WIP display errors in parallel

app/Main.hs

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

lib/Internal/Database/Ops.hs

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

lib/Internal/Types.hs

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

lib/Internal/Utils.hs

@@ -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,25 +150,25 @@ 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
-  let fromSplit =
-        Split
-          { sAcnt = a_
-          , sCurrency = c_
-          , sValue = Just trAmount
-          , sComment = ""
+toTx :: SplitCur -> SplitAcnt -> [ExpSplit] -> TxRecord -> EitherErrs RawTx
+toTx sc sa toSplits r@TxRecord {..} =
+  concatEithers2 acRes ssRes $ \(a_, c_) ss_ ->
+    let fromSplit =
+          Split
+            { sAcnt = a_
+            , sCurrency = c_
+            , sValue = Just trAmount
+            , sComment = ""
+            }
+     in Tx
+          { txTags = []
+          , txDate = trDate
+          , txDescr = trDesc
+          , txSplits = fromSplit : ss_
           }
-  return $
-    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