ENH don't print db lookup errors

lib/Internal/Insert.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TupleSections #-}
+{-# LANGUAGE NoImplicitPrelude #-}
 
 module Internal.Insert
   ( insertStatements
@@ -16,35 +17,9 @@ import Internal.Statement
 import Internal.Types hiding (sign)
 import Internal.Utils
 import RIO hiding (to)
-import qualified RIO.Map as M
 import qualified RIO.Text as T
 import RIO.Time
 
-lookupKey :: (Ord k, Show k, MonadUnliftIO m) => M.Map k v -> k -> m (Maybe v)
-lookupKey m k = do
-  let v = M.lookup k m
-  when (isNothing v) $
-    liftIO $
-      putStrLn $
-        "key does not exist: " ++ show k
-  return v
-
-lookupAccount :: MonadUnliftIO m => AcntID -> MappingT m (Maybe (Key AccountR, AcntSign))
-lookupAccount p = do
-  m <- asks kmAccount
-  lookupKey m p
-
-lookupAccountKey :: MonadUnliftIO m => AcntID -> MappingT m (Maybe (Key AccountR))
-lookupAccountKey = fmap (fmap fst) . lookupAccount
-
-lookupAccountSign :: MonadUnliftIO m => AcntID -> MappingT m (Maybe AcntSign)
-lookupAccountSign = fmap (fmap snd) . lookupAccount
-
-lookupCurrency :: MonadUnliftIO m => T.Text -> MappingT m (Maybe (Key CurrencyR))
-lookupCurrency c = do
-  m <- asks kmCurrency
-  lookupKey m c
-
 --------------------------------------------------------------------------------
 -- intervals
 
@@ -118,8 +93,9 @@ mdyPatternMatches check x p = case p of
 
 insertBudget :: MonadUnliftIO m => Budget -> MappingT m [InsertError]
 insertBudget Budget {income = is, expenses = es} = do
-  mapM_ insertExpense es
+  es1 <- mapM insertIncome is
-  concat <$> mapM insertIncome is
+  es2 <- mapM insertExpense es
+  return $ concat $ es1 ++ es2
 
 -- TODO this hashes twice (not that it really matters)
 whenHash
@@ -140,15 +116,19 @@ insertIncome
     { incCurrency = cur
     , incWhen = dp
     , incAccount = from
-    , incTaxes = ts
+    , incTaxes = taxes
     } =
-    whenHash CTIncome i [] $ \c -> do
+    whenHash CTIncome i [] $ \c ->
-      bounds <- (liftIO . resolveBounds) =<< asks kmBudgetInterval
       unlessLeft (balanceIncome i) $ \balanced -> do
-        forM_ (expandDatePat bounds dp) $ \day -> do
+        bounds <- (liftIO . resolveBounds) =<< asks kmBudgetInterval
-          alloTx <- concat <$> mapM (allocationToTx from day) balanced
+        fmap concat $ forM (expandDatePat bounds dp) $ \day -> do
-          taxTx <- fmap (,Fixed) <$> mapM (taxToTx from day cur) ts
+          -- TODO why are these separate?
-          lift $ mapM_ (\(t, b) -> insertTxBucket (Just b) c t) $ alloTx ++ taxTx
+          nontaxRes <- alloTxs concat (allocationToTx from day) balanced
+          taxRes <- alloTxs (fmap (,Fixed)) (taxToTx from day cur) taxes
+          unlessLefts_ (concatEithers2 nontaxRes taxRes (++)) $ \txs ->
+            lift $ mapM_ (\(t, b) -> insertTxBucket (Just b) c t) txs
+    where
+      alloTxs squish toTx = fmap (fmap squish . concatEithersL) . mapM toTx
 
 balanceIncome :: Income -> EitherErr [BalAllocation]
 balanceIncome
@@ -202,7 +182,7 @@ allocationToTx
   => AcntID
   -> Day
   -> BalAllocation
-  -> MappingT m [(KeyTx, Bucket)]
+  -> MappingT m (EitherErrs [(KeyTx, Bucket)])
 allocationToTx
   from
   day
@@ -212,9 +192,15 @@ allocationToTx
     , alloCurrency = cur
     , alloAmts = as
     } =
-    fmap (,b) <$> mapM (transferToTx day from to cur) as
+    second (fmap (,b)) . concatEithersL <$> mapM (transferToTx day from to cur) as
 
-taxToTx :: MonadUnliftIO m => AcntID -> Day -> T.Text -> Tax -> MappingT m KeyTx
+taxToTx
+  :: MonadUnliftIO m
+  => AcntID
+  -> Day
+  -> T.Text
+  -> Tax
+  -> MappingT m (EitherErrs KeyTx)
 taxToTx from day cur Tax {taxAcnt = to, taxValue = v} =
   txPair day from to cur (dec2Rat v) ""
 
@@ -225,11 +211,11 @@ transferToTx
   -> AcntID
   -> T.Text
   -> BalAmount
-  -> MappingT m KeyTx
+  -> MappingT m (EitherErrs KeyTx)
 transferToTx day from to cur Amount {amtValue = v, amtDesc = d} =
   txPair day from to cur v d
 
-insertExpense :: MonadUnliftIO m => Expense -> MappingT m ()
+insertExpense :: MonadUnliftIO m => Expense -> MappingT m [InsertError]
 insertExpense
   e@Expense
     { expFrom = from
@@ -238,11 +224,12 @@ insertExpense
     , expBucket = buc
     , expAmounts = as
     } = do
-    whenHash CTExpense e () $ \key -> mapM_ (go key) as
+    whenHash CTExpense e [] $ \key -> concat <$> mapM (go key) as
     where
       go key amt = do
-        keys <- timeAmountToTx from to cur amt
+        res <- timeAmountToTx from to cur amt
-        lift $ mapM_ (insertTxBucket (Just buc) key) keys
+        unlessLefts_ res $
+          lift . mapM_ (insertTxBucket (Just buc) key)
 
 timeAmountToTx
   :: MonadUnliftIO m
@@ -250,7 +237,7 @@ timeAmountToTx
   -> AcntID
   -> CurID
   -> TimeAmount
-  -> MappingT m [KeyTx]
+  -> MappingT m (EitherErrs [KeyTx])
 timeAmountToTx
   from
   to
@@ -264,7 +251,7 @@ timeAmountToTx
         }
     } = do
     bounds <- (liftIO . resolveBounds) =<< asks kmBudgetInterval
