lib/Internal/Insert.hs

@@ -1,7 +1,6 @@
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TupleSections #-}
-{-# LANGUAGE NoImplicitPrelude #-}
 
 module Internal.Insert
   ( insertStatements
@@ -17,9 +16,35 @@ 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
 
@@ -93,9 +118,8 @@ mdyPatternMatches check x p = case p of
 
 insertBudget :: MonadUnliftIO m => Budget -> MappingT m [InsertError]
 insertBudget Budget {income = is, expenses = es} = do
-  es1 <- mapM insertIncome is
-  es2 <- mapM insertExpense es
-  return $ concat $ es1 ++ es2
+  mapM_ insertExpense es
+  concat <$> mapM insertIncome is
 
 -- TODO this hashes twice (not that it really matters)
 whenHash
@@ -116,19 +140,15 @@ insertIncome
     { incCurrency = cur
     , incWhen = dp
     , incAccount = from
-    , incTaxes = taxes
+    , incTaxes = ts
     } =
-    whenHash CTIncome i [] $ \c ->
-      unlessLeft (balanceIncome i) $ \balanced -> do
+    whenHash CTIncome i [] $ \c -> do
       bounds <- (liftIO . resolveBounds) =<< asks kmBudgetInterval
-        fmap concat $ forM (expandDatePat bounds dp) $ \day -> do
-          -- TODO why are these separate?
-          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
+      unlessLeft (balanceIncome i) $ \balanced -> do
+        forM_ (expandDatePat bounds dp) $ \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
 
 balanceIncome :: Income -> EitherErr [BalAllocation]
 balanceIncome
@@ -182,7 +202,7 @@ allocationToTx
   => AcntID
   -> Day
   -> BalAllocation
-  -> MappingT m (EitherErrs [(KeyTx, Bucket)])
+  -> MappingT m [(KeyTx, Bucket)]
 allocationToTx
   from
   day
@@ -192,15 +212,9 @@ allocationToTx
     , alloCurrency = cur
     , alloAmts = as
     } =
-    second (fmap (,b)) . concatEithersL <$> mapM (transferToTx day from to cur) as
+    fmap (,b) <$> mapM (transferToTx day from to cur) as
 
-taxToTx
-  :: MonadUnliftIO m
-  => AcntID
-  -> Day
-  -> T.Text
-  -> Tax
-  -> MappingT m (EitherErrs KeyTx)
+taxToTx :: MonadUnliftIO m => AcntID -> Day -> T.Text -> Tax -> MappingT m KeyTx
 taxToTx from day cur Tax {taxAcnt = to, taxValue = v} =
   txPair day from to cur (dec2Rat v) ""
 
@@ -211,11 +225,11 @@ transferToTx
   -> AcntID
   -> T.Text
   -> BalAmount
-  -> MappingT m (EitherErrs KeyTx)
+  -> MappingT m KeyTx
 transferToTx day from to cur Amount {amtValue = v, amtDesc = d} =
   txPair day from to cur v d
 
-insertExpense :: MonadUnliftIO m => Expense -> MappingT m [InsertError]
+insertExpense :: MonadUnliftIO m => Expense -> MappingT m ()
 insertExpense
   e@Expense
     { expFrom = from
@@ -224,12 +238,11 @@ insertExpense
     , expBucket = buc
     , expAmounts = as
     } = do
-    whenHash CTExpense e [] $ \key -> concat <$> mapM (go key) as
+    whenHash CTExpense e () $ \key -> mapM_ (go key) as
     where
       go key amt = do
-        res <- timeAmountToTx from to cur amt
-        unlessLefts_ res $
-          lift . mapM_ (insertTxBucket (Just buc) key)
+        keys <- timeAmountToTx from to cur amt
+        lift $ mapM_ (insertTxBucket (Just buc) key) keys
 
 timeAmountToTx
   :: MonadUnliftIO m
@@ -237,7 +250,7 @@ timeAmountToTx
   -> AcntID
   -> CurID
   -> TimeAmount
-  -> MappingT m (EitherErrs [KeyTx])
+  -> MappingT m [KeyTx]
 timeAmountToTx
   from
   to
@@ -251,7 +264,7 @@ timeAmountToTx
         }
     } = do
     bounds <- (liftIO . resolveBounds) =<< asks kmBudgetInterval
-    concatEithersL <$> mapM tx (expandDatePat bounds dp)
+    mapM tx $ expandDatePat bounds dp
     where
       tx day = txPair day from to cur (dec2Rat v) d
 
