WIP display errors in parallel

This commit is contained in:
Nathan Dwarshuis 2023-01-26 23:41:45 -05:00
parent fc6cde2716
commit d3837feea5
4 changed files with 88 additions and 54 deletions

View File

@ -163,7 +163,7 @@ runSync c = do
sync_ config = migrate_ (sqlConfig config) $ do
res <- getDBState config
case res of
Left e -> throwIO $ InsertException [e]
Left es -> throwIO $ InsertException es
Right s -> flip runReaderT (s $ takeDirectory c) $ do
es1 <- insertBudget $ budget config
es2 <- insertStatements config

View File

@ -305,13 +305,11 @@ indexAcntRoot r =
getDBState
:: MonadUnliftIO m
=> Config
-> SqlPersistT m (EitherErr (FilePath -> DBState))
getDBState c = mapM (uncurry go) intervals
-> SqlPersistT m (EitherErrs (FilePath -> DBState))
getDBState c = mapM (uncurry go) $ mapError2 bi si (,)
where
intervals = do
b <- intervalMaybeBounds $ budgetInterval $ global c
s <- intervalMaybeBounds $ statementInterval $ global c
return (b, s)
bi = intervalMaybeBounds $ budgetInterval $ global c
si = intervalMaybeBounds $ statementInterval $ global c
go budgetInt statementInt = do
am <- updateAccounts $ accounts c
cm <- updateCurrencies $ currencies c

View File

@ -23,6 +23,7 @@ import Dhall.TH
import Language.Haskell.TH.Syntax (Lift)
import RIO
import qualified RIO.Map as M
-- import RIO.State
import qualified RIO.Text as T
import RIO.Time
@ -526,3 +527,12 @@ newtype InsertException = InsertException [InsertError] deriving (Show)
instance Exception InsertException
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

View File

