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 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

View File

@ -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

View File

@ -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

View File

@ -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