@@ -264,10 +277,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
+insertStatement (StmtManual m) = insertManual m >> return []
 insertStatement (StmtImport i) = insertImport i
 
-insertManual :: MonadUnliftIO m => Manual -> MappingT m [InsertError]
+insertManual :: MonadUnliftIO m => Manual -> MappingT m ()
 insertManual
   m@Manual
     { manualDate = dp
@@ -277,10 +290,10 @@ insertManual
     , manualCurrency = u
     , manualDesc = e
     } = do
-    whenHash CTManual m [] $ \c -> do
+    whenHash CTManual m () $ \c -> do
       bounds <- (liftIO . resolveBounds) =<< asks kmStatementInterval
-      res <- mapM tx $ expandDatePat bounds dp
-      unlessLefts_ (concatEithersL res) $ lift . mapM_ (insertTx c)
+      ts <- mapM tx $ expandDatePat bounds dp
+      lift $ mapM_ (insertTx c) ts
     where
       tx day = txPair day from to u (dec2Rat v) e
 
@@ -288,15 +301,12 @@ 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
-  recoverIO (readImport i) $ \r -> unlessLefts r $ \bs -> do
-    bounds <- asks kmStatementInterval
-    res <- mapM resolveTx $ filter (inMaybeBounds bounds . txDate) bs
-    unlessLefts_ (concatEithersL res) $ lift . mapM_ (insertTx c)
-  where
-    recoverIO x rest = do
-      res <- tryIO x
+  res <- tryIO $ readImport i
   case res of
-        Right r -> rest r
+    Right r -> unlessLefts r $ \bs -> do
+      bounds <- asks kmStatementInterval
+      rs <- mapM resolveTx $ filter (inMaybeBounds bounds . txDate) bs
+      lift $ mapM_ (insertTx c) rs
     -- If file is not found (or something else happens) then collect the
     -- error try the remaining imports
     Left e -> return [InsertIOError $ showT e]
@@ -312,7 +322,7 @@ txPair
   -> T.Text
   -> Rational
   -> T.Text
-  -> MappingT m (EitherErrs KeyTx)
+  -> MappingT m KeyTx
 txPair day from to cur val desc = resolveTx tx
   where
     split a v = Split {sAcnt = a, sValue = v, sComment = "", sCurrency = cur}
@@ -324,27 +334,27 @@ txPair day from to cur val desc = resolveTx tx
         , txSplits = [split from (-val), split to val]
         }
 
-resolveTx :: MonadUnliftIO m => BalTx -> MappingT m (EitherErrs KeyTx)
+resolveTx :: MonadUnliftIO m => BalTx -> MappingT m KeyTx
 resolveTx t@Tx {txSplits = ss} = do
-  res <- concatEithersL <$> mapM resolveSplit ss
-  return $ fmap (\kss -> t {txSplits = kss}) res
+  rs <- catMaybes <$> mapM resolveSplit ss
+  return $ t {txSplits = rs}
 