-    mapM tx $ expandDatePat bounds dp
+    concatEithersL <$> mapM tx (expandDatePat bounds dp)
     where
       tx day = txPair day from to cur (dec2Rat v) d
 
@@ -277,10 +264,10 @@ insertStatements conf = concat <$> mapM insertStatement (statements conf)
 -- unless (null es) $ throwIO $ InsertException es
 
 insertStatement :: MonadUnliftIO m => Statement -> MappingT m [InsertError]
-insertStatement (StmtManual m) = insertManual m >> return []
+insertStatement (StmtManual m) = insertManual m
 insertStatement (StmtImport i) = insertImport i
 
-insertManual :: MonadUnliftIO m => Manual -> MappingT m ()
+insertManual :: MonadUnliftIO m => Manual -> MappingT m [InsertError]
 insertManual
   m@Manual
     { manualDate = dp
@@ -290,10 +277,10 @@ insertManual
     , manualCurrency = u
     , manualDesc = e
     } = do
-    whenHash CTManual m () $ \c -> do
+    whenHash CTManual m [] $ \c -> do
       bounds <- (liftIO . resolveBounds) =<< asks kmStatementInterval
-      ts <- mapM tx $ expandDatePat bounds dp
+      res <- mapM tx $ expandDatePat bounds dp
-      lift $ mapM_ (insertTx c) ts
+      unlessLefts_ (concatEithersL res) $ lift . mapM_ (insertTx c)
     where
       tx day = txPair day from to u (dec2Rat v) e
 
@@ -301,15 +288,18 @@ insertImport :: MonadUnliftIO m => Import -> MappingT m [InsertError]
 insertImport i = whenHash CTImport i [] $ \c -> do
   -- TODO this isn't efficient, the whole file will be read and maybe no
   -- transactions will be desired
