ENH show errors in parallel

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

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
+    whenHash CTIncome i [] $ \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
+      case (balanceIncome i, expandDatePat bounds dp) of
-            Left e -> return $ Just e
+        (Right balanced, Right days) -> do
-            Right days -> do
           forM_ days $ \day -> do
-                alloTx <- concat <$> mapM (allocationToTx from day) as
+            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 Nothing
+          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 $ AllocationError MissingBlank
-      _ -> Left "multiple blank amounts present"
+      _ -> 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
+        unlessLeft res $
-          Left err -> return $ Just err
+          lift . mapM_ (insertTxBucket (Just buc) key)
-          Right txs -> do
-            lift $ mapM_ (insertTxBucket (Just buc) key) txs
-            return Nothing
 
 timeAmountToTx
   :: MonadUnliftIO m
@@ -275,9 +272,7 @@ timeAmountToTx
         }
     } = do
     bounds <- (liftIO . resolveBounds) =<< asks kmBudgetInterval
-    case expandDatePat bounds dp of
+    bimapM return (mapM tx) $ expandDatePat bounds dp
-      Left e -> return $ Left e
-      Right days -> Right <$> mapM tx days
     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
+      unlessLeft (expandDatePat bounds dp) $ \days -> do
-        Left err -> return $ Just err
-        Right days -> do
         ts <- mapM tx days
         lift $ mapM_ (insertTx c) ts
-          return Nothing
     where
       tx day = txPair day from to u (dec2Rat v) e
 
-insertImport :: MonadUnliftIO m => Import -> MappingT m (Maybe InsertError)
+insertImport :: MonadUnliftIO m => Import -> MappingT m [InsertError]
-insertImport i = whenHash CTImport i Nothing $ \c -> do
+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
+  unlessLefts res $ \bs -> do
-    Right bs -> do
     rs <- mapM resolveTx $ filter (inMaybeBounds bounds . txDate) bs
     lift $ mapM_ (insertTx c) rs
-      return Nothing
-    Left e -> return $ Just e
 
 --------------------------------------------------------------------------------
 -- low-level transaction stuff

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
+  case (matched, unmatched, notfound) of
+    (ms_, [], []) -> do
       -- TODO record number of times each match hits for debugging
-  matched_ <- mapM balanceTx matched
+      matched_ <- first (: []) $ mapM balanceTx ms_
-  case (matched_, unmatched, notfound) of
+      Right matched_
-    (xs, [], []) -> Right xs
+    (_, us, ns) -> Left [StatementError us ns]
-    (_, 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) [] =

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)
 

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