-resolveSplit :: MonadUnliftIO m => BalSplit -> MappingT m (EitherErrs KeySplit)
+resolveSplit :: MonadUnliftIO m => BalSplit -> MappingT m (Maybe 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 $ concatEither3 aid cid sign $ \aid_ cid_ sign_ ->
+  return $ case (aid, cid, sign) of
+    (Just aid', Just cid', Just sign') ->
+      Just $
         s
-      { sAcnt = aid_
-      , sCurrency = cid_
-      , sValue = v * fromIntegral (sign2Int sign_)
+          { sAcnt = aid'
+          , 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
@@ -357,15 +367,3 @@ 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/Statement.hs

@@ -2,7 +2,6 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE TupleSections #-}
-{-# LANGUAGE NoImplicitPrelude #-}
 
 module Internal.Statement
   ( readImport
@@ -25,9 +24,9 @@ import qualified RIO.Vector as V
 -- TODO this probably won't scale well (pipes?)
 
 readImport :: MonadUnliftIO m => Import -> MappingT m (EitherErrs [BalTx])
-readImport Import {..} = do
-  res <- mapM (readImport_ impSkipLines impDelim impTxOpts) impPaths
-  return $ (matchRecords impMatches . L.sort . concat) =<< concatEitherL res
+readImport Import {..} =
+  matchRecords impMatches . L.sort . concat
+    <$> mapM (readImport_ impSkipLines impDelim impTxOpts) impPaths
 
 readImport_
   :: MonadUnliftIO m
@@ -35,13 +34,13 @@ readImport_
   -> Word
   -> TxOpts
   -> FilePath
-  -> MappingT m (EitherErr [TxRecord])
+  -> MappingT m [TxRecord]
 readImport_ n delim tns p = do
   dir <- asks kmConfigDir
   bs <- liftIO $ BL.readFile $ dir </> p
   case decodeByNameWithP (parseTxRecord p tns) opts $ skip bs of
-    Left m -> return $ Left $ ParseError $ T.pack m
-    Right (_, v) -> return $ Right $ catMaybes $ V.toList v
+    Left m -> liftIO $ putStrLn m >> return []
+    Right (_, v) -> return $ catMaybes $ V.toList v
   where
     opts = defaultDecodeOptions {decDelimiter = fromIntegral delim}
     skip = BL.intercalate "\n" . L.drop (fromIntegral n) . BL.split 10
@@ -146,10 +145,10 @@ zipperMatch' z x = go z
     go z' = Right (z', MatchFail)
 
 matchDec :: Match -> Maybe Match
-matchDec m = case mTimes m of
-  Just 0 -> Nothing
-  Just n -> Just $ m {mTimes = Just $ n - 1}
-  Nothing -> Just m
+matchDec m@Match {mTimes = t} =
+  if t' == Just 0 then Nothing else Just $ m {mTimes = t'}
+  where
+    t' = fmap pred t
 
 matchAll :: [MatchGroup] -> [TxRecord] -> EitherErrs ([RawTx], [TxRecord], [Match])
 matchAll = go ([], [])

lib/Internal/Types.hs

@@ -11,7 +11,6 @@
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE NoImplicitPrelude #-}
 
 module Internal.Types where
 
@@ -530,7 +529,6 @@ data LookupSuberr
   = SplitIDField SplitIDType
   | SplitValField
   | MatchField MatchType
-  | DBKey SplitIDType
   deriving (Show)
 
 data AllocationSuberr
@@ -544,7 +542,6 @@ 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]
@@ -559,3 +556,10 @@ 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,7 +1,6 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE NoImplicitPrelude #-}
 
 module Internal.Utils
   ( compareDate
@@ -13,20 +12,14 @@ module Internal.Utils
   , leftToMaybe
   , dec2Rat
   , concatEithers2
-  , concatEither3
   , concatEither2
-  , concatEitherL
-  , concatEithersL
   , parseRational
   , showError
-  , unlessLeft_
-  , unlessLefts_
   , unlessLeft
   , unlessLefts
   , inMaybeBounds
   , acntPath2Text
   , showT
-  , lookupErr
   )
 where
 
@@ -289,21 +282,29 @@ 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 ["Could not find field", singleQuote f, "when resolving", what]
+    T.unwords
+      [ "Could not find field"
+      , singleQuote f
+      , "when resolving"
+      , what
+      ]
     where
       what = case t of
-        SplitIDField st -> T.unwords ["split", idName st, "ID"]
+        SplitIDField st ->
+          T.unwords
+            [ "split"
+            , case st of AcntField -> "account"; CurField -> "currency"
+            , "ID"
+            ]
         SplitValField -> "split value"
-        MatchField mt -> T.unwords [matchName mt, "match"]
-        DBKey st -> T.unwords ["database", idName st, "ID key"]
-      idName AcntField = "account"
-      idName CurField = "currency"
-      matchName MatchNumeric = "numeric"
-      matchName MatchText = "text"
+        MatchField mt ->
+          T.unwords
+            [ case mt of MatchNumeric -> "numeric"; MatchText -> "text"
+            , "match"
+            ]
   (AllocationError t dp) -> T.concat [msg, ": datepattern=", showT dp]
     where
       msg = case t of
@@ -466,19 +467,13 @@ leftToMaybe :: Either a b -> Maybe a
 leftToMaybe (Left a) = Just a
 leftToMaybe _ = Nothing
 
-unlessLeft :: (Monad m, MonadPlus n) => Either a b -> (b -> m (n a)) -> m (n a)
+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
+unlessLeft (Right rs) f = f rs >> return mzero
 
-unlessLefts :: (Monad m) => Either (n a) b -> (b -> m (n a)) -> m (n a)
+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
-
-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)
+unlessLefts (Right rs) f = f rs >> return mzero
 
 plural :: Either a b -> Either [a] b
 plural = first (: [])