-  res <- tryIO $ readImport i
+  recoverIO (readImport i) $ \r -> unlessLefts r $ \bs -> do
-  case res of
+    bounds <- asks kmStatementInterval
-    Right r -> unlessLefts r $ \bs -> do
+    res <- mapM resolveTx $ filter (inMaybeBounds bounds . txDate) bs
-      bounds <- asks kmStatementInterval
+    unlessLefts_ (concatEithersL res) $ lift . mapM_ (insertTx c)
-      rs <- mapM resolveTx $ filter (inMaybeBounds bounds . txDate) bs
+  where
-      lift $ mapM_ (insertTx c) rs
+    recoverIO x rest = do
-    -- If file is not found (or something else happens) then collect the
+      res <- tryIO x
-    -- error try the remaining imports
+      case res of
-    Left e -> return [InsertIOError $ showT e]
+        Right r -> rest r
+        -- If file is not found (or something else happens) then collect the
+        -- error try the remaining imports
+        Left e -> return [InsertIOError $ showT e]
 
 --------------------------------------------------------------------------------
 -- low-level transaction stuff
@@ -322,7 +312,7 @@ txPair
   -> T.Text
   -> Rational
   -> T.Text
-  -> MappingT m KeyTx
+  -> MappingT m (EitherErrs KeyTx)
 txPair day from to cur val desc = resolveTx tx
   where
     split a v = Split {sAcnt = a, sValue = v, sComment = "", sCurrency = cur}
@@ -334,27 +324,27 @@ txPair day from to cur val desc = resolveTx tx
         , txSplits = [split from (-val), split to val]
         }
 
-resolveTx :: MonadUnliftIO m => BalTx -> MappingT m KeyTx
+resolveTx :: MonadUnliftIO m => BalTx -> MappingT m (EitherErrs KeyTx)
 resolveTx t@Tx {txSplits = ss} = do
-  rs <- catMaybes <$> mapM resolveSplit ss
+  res <- concatEithersL <$> mapM resolveSplit ss
-  return $ t {txSplits = rs}
+  return $ fmap (\kss -> t {txSplits = kss}) res
 
-resolveSplit :: MonadUnliftIO m => BalSplit -> MappingT m (Maybe KeySplit)
+resolveSplit :: MonadUnliftIO m => BalSplit -> MappingT m (EitherErrs KeySplit)
 resolveSplit s@Split {sAcnt = p, sCurrency = c, sValue = v} = do
   aid <- lookupAccountKey p
   cid <- lookupCurrency c
   sign <- lookupAccountSign p
   -- TODO correct sign here?
   -- TODO lenses would be nice here