@ -18,7 +18,6 @@ import Text.Regex.TDFA
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)
-- TODO get rid of these errors
gregTup :: Gregorian -> EitherErr (Integer, Int, Int)
gregTup Gregorian {..}
| gYear > 99 = Left $ YearError gYear
@ -85,12 +84,10 @@ valMatches MatchVal {..} x =
p = 10 ^ mvPrec
s = signum x >= 0
evalSplit :: TxRecord -> ExpSplit -> EitherErr RawSplit
evalSplit r s@Split {sAcnt = a, sValue = v, sCurrency = c} = do
a_ <- evalAcnt r a
v_ <- mapM (evalExp r) v
c_ <- evalCurrency r c
return (s {sAcnt = a_, sValue = v_, sCurrency = c_})
evalSplit :: TxRecord -> ExpSplit -> EitherErrs RawSplit
evalSplit r s@Split {sAcnt = a, sValue = v, sCurrency = c} =
concatEither3 (evalAcnt r a) (evalCurrency r c) (mapM (evalExp r) v) $
\a_ c_ v_ -> (s {sAcnt = a_, sValue = v_, sCurrency = c_})
evalAcnt :: TxRecord -> SplitAcnt -> EitherErr T.Text
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
lookupErr AccountField (k1, k2) m
-- TODO wett codde
evalCurrency :: TxRecord -> SplitCur -> EitherErr T.Text
evalCurrency TxRecord {trOther = o} s = case s of
ConstT p -> Right p
@ -119,24 +117,22 @@ evalCurrency TxRecord {trOther = o} s = case s of
errorT :: T.Text -> a
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 what k m = case M.lookup k m of
Just x -> Right x
_ -> Left $ LookupError what $ showT k
matches :: Match -> TxRecord -> EitherErr (MatchRes RawTx)
matches :: Match -> TxRecord -> EitherErrs (MatchRes RawTx)
matches Match {..} r@TxRecord {..} = do
date <- maybe (Right True) (`dateMatches` trDate) mDate
let val = valMatches mVal trAmount
other <- foldM (\a o -> (a &&) <$> fieldMatches trOther o) True mOther
desc <- maybe (return True) (matchMaybe trDesc) mDesc
if date && val && desc && other
res <- concatEither3 date other desc (\x y z -> x && y && z)
if val && res
then maybe (Right MatchSkip) (fmap MatchPass . eval) mTx
else Right MatchFail
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
matchMaybe :: RegexContext Regex query b => query -> T.Text -> EitherErr b
@ -154,11 +150,9 @@ fieldMatches dict m = case m of
checkMaybe :: (a -> Bool) -> Maybe a -> Bool
checkMaybe = maybe True
toTx :: SplitCur -> SplitAcnt -> [ExpSplit] -> TxRecord -> EitherErr RawTx
toTx sc sa toSplits r@TxRecord {..} = do
a_ <- evalAcnt r sa
c_ <- evalCurrency r sc
ss_ <- mapM (evalSplit r) toSplits
toTx :: SplitCur -> SplitAcnt -> [ExpSplit] -> TxRecord -> EitherErrs RawTx
toTx sc sa toSplits r@TxRecord {..} =
concatEithers2 acRes ssRes $ \(a_, c_) ss_ ->
let fromSplit =
Split
{ sAcnt = a_
@ -166,13 +160,15 @@ toTx sc sa toSplits r@TxRecord {..} = do
, sValue = Just trAmount
, sComment = ""
}
return $
Tx
in Tx
{ txTags = []
, txDate = trDate
, txDescr = trDesc
, txSplits = fromSplit : ss_
}
where
acRes = concatEither2 (evalAcnt r sa) (evalCurrency r sc) (,)
ssRes = concatEithersL $ fmap (evalSplit r) toSplits
parseRational :: MonadFail m => T.Text -> T.Text -> m Rational
parseRational pat s = case ms of
@ -207,9 +203,6 @@ parseRational pat s = case ms of
k <- readSign sign
return (k, w)
-- readRationalMsg :: T.Text -> EitherErr Rational
-- readRationalMsg t = maybe (Left $ ConversionError t) Right $ readRational t
readRational :: T.Text -> EitherErr Rational
readRational s = case T.split (== '.') s of
[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 f t@Tx {txSplits = ss} = t {txSplits = fmap f ss}
boundsFromGregorian :: (Gregorian, Gregorian) -> EitherErr Bounds
boundsFromGregorian (a, b) = do
a_ <- fromGregorian' a
b_ <- fromGregorian' b
return (a_, b_)
boundsFromGregorian :: (Gregorian, Gregorian) -> EitherErrs Bounds
boundsFromGregorian (a, b) = concatEither2 a_ b_ (,)
where
a_ = fromGregorian' a
b_ = fromGregorian' b
fromGregorian' :: Gregorian -> EitherErr Day
fromGregorian' = fmap (uncurry3 fromGregorian) . gregTup
@ -243,11 +236,11 @@ inBounds (d0, d1) x = d0 <= x && x <= d1
inMaybeBounds :: MaybeBounds -> Day -> Bool
inMaybeBounds (d0, d1) x = maybe True (x >=) d0 && maybe True (x <=) d1
intervalMaybeBounds :: Interval -> EitherErr MaybeBounds
intervalMaybeBounds Interval {intStart = s, intEnd = e} = do
s_ <- mapM fromGregorian' s
e_ <- mapM fromGregorian' e
return (s_, e_)
intervalMaybeBounds :: Interval -> EitherErrs MaybeBounds
intervalMaybeBounds Interval {intStart = s, intEnd = e} = concatEither2 s_ e_ (,)
where
s_ = mapM fromGregorian' s
e_ = mapM fromGregorian' e
resolveBounds :: MonadUnliftIO m => MaybeBounds -> m Bounds
resolveBounds (s, e) = do
@ -386,3 +379,36 @@ keyVal a b = T.concat [a, "=", b]
keyVals :: [(T.Text, T.Text)] -> T.Text
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