From 6a43a9a78ac79da630155cddd9fe21db2073188e Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Fri, 27 Jan 2023 20:31:13 -0500 Subject: [PATCH] ENH show errors in parallel --- lib/Internal/Database/Ops.hs | 2 +- lib/Internal/Insert.hs | 85 ++++++++++++++++-------------------- lib/Internal/Statement.hs | 36 ++++++++------- lib/Internal/Types.hs | 8 ++++ lib/Internal/Utils.hs | 9 ++++ 5 files changed, 76 insertions(+), 64 deletions(-) diff --git a/lib/Internal/Database/Ops.hs b/lib/Internal/Database/Ops.hs index db37438..932cc6c 100644 --- a/lib/Internal/Database/Ops.hs +++ b/lib/Internal/Database/Ops.hs @@ -306,7 +306,7 @@ getDBState :: MonadUnliftIO m => Config -> SqlPersistT m (EitherErrs (FilePath -> DBState)) -getDBState c = mapM (uncurry go) $ mapError2 bi si (,) +getDBState c = mapM (uncurry go) $ concatEithers2 bi si (,) where bi = intervalMaybeBounds $ budgetInterval $ global c si = intervalMaybeBounds $ statementInterval $ global c diff --git a/lib/Internal/Insert.hs b/lib/Internal/Insert.hs index dd73662..fbcc0fa 100644 --- a/lib/Internal/Insert.hs +++ b/lib/Internal/Insert.hs @@ -8,6 +8,7 @@ module Internal.Insert ) where +import Data.Bitraversable import Data.Hashable import Database.Persist.Class import Database.Persist.Sql hiding (Single, Statement) @@ -122,7 +123,7 @@ insertBudget :: MonadUnliftIO m => Budget -> MappingT m [InsertError] insertBudget Budget {income = is, expenses = es} = do es1 <- mapM insertIncome is es2 <- mapM insertExpense es - return $ catMaybes es1 ++ concat es2 + return $ concat $ es1 ++ es2 -- TODO this hashes twice (not that it really matters) whenHash @@ -137,7 +138,7 @@ whenHash t o def f = do hs <- asks kmNewCommits if h `elem` hs then f =<< lift (insert $ CommitR h t) else return def -insertIncome :: MonadUnliftIO m => Income -> MappingT m (Maybe InsertError) +insertIncome :: MonadUnliftIO m => Income -> MappingT m [InsertError] insertIncome i@Income { incCurrency = cur @@ -145,21 +146,18 @@ insertIncome , incAccount = from , incTaxes = ts } = - whenHash CTIncome i Nothing $ \c -> do - case balanceIncome i of - Left m -> liftIO $ print m >> return Nothing - Right as -> do - bounds <- (liftIO . resolveBounds) =<< asks kmBudgetInterval - case expandDatePat bounds dp of - Left e -> return $ Just e - Right days -> do - forM_ days $ \day -> do - alloTx <- concat <$> mapM (allocationToTx from day) as - taxTx <- fmap (,Fixed) <$> mapM (taxToTx from day cur) ts - lift $ mapM_ (\(t, b) -> insertTxBucket (Just b) c t) $ alloTx ++ taxTx - return Nothing + whenHash CTIncome i [] $ \c -> do + bounds <- (liftIO . resolveBounds) =<< asks kmBudgetInterval + case (balanceIncome i, expandDatePat bounds dp) of + (Right balanced, Right days) -> do + forM_ days $ \day -> do + alloTx <- concat <$> mapM (allocationToTx from day) balanced + taxTx <- fmap (,Fixed) <$> mapM (taxToTx from day cur) ts + lift $ mapM_ (\(t, b) -> insertTxBucket (Just b) c t) $ alloTx ++ taxTx + return [] + (a, b) -> return $ catMaybes [leftToMaybe a, leftToMaybe b] -balanceIncome :: Income -> Either T.Text [BalAllocation] +balanceIncome :: Income -> EitherErr [BalAllocation] balanceIncome Income { incGross = g @@ -181,17 +179,19 @@ sumAllocations = sum . concatMap (fmap amtValue . alloAmts) sumTaxes :: [Tax] -> Rational sumTaxes = sum . fmap (dec2Rat . taxValue) -balancePostTax :: Rational -> [RawAllocation] -> Either T.Text [BalAllocation] +-- TODO these errors could be more descriptive by including an indicator +-- of the budget itself +balancePostTax :: Rational -> [RawAllocation] -> EitherErr [BalAllocation] balancePostTax bal as - | null as = Left "no allocations to balance" + | null as = Left $ AllocationError NoAllocations | otherwise = case partitionEithers $ fmap hasVal as of ([([empty], nonmissing)], bs) -> let s = bal - sumAllocations (nonmissing : bs) in if s < 0 - then Left "allocations exceed total" + then Left $ AllocationError ExceededTotal else Right $ mapAmts (empty {amtValue = s} :) nonmissing : bs - ([], _) -> Left "need one blank amount to balance" - _ -> Left "multiple blank amounts present" + ([], _) -> Left $ AllocationError MissingBlank + _ -> Left $ AllocationError TooManyBlanks where hasVal a@Allocation {alloAmts = xs} = case partitionEithers $ fmap maybeAmt xs of @@ -245,15 +245,12 @@ insertExpense , expBucket = buc , expAmounts = as } = do - whenHash CTExpense e [] $ \key -> catMaybes <$> mapM (go key) as + whenHash CTExpense e [] $ \key -> concat <$> mapM (go key) as where go key amt = do res <- timeAmountToTx from to cur amt - case res of - Left err -> return $ Just err - Right txs -> do - lift $ mapM_ (insertTxBucket (Just buc) key) txs - return Nothing + unlessLeft res $ + lift . mapM_ (insertTxBucket (Just buc) key) timeAmountToTx :: MonadUnliftIO m @@ -275,9 +272,7 @@ timeAmountToTx } } = do bounds <- (liftIO . resolveBounds) =<< asks kmBudgetInterval - case expandDatePat bounds dp of - Left e -> return $ Left e - Right days -> Right <$> mapM tx days + bimapM return (mapM tx) $ expandDatePat bounds dp where tx day = txPair day from to cur (dec2Rat v) d @@ -285,15 +280,15 @@ timeAmountToTx -- statements insertStatements :: MonadUnliftIO m => Config -> MappingT m [InsertError] -insertStatements conf = catMaybes <$> mapM insertStatement (statements conf) +insertStatements conf = concat <$> mapM insertStatement (statements conf) -- unless (null es) $ throwIO $ InsertException es -insertStatement :: MonadUnliftIO m => Statement -> MappingT m (Maybe InsertError) +insertStatement :: MonadUnliftIO m => Statement -> MappingT m [InsertError] insertStatement (StmtManual m) = insertManual m insertStatement (StmtImport i) = insertImport i -insertManual :: MonadUnliftIO m => Manual -> MappingT m (Maybe InsertError) +insertManual :: MonadUnliftIO m => Manual -> MappingT m [InsertError] insertManual m@Manual { manualDate = dp @@ -303,29 +298,23 @@ insertManual , manualCurrency = u , manualDesc = e } = do - whenHash CTManual m Nothing $ \c -> do + whenHash CTManual m [] $ \c -> do bounds <- (liftIO . resolveBounds) =<< asks kmStatementInterval - case expandDatePat bounds dp of - Left err -> return $ Just err - Right days -> do - ts <- mapM tx days - lift $ mapM_ (insertTx c) ts - return Nothing + unlessLeft (expandDatePat bounds dp) $ \days -> do + ts <- mapM tx days + lift $ mapM_ (insertTx c) ts where tx day = txPair day from to u (dec2Rat v) e -insertImport :: MonadUnliftIO m => Import -> MappingT m (Maybe InsertError) -insertImport i = whenHash CTImport i Nothing $ \c -> do +insertImport :: MonadUnliftIO m => Import -> MappingT m [InsertError] +insertImport i = whenHash CTImport i [] $ \c -> do bounds <- asks kmStatementInterval res <- readImport i -- TODO this isn't efficient, the whole file will be read and maybe no -- transactions will be desired - case res of - Right bs -> do - rs <- mapM resolveTx $ filter (inMaybeBounds bounds . txDate) bs - lift $ mapM_ (insertTx c) rs - return Nothing - Left e -> return $ Just e + unlessLefts res $ \bs -> do + rs <- mapM resolveTx $ filter (inMaybeBounds bounds . txDate) bs + lift $ mapM_ (insertTx c) rs -------------------------------------------------------------------------------- -- low-level transaction stuff diff --git a/lib/Internal/Statement.hs b/lib/Internal/Statement.hs index 5d42b3d..6ecbc83 100644 --- a/lib/Internal/Statement.hs +++ b/lib/Internal/Statement.hs @@ -23,7 +23,7 @@ import qualified RIO.Vector as V -- TODO this probably won't scale well (pipes?) -readImport :: MonadUnliftIO m => Import -> MappingT m (EitherErr [BalTx]) +readImport :: MonadUnliftIO m => Import -> MappingT m (EitherErrs [BalTx]) readImport Import {..} = matchRecords impMatches . L.sort . concat <$> mapM (readImport_ impSkipLines impDelim impTxOpts) impPaths @@ -59,14 +59,15 @@ parseTxRecord p TxOpts {..} r = do d' <- parseTimeM True defaultTimeLocale (T.unpack toDateFmt) d return $ Just $ TxRecord d' a e os p -matchRecords :: [Match] -> [TxRecord] -> EitherErr [BalTx] +matchRecords :: [Match] -> [TxRecord] -> EitherErrs [BalTx] matchRecords ms rs = do (matched, unmatched, notfound) <- matchAll (matchPriorities ms) rs - -- TODO record number of times each match hits for debugging - matched_ <- mapM balanceTx matched - case (matched_, unmatched, notfound) of - (xs, [], []) -> Right xs - (_, us, ns) -> Left $ StatementError us ns + case (matched, unmatched, notfound) of + (ms_, [], []) -> do + -- TODO record number of times each match hits for debugging + matched_ <- first (: []) $ mapM balanceTx ms_ + Right matched_ + (_, us, ns) -> Left [StatementError us ns] matchPriorities :: [Match] -> [MatchGroup] matchPriorities = @@ -100,7 +101,12 @@ resetZipper = initZipper . recoverZipper recoverZipper :: Zipped a -> [a] recoverZipper (Zipped as bs) = reverse as ++ bs -zipperSlice :: Monad m => (a -> b -> m Ordering) -> b -> Zipped a -> m (Either (Zipped a) (Unzipped a)) +zipperSlice + :: Monad m + => (a -> b -> m Ordering) + -> b + -> Zipped a + -> m (Either (Zipped a) (Unzipped a)) zipperSlice f x = go where go z@(Zipped _ []) = return $ Left z @@ -118,7 +124,7 @@ zipperSlice f x = go EQ -> goEq $ Unzipped bs (a : cs) as LT -> return z -zipperMatch :: Unzipped Match -> TxRecord -> EitherErr (Zipped Match, MatchRes RawTx) +zipperMatch :: Unzipped Match -> TxRecord -> EitherErrs (Zipped Match, MatchRes RawTx) zipperMatch (Unzipped bs cs as) x = go [] cs where go _ [] = Right (Zipped bs $ cs ++ as, MatchFail) @@ -131,7 +137,7 @@ zipperMatch (Unzipped bs cs as) x = go [] cs ms' = maybe ms (: ms) (matchDec m) in Right (Zipped bs $ ps ++ ms' ++ as, skipOrPass) -zipperMatch' :: Zipped Match -> TxRecord -> EitherErr (Zipped Match, MatchRes RawTx) +zipperMatch' :: Zipped Match -> TxRecord -> EitherErrs (Zipped Match, MatchRes RawTx) zipperMatch' z x = go z where go (Zipped bs (a : as)) = do @@ -147,7 +153,7 @@ matchDec m@Match {mTimes = t} = where t' = fmap pred t -matchAll :: [MatchGroup] -> [TxRecord] -> EitherErr ([RawTx], [TxRecord], [Match]) +matchAll :: [MatchGroup] -> [TxRecord] -> EitherErrs ([RawTx], [TxRecord], [Match]) matchAll = go ([], []) where go (matched, unused) gs rs = case (gs, rs) of @@ -157,13 +163,13 @@ matchAll = go ([], []) (ts, unmatched, us) <- matchGroup g rs go (ts ++ matched, us ++ unused) gs' unmatched -matchGroup :: MatchGroup -> [TxRecord] -> EitherErr ([RawTx], [TxRecord], [Match]) +matchGroup :: MatchGroup -> [TxRecord] -> EitherErrs ([RawTx], [TxRecord], [Match]) matchGroup MatchGroup {mgDate = ds, mgNoDate = ns} rs = do (md, rest, ud) <- matchDates ds rs (mn, unmatched, un) <- matchNonDates ns rest return (md ++ mn, unmatched, filter ((/= Nothing) . mTimes) $ ud ++ un) -matchDates :: [Match] -> [TxRecord] -> EitherErr ([RawTx], [TxRecord], [Match]) +matchDates :: [Match] -> [TxRecord] -> EitherErrs ([RawTx], [TxRecord], [Match]) matchDates ms = go ([], [], initZipper ms) where go (matched, unmatched, z) [] = @@ -183,9 +189,9 @@ matchDates ms = go ([], [], initZipper ms) MatchSkip -> (Nothing : matched, unmatched) MatchFail -> (matched, r : unmatched) go (m, u, z') rs - findDate m r = maybe (Right EQ) (`compareDate` trDate r) $ mDate m + findDate m r = maybe (Right EQ) (first (: []) . (`compareDate` trDate r)) $ mDate m -matchNonDates :: [Match] -> [TxRecord] -> EitherErr ([RawTx], [TxRecord], [Match]) +matchNonDates :: [Match] -> [TxRecord] -> EitherErrs ([RawTx], [TxRecord], [Match]) matchNonDates ms = go ([], [], initZipper ms) where go (matched, unmatched, z) [] = diff --git a/lib/Internal/Types.hs b/lib/Internal/Types.hs index f39aa68..8918b01 100644 --- a/lib/Internal/Types.hs +++ b/lib/Internal/Types.hs @@ -511,6 +511,13 @@ data BalanceType = TooFewSplits | NotOneBlank deriving (Show) data LookupField = AccountField | CurrencyField | OtherField deriving (Show) +data AllocationSuberr + = NoAllocations + | ExceededTotal + | MissingBlank + | TooManyBlanks + deriving (Show) + -- data ConversionSubError = Malformed | deriving (Show) data InsertError @@ -519,6 +526,7 @@ data InsertError | ConversionError T.Text | LookupError LookupField T.Text | BalanceError BalanceType CurID [RawSplit] + | AllocationError AllocationSuberr | StatementError [TxRecord] [Match] deriving (Show) diff --git a/lib/Internal/Utils.hs b/lib/Internal/Utils.hs index 29f03fb..b0ade06 100644 --- a/lib/Internal/Utils.hs +++ b/lib/Internal/Utils.hs @@ -293,6 +293,7 @@ showError other = (: []) $ case other of (ConversionError x) -> T.append "Could not convert to rational number: " x -- TODO use the field indicator (LookupError _ f) -> T.append "Could not find field: " f + (AllocationError _) -> "Could not balance allocation" (BalanceError t cur rss) -> T.concat [ msg @@ -412,3 +413,11 @@ concatEithersL = first concat . concatEitherL leftToMaybe :: Either a b -> Maybe a leftToMaybe (Left a) = Just a leftToMaybe _ = Nothing + +unlessLeft :: (Monad m, MonadPlus n) => Either a b -> (b -> m ()) -> m (n a) +unlessLeft (Left es) _ = return (return es) +unlessLeft (Right rs) f = f rs >> return mzero + +unlessLefts :: (Monad m, MonadPlus n) => Either (n a) b -> (b -> m ()) -> m (n a) +unlessLefts (Left es) _ = return es +unlessLefts (Right rs) f = f rs >> return mzero