-  return $ case (aid, cid, sign) of
+  return $ concatEither3 aid cid sign $ \aid_ cid_ sign_ ->
-    (Just aid', Just cid', Just sign') ->
+    s
-      Just $
+      { sAcnt = aid_
-        s
+      , sCurrency = cid_
-          { sAcnt = aid'
+      , sValue = v * fromIntegral (sign2Int sign_)
-          , sCurrency = cid'
+      }
-          , sValue = v * fromIntegral (sign2Int sign')
+
-          }
+-- return $ case (aid, cid, sign) of
-    _ -> Nothing
+--   _ -> Nothing
 
 insertTxBucket :: MonadUnliftIO m => Maybe Bucket -> Key CommitR -> KeyTx -> SqlPersistT m ()
 insertTxBucket b c Tx {txDate = d, txDescr = e, txSplits = ss} = do
@@ -367,3 +357,15 @@ insertTx = insertTxBucket Nothing
 insertSplit :: MonadUnliftIO m => Key TransactionR -> KeySplit -> SqlPersistT m ()
 insertSplit t Split {sAcnt = aid, sCurrency = cid, sValue = v, sComment = c} = do
   insert_ $ SplitR t cid aid c v
+
+lookupAccount :: MonadUnliftIO m => AcntID -> MappingT m (EitherErr (Key AccountR, AcntSign))
+lookupAccount p = lookupErr (DBKey AcntField) p <$> asks kmAccount
+
+lookupAccountKey :: MonadUnliftIO m => AcntID -> MappingT m (EitherErr (Key AccountR))
+lookupAccountKey = fmap (fmap fst) . lookupAccount
+
+lookupAccountSign :: MonadUnliftIO m => AcntID -> MappingT m (EitherErr AcntSign)
+lookupAccountSign = fmap (fmap snd) . lookupAccount
+
+lookupCurrency :: MonadUnliftIO m => T.Text -> MappingT m (EitherErr (Key CurrencyR))
+lookupCurrency c = lookupErr (DBKey CurField) c <$> asks kmCurrency

lib/Internal/Types.hs

@@ -11,6 +11,7 @@
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE NoImplicitPrelude #-}
 
 module Internal.Types where
 
@@ -529,6 +530,7 @@ data LookupSuberr
   = SplitIDField SplitIDType
   | SplitValField
   | MatchField MatchType
+  | DBKey SplitIDType
   deriving (Show)
 
 data AllocationSuberr
@@ -542,6 +544,7 @@ data InsertError
   = RegexError T.Text
   | MatchValPrecisionError Natural Natural
   | InsertIOError T.Text
+  | ParseError T.Text
   | ConversionError T.Text
   | LookupError LookupSuberr T.Text
   | BalanceError BalanceType CurID [RawSplit]
@@ -556,10 +559,3 @@ 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

@@ -1,6 +1,7 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE NoImplicitPrelude #-}
 
 module Internal.Utils
   ( compareDate
@@ -12,14 +13,20 @@ module Internal.Utils
   , leftToMaybe
   , dec2Rat
   , concatEithers2
+  , concatEither3
   , concatEither2
+  , concatEitherL
+  , concatEithersL
   , parseRational
   , showError
+  , unlessLeft_
+  , unlessLefts_
   , unlessLeft
   , unlessLefts
   , inMaybeBounds
   , acntPath2Text
   , showT
+  , lookupErr
   )
 where
 
@@ -282,29 +289,21 @@ showError other = (: []) $ case other of
   (RegexError re) -> T.append "could not make regex from pattern: " re
   (ConversionError x) -> T.append "Could not convert to rational number: " x
   (InsertIOError msg) -> T.append "IO Error: " msg
+  (ParseError msg) -> T.append "Parse Error: " msg
   (MatchValPrecisionError d p) ->
     T.unwords ["Match denominator", showT d, "must be less than", showT p]
   (LookupError t f) ->
-    T.unwords
+    T.unwords ["Could not find field", singleQuote f, "when resolving", what]
-      [ "Could not find field"
-      , singleQuote f
-      , "when resolving"
-      , what
-      ]
     where
       what = case t of
-        SplitIDField st ->
+        SplitIDField st -> T.unwords ["split", idName st, "ID"]
-          T.unwords
-            [ "split"
-            , case st of AcntField -> "account"; CurField -> "currency"
-            , "ID"
-            ]
         SplitValField -> "split value"
-        MatchField mt ->
+        MatchField mt -> T.unwords [matchName mt, "match"]
-          T.unwords
+        DBKey st -> T.unwords ["database", idName st, "ID key"]
-            [ case mt of MatchNumeric -> "numeric"; MatchText -> "text"
+      idName AcntField = "account"
-            , "match"
+      idName CurField = "currency"
-            ]
+      matchName MatchNumeric = "numeric"
+      matchName MatchText = "text"
   (AllocationError t dp) -> T.concat [msg, ": datepattern=", showT dp]
     where
       msg = case t of
@@ -467,13 +466,19 @@ 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 :: (Monad m, MonadPlus n) => Either a b -> (b -> m (n a)) -> m (n a)
 unlessLeft (Left es) _ = return (return es)
-unlessLeft (Right rs) f = f rs >> return mzero
+unlessLeft (Right rs) f = f rs
 
-unlessLefts :: (Monad m, MonadPlus n) => Either (n a) b -> (b -> m ()) -> m (n a)
+unlessLefts :: (Monad m) => Either (n a) b -> (b -> m (n a)) -> m (n a)
 unlessLefts (Left es) _ = return es
-unlessLefts (Right rs) f = f rs >> return mzero
+unlessLefts (Right rs) f = f rs
+
+unlessLeft_ :: (Monad m, MonadPlus n) => Either a b -> (b -> m ()) -> m (n a)
+unlessLeft_ e f = unlessLeft e (\x -> void (f x) >> return mzero)
+
+unlessLefts_ :: (Monad m, MonadPlus n) => Either (n a) b -> (b -> m ()) -> m (n a)
+unlessLefts_ e f = unlessLefts e (\x -> void (f x) >> return mzero)
 
 plural :: Either a b -> Either [a] b
 plural = first (: [])