WIP display errors in parallel
This commit is contained in:
parent
fc6cde2716
commit
d3837feea5
|
@ -163,7 +163,7 @@ runSync c = do
|
||||||
sync_ config = migrate_ (sqlConfig config) $ do
|
sync_ config = migrate_ (sqlConfig config) $ do
|
||||||
res <- getDBState config
|
res <- getDBState config
|
||||||
case res of
|
case res of
|
||||||
Left e -> throwIO $ InsertException [e]
|
Left es -> throwIO $ InsertException es
|
||||||
Right s -> flip runReaderT (s $ takeDirectory c) $ do
|
Right s -> flip runReaderT (s $ takeDirectory c) $ do
|
||||||
es1 <- insertBudget $ budget config
|
es1 <- insertBudget $ budget config
|
||||||
es2 <- insertStatements config
|
es2 <- insertStatements config
|
||||||
|
|
|
@ -305,13 +305,11 @@ indexAcntRoot r =
|
||||||
getDBState
|
getDBState
|
||||||
:: MonadUnliftIO m
|
:: MonadUnliftIO m
|
||||||
=> Config
|
=> Config
|
||||||
-> SqlPersistT m (EitherErr (FilePath -> DBState))
|
-> SqlPersistT m (EitherErrs (FilePath -> DBState))
|
||||||
getDBState c = mapM (uncurry go) intervals
|
getDBState c = mapM (uncurry go) $ mapError2 bi si (,)
|
||||||
where
|
where
|
||||||
intervals = do
|
bi = intervalMaybeBounds $ budgetInterval $ global c
|
||||||
b <- intervalMaybeBounds $ budgetInterval $ global c
|
si = intervalMaybeBounds $ statementInterval $ global c
|
||||||
s <- intervalMaybeBounds $ statementInterval $ global c
|
|
||||||
return (b, s)
|
|
||||||
go budgetInt statementInt = do
|
go budgetInt statementInt = do
|
||||||
am <- updateAccounts $ accounts c
|
am <- updateAccounts $ accounts c
|
||||||
cm <- updateCurrencies $ currencies c
|
cm <- updateCurrencies $ currencies c
|
||||||
|
|
|
@ -23,6 +23,7 @@ import Dhall.TH
|
||||||
import Language.Haskell.TH.Syntax (Lift)
|
import Language.Haskell.TH.Syntax (Lift)
|
||||||
import RIO
|
import RIO
|
||||||
import qualified RIO.Map as M
|
import qualified RIO.Map as M
|
||||||
|
-- import RIO.State
|
||||||
import qualified RIO.Text as T
|
import qualified RIO.Text as T
|
||||||
import RIO.Time
|
import RIO.Time
|
||||||
|
|
||||||
|
@ -526,3 +527,12 @@ newtype InsertException = InsertException [InsertError] deriving (Show)
|
||||||
instance Exception InsertException
|
instance Exception InsertException
|
||||||
|
|
||||||
type EitherErr = Either InsertError
|
type EitherErr = Either InsertError
|
||||||
|
|
||||||
|
type EitherErrs = Either [InsertError]
|
||||||
|
|
||||||
|
-- type StateErr = State [InsertError]
|
||||||
|
|
||||||
|
-- runErrors :: StateErr a -> Either [InsertError] a
|
||||||
|
-- runErrors x = case runState x [] of
|
||||||
|
-- (y, []) -> Right y
|
||||||
|
-- (_, es) -> Left es
|
||||||
|
|
|
@ -18,7 +18,6 @@ import Text.Regex.TDFA
|
||||||
thrice :: (a -> d) -> (b -> e) -> (c -> f) -> (a, b, c) -> (d, e, f)
|
thrice :: (a -> d) -> (b -> e) -> (c -> f) -> (a, b, c) -> (d, e, f)
|
||||||
thrice f1 f2 f3 (x, y, z) = (f1 x, f2 y, f3 z)
|
thrice f1 f2 f3 (x, y, z) = (f1 x, f2 y, f3 z)
|
||||||
|
|
||||||
-- TODO get rid of these errors
|
|
||||||
gregTup :: Gregorian -> EitherErr (Integer, Int, Int)
|
gregTup :: Gregorian -> EitherErr (Integer, Int, Int)
|
||||||
gregTup Gregorian {..}
|
gregTup Gregorian {..}
|
||||||
| gYear > 99 = Left $ YearError gYear
|
| gYear > 99 = Left $ YearError gYear
|
||||||
|
@ -85,12 +84,10 @@ valMatches MatchVal {..} x =
|
||||||
p = 10 ^ mvPrec
|
p = 10 ^ mvPrec
|
||||||
s = signum x >= 0
|
s = signum x >= 0
|
||||||
|
|
||||||
evalSplit :: TxRecord -> ExpSplit -> EitherErr RawSplit
|
evalSplit :: TxRecord -> ExpSplit -> EitherErrs RawSplit
|
||||||
evalSplit r s@Split {sAcnt = a, sValue = v, sCurrency = c} = do
|
evalSplit r s@Split {sAcnt = a, sValue = v, sCurrency = c} =
|
||||||
a_ <- evalAcnt r a
|
concatEither3 (evalAcnt r a) (evalCurrency r c) (mapM (evalExp r) v) $
|
||||||
v_ <- mapM (evalExp r) v
|
\a_ c_ v_ -> (s {sAcnt = a_, sValue = v_, sCurrency = c_})
|
||||||
c_ <- evalCurrency r c
|
|
||||||
return (s {sAcnt = a_, sValue = v_, sCurrency = c_})
|
|
||||||
|
|
||||||
evalAcnt :: TxRecord -> SplitAcnt -> EitherErr T.Text
|
evalAcnt :: TxRecord -> SplitAcnt -> EitherErr T.Text
|
||||||
evalAcnt TxRecord {trOther = o} s = case s of
|
evalAcnt TxRecord {trOther = o} s = case s of
|
||||||
|
@ -104,6 +101,7 @@ evalAcnt TxRecord {trOther = o} s = case s of
|
||||||
k2 <- lookupErr AccountField f2 o
|
k2 <- lookupErr AccountField f2 o
|
||||||
lookupErr AccountField (k1, k2) m
|
lookupErr AccountField (k1, k2) m
|
||||||
|
|
||||||
|
-- TODO wett codde
|
||||||
evalCurrency :: TxRecord -> SplitCur -> EitherErr T.Text
|
evalCurrency :: TxRecord -> SplitCur -> EitherErr T.Text
|
||||||
evalCurrency TxRecord {trOther = o} s = case s of
|
evalCurrency TxRecord {trOther = o} s = case s of
|
||||||
ConstT p -> Right p
|
ConstT p -> Right p
|
||||||
|
@ -119,24 +117,22 @@ evalCurrency TxRecord {trOther = o} s = case s of
|
||||||
errorT :: T.Text -> a
|
errorT :: T.Text -> a
|
||||||
errorT = error . T.unpack
|
errorT = error . T.unpack
|
||||||
|
|
||||||
-- lookupField :: (Ord k, Show k) => k -> M.Map k v -> v
|
|
||||||
-- lookupField = lookupErr "field"
|
|
||||||
|
|
||||||
lookupErr :: (Ord k, Show k) => LookupField -> k -> M.Map k v -> EitherErr v
|
lookupErr :: (Ord k, Show k) => LookupField -> k -> M.Map k v -> EitherErr v
|
||||||
lookupErr what k m = case M.lookup k m of
|
lookupErr what k m = case M.lookup k m of
|
||||||
Just x -> Right x
|
Just x -> Right x
|
||||||
_ -> Left $ LookupError what $ showT k
|
_ -> Left $ LookupError what $ showT k
|
||||||
|
|
||||||
matches :: Match -> TxRecord -> EitherErr (MatchRes RawTx)
|
matches :: Match -> TxRecord -> EitherErrs (MatchRes RawTx)
|
||||||
matches Match {..} r@TxRecord {..} = do
|
matches Match {..} r@TxRecord {..} = do
|
||||||
date <- maybe (Right True) (`dateMatches` trDate) mDate
|
res <- concatEither3 date other desc (\x y z -> x && y && z)
|
||||||
let val = valMatches mVal trAmount
|
if val && res
|
||||||
other <- foldM (\a o -> (a &&) <$> fieldMatches trOther o) True mOther
|
|
||||||
desc <- maybe (return True) (matchMaybe trDesc) mDesc
|
|
||||||
if date && val && desc && other
|
|
||||||
then maybe (Right MatchSkip) (fmap MatchPass . eval) mTx
|
then maybe (Right MatchSkip) (fmap MatchPass . eval) mTx
|
||||||
else Right MatchFail
|
else Right MatchFail
|
||||||
where
|
where
|
||||||
|
val = valMatches mVal trAmount
|
||||||
|
date = maybe (Right True) (`dateMatches` trDate) mDate
|
||||||
|
other = foldM (\a o -> (a &&) <$> fieldMatches trOther o) True mOther
|
||||||
|
desc = maybe (return True) (matchMaybe trDesc) mDesc
|
||||||
eval (ToTx cur a ss) = toTx cur a ss r
|
eval (ToTx cur a ss) = toTx cur a ss r
|
||||||
|
|
||||||
matchMaybe :: RegexContext Regex query b => query -> T.Text -> EitherErr b
|
matchMaybe :: RegexContext Regex query b => query -> T.Text -> EitherErr b
|
||||||
|
@ -154,25 +150,25 @@ fieldMatches dict m = case m of
|
||||||
checkMaybe :: (a -> Bool) -> Maybe a -> Bool
|
checkMaybe :: (a -> Bool) -> Maybe a -> Bool
|
||||||
checkMaybe = maybe True
|
checkMaybe = maybe True
|
||||||
|
|
||||||
toTx :: SplitCur -> SplitAcnt -> [ExpSplit] -> TxRecord -> EitherErr RawTx
|
toTx :: SplitCur -> SplitAcnt -> [ExpSplit] -> TxRecord -> EitherErrs RawTx
|
||||||
toTx sc sa toSplits r@TxRecord {..} = do
|
toTx sc sa toSplits r@TxRecord {..} =
|
||||||
a_ <- evalAcnt r sa
|
concatEithers2 acRes ssRes $ \(a_, c_) ss_ ->
|
||||||
c_ <- evalCurrency r sc
|
let fromSplit =
|
||||||
ss_ <- mapM (evalSplit r) toSplits
|
Split
|
||||||
let fromSplit =
|
{ sAcnt = a_
|
||||||
Split
|
, sCurrency = c_
|
||||||
{ sAcnt = a_
|
, sValue = Just trAmount
|
||||||
, sCurrency = c_
|
, sComment = ""
|
||||||
, sValue = Just trAmount
|
}
|
||||||
, sComment = ""
|
in Tx
|
||||||
|
{ txTags = []
|
||||||
|
, txDate = trDate
|
||||||
|
, txDescr = trDesc
|
||||||
|
, txSplits = fromSplit : ss_
|
||||||
}
|
}
|
||||||
return $
|
where
|
||||||
Tx
|
acRes = concatEither2 (evalAcnt r sa) (evalCurrency r sc) (,)
|
||||||
{ txTags = []
|
ssRes = concatEithersL $ fmap (evalSplit r) toSplits
|
||||||
, txDate = trDate
|
|
||||||
, txDescr = trDesc
|
|
||||||
, txSplits = fromSplit : ss_
|
|
||||||
}
|
|
||||||
|
|
||||||
parseRational :: MonadFail m => T.Text -> T.Text -> m Rational
|
parseRational :: MonadFail m => T.Text -> T.Text -> m Rational
|
||||||
parseRational pat s = case ms of
|
parseRational pat s = case ms of
|
||||||
|
@ -207,9 +203,6 @@ parseRational pat s = case ms of
|
||||||
k <- readSign sign
|
k <- readSign sign
|
||||||
return (k, w)
|
return (k, w)
|
||||||
|
|
||||||
-- readRationalMsg :: T.Text -> EitherErr Rational
|
|
||||||
-- readRationalMsg t = maybe (Left $ ConversionError t) Right $ readRational t
|
|
||||||
|
|
||||||
readRational :: T.Text -> EitherErr Rational
|
readRational :: T.Text -> EitherErr Rational
|
||||||
readRational s = case T.split (== '.') s of
|
readRational s = case T.split (== '.') s of
|
||||||
[x] -> maybe err (return . fromInteger) $ readT x
|
[x] -> maybe err (return . fromInteger) $ readT x
|
||||||
|
@ -228,11 +221,11 @@ readRational s = case T.split (== '.') s of
|
||||||
mapTxSplits :: (a -> b) -> Tx a -> Tx b
|
mapTxSplits :: (a -> b) -> Tx a -> Tx b
|
||||||
mapTxSplits f t@Tx {txSplits = ss} = t {txSplits = fmap f ss}
|
mapTxSplits f t@Tx {txSplits = ss} = t {txSplits = fmap f ss}
|
||||||
|
|
||||||
boundsFromGregorian :: (Gregorian, Gregorian) -> EitherErr Bounds
|
boundsFromGregorian :: (Gregorian, Gregorian) -> EitherErrs Bounds
|
||||||
boundsFromGregorian (a, b) = do
|
boundsFromGregorian (a, b) = concatEither2 a_ b_ (,)
|
||||||
a_ <- fromGregorian' a
|
where
|
||||||
b_ <- fromGregorian' b
|
a_ = fromGregorian' a
|
||||||
return (a_, b_)
|
b_ = fromGregorian' b
|
||||||
|
|
||||||
fromGregorian' :: Gregorian -> EitherErr Day
|
fromGregorian' :: Gregorian -> EitherErr Day
|
||||||
fromGregorian' = fmap (uncurry3 fromGregorian) . gregTup
|
fromGregorian' = fmap (uncurry3 fromGregorian) . gregTup
|
||||||
|
@ -243,11 +236,11 @@ inBounds (d0, d1) x = d0 <= x && x <= d1
|
||||||
inMaybeBounds :: MaybeBounds -> Day -> Bool
|
inMaybeBounds :: MaybeBounds -> Day -> Bool
|
||||||
inMaybeBounds (d0, d1) x = maybe True (x >=) d0 && maybe True (x <=) d1
|
inMaybeBounds (d0, d1) x = maybe True (x >=) d0 && maybe True (x <=) d1
|
||||||
|
|
||||||
intervalMaybeBounds :: Interval -> EitherErr MaybeBounds
|
intervalMaybeBounds :: Interval -> EitherErrs MaybeBounds
|
||||||
intervalMaybeBounds Interval {intStart = s, intEnd = e} = do
|
intervalMaybeBounds Interval {intStart = s, intEnd = e} = concatEither2 s_ e_ (,)
|
||||||
s_ <- mapM fromGregorian' s
|
where
|
||||||
e_ <- mapM fromGregorian' e
|
s_ = mapM fromGregorian' s
|
||||||
return (s_, e_)
|
e_ = mapM fromGregorian' e
|
||||||
|
|
||||||
resolveBounds :: MonadUnliftIO m => MaybeBounds -> m Bounds
|
resolveBounds :: MonadUnliftIO m => MaybeBounds -> m Bounds
|
||||||
resolveBounds (s, e) = do
|
resolveBounds (s, e) = do
|
||||||
|
@ -386,3 +379,36 @@ keyVal a b = T.concat [a, "=", b]
|
||||||
|
|
||||||
keyVals :: [(T.Text, T.Text)] -> T.Text
|
keyVals :: [(T.Text, T.Text)] -> T.Text
|
||||||
keyVals = T.intercalate "; " . fmap (uncurry keyVal)
|
keyVals = T.intercalate "; " . fmap (uncurry keyVal)
|
||||||
|
|
||||||
|
concatEither2 :: Either x a -> Either x b -> (a -> b -> c) -> Either [x] c
|
||||||
|
concatEither2 a b fun = case (a, b) of
|
||||||
|
(Right a_, Right b_) -> Right $ fun a_ b_
|
||||||
|
_ -> Left $ catMaybes [leftToMaybe a, leftToMaybe b]
|
||||||
|
|
||||||
|
concatEither3 :: Either x a -> Either x b -> Either x c -> (a -> b -> c -> d) -> Either [x] d
|
||||||
|
concatEither3 a b c fun = case (a, b, c) of
|
||||||
|
(Right a_, Right b_, Right c_) -> Right $ fun a_ b_ c_
|
||||||
|
_ -> Left $ catMaybes [leftToMaybe a, leftToMaybe b, leftToMaybe c]
|
||||||
|
|
||||||
|
concatEithers2 :: Either [x] a -> Either [x] b -> (a -> b -> c) -> Either [x] c
|
||||||
|
concatEithers2 a b = first concat . concatEither2 a b
|
||||||
|
|
||||||
|
concatEithers3
|
||||||
|
:: Either [x] a
|
||||||
|
-> Either [x] b
|
||||||
|
-> Either [x] c
|
||||||
|
-> (a -> b -> c -> d)
|
||||||
|
-> Either [x] d
|
||||||
|
concatEithers3 a b c = first concat . concatEither3 a b c
|
||||||
|
|
||||||
|
concatEitherL :: [Either x a] -> Either [x] [a]
|
||||||
|
concatEitherL as = case partitionEithers as of
|
||||||
|
([], bs) -> Right bs
|
||||||
|
(es, _) -> Left es
|
||||||
|
|
||||||
|
concatEithersL :: [Either [x] a] -> Either [x] [a]
|
||||||
|
concatEithersL = first concat . concatEitherL
|
||||||
|
|
||||||
|
leftToMaybe :: Either a b -> Maybe a
|
||||||
|
leftToMaybe (Left a) = Just a
|
||||||
|
leftToMaybe _ = Nothing
|
||||||
|
|
Loading…
Reference in New Issue