REF combine statement with history

budget.cabal

@@ -28,7 +28,6 @@ library
       Internal.Budget
       Internal.Database.Ops
       Internal.History
-      Internal.Statement
       Internal.Types.Database
       Internal.Types.Dhall
       Internal.Types.Main

lib/Internal/History.hs

@@ -7,14 +7,19 @@ module Internal.History
 where
 
 import Control.Monad.Except
+import Data.Csv
 import Database.Persist.Monad
 import Internal.Database.Ops
-import Internal.Statement
 import Internal.Types.Main
 import Internal.Utils
 import RIO hiding (to)
+import qualified RIO.ByteString.Lazy as BL
+import RIO.FilePath
+import qualified RIO.List as L
+import qualified RIO.Map as M
 import qualified RIO.Text as T
 import RIO.Time
+import qualified RIO.Vector as V
 
 splitHistory :: [History] -> ([HistTransfer], [Statement])
 splitHistory = partitionEithers . fmap go
@@ -95,3 +100,227 @@ insertTx :: MonadSqlQuery m => CommitRId -> KeyTx -> m ()
 insertTx c Tx {txDate = d, txDescr = e, txEntries = ss} = do
   k <- insert $ TransactionR c d e
   mapM_ (insertEntry k) ss
+
+--------------------------------------------------------------------------------
+-- Statements
+
+-- TODO this probably won't scale well (pipes?)
+readImport :: (MonadUnliftIO m, MonadFinance m) => Statement -> m [BalTx]
+readImport Statement {stmtTxOpts, stmtParsers, stmtSkipLines, stmtDelim, stmtPaths} = do
+  let ores = compileOptions stmtTxOpts
+  let cres = combineErrors $ compileMatch <$> stmtParsers
+  (compiledOptions, compiledMatches) <- liftIOExcept $ combineError ores cres (,)
+  let readStmt = readImport_ stmtSkipLines stmtDelim compiledOptions
+  records <- L.sort . concat <$> mapErrorsIO readStmt stmtPaths
+  m <- askDBState kmCurrency
+  fromEither $
+    flip runReader m $
+      runExceptT $
+        matchRecords compiledMatches records
+
+readImport_
+  :: (MonadUnliftIO m, MonadFinance m)
+  => Natural
+  -> Word
+  -> TxOptsRe
+  -> FilePath
+  -> m [TxRecord]
+readImport_ n delim tns p = do
+  dir <- askDBState kmConfigDir
+  res <- tryIO $ BL.readFile $ dir </> p
+  bs <- fromEither $ first (InsertException . (: []) . InsertIOError . showT) res
+  case decodeByNameWithP (parseTxRecord p tns) opts $ skip bs of
+    Left m -> throwIO $ InsertException [ParseError $ T.pack m]
+    Right (_, v) -> return $ catMaybes $ V.toList v
+  where
+    opts = defaultDecodeOptions {decDelimiter = fromIntegral delim}
+    skip = BL.intercalate "\n" . L.drop (fromIntegral n) . BL.split 10
+
+-- TODO handle this better, this maybe thing is a hack to skip lines with
+-- blank dates but will likely want to make this more flexible
+parseTxRecord :: FilePath -> TxOptsRe -> NamedRecord -> Parser (Maybe TxRecord)
+parseTxRecord p TxOpts {toDate, toAmountFmt, toDesc, toAmount, toOther, toDateFmt} r = do
+  d <- r .: T.encodeUtf8 toDate
+  if d == ""
+    then return Nothing
+    else do
+      a <- parseRational toAmountFmt =<< r .: T.encodeUtf8 toAmount
+      e <- r .: T.encodeUtf8 toDesc
+      os <- M.fromList <$> mapM (\n -> (n,) <$> r .: T.encodeUtf8 n) toOther
+      d' <- parseTimeM True defaultTimeLocale (T.unpack toDateFmt) d
+      return $ Just $ TxRecord d' a e os p
+
+matchRecords :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM [BalTx]
+matchRecords ms rs = do
+  (matched, unmatched, notfound) <- matchAll (matchPriorities ms) rs
+  case (matched, unmatched, notfound) of
+    -- TODO record number of times each match hits for debugging
+    (ms_, [], []) -> liftInner $ combineErrors $ fmap balanceTx ms_
+    (_, us, ns) -> throwError $ InsertException [StatementError us ns]
+
+matchPriorities :: [MatchRe] -> [MatchGroup]
+matchPriorities =
+  fmap matchToGroup
+    . L.groupBy (\a b -> spPriority a == spPriority b)
+    . L.sortOn (Down . spPriority)
+
+matchToGroup :: [MatchRe] -> MatchGroup
+matchToGroup ms =
+  uncurry MatchGroup $
+    first (L.sortOn spDate) $
+      L.partition (isJust . spDate) ms
+
+-- TDOO could use a better struct to flatten the maybe date subtype
+data MatchGroup = MatchGroup
+  { mgDate :: ![MatchRe]
+  , mgNoDate :: ![MatchRe]
+  }
+  deriving (Show)
+
+data Zipped a = Zipped ![a] ![a]
+
+data Unzipped a = Unzipped ![a] ![a] ![a]
+
+initZipper :: [a] -> Zipped a
+initZipper = Zipped []
+
+resetZipper :: Zipped a -> Zipped a
+resetZipper = initZipper . recoverZipper
+
+recoverZipper :: Zipped a -> [a]
+recoverZipper (Zipped as bs) = reverse as ++ bs
+
+zipperSlice
+  :: (a -> b -> Ordering)
+  -> b
+  -> Zipped a
+  -> Either (Zipped a) (Unzipped a)
+zipperSlice f x = go
+  where
+    go z@(Zipped _ []) = Left z
+    go z@(Zipped bs (a : as)) =
+      case f a x of
+        GT -> go $ Zipped (a : bs) as
+        EQ -> Right $ goEq (Unzipped bs [a] as)
+        LT -> Left z
+    goEq z@(Unzipped _ _ []) = z
+    goEq z@(Unzipped bs cs (a : as)) =
+      case f a x of
+        GT -> goEq $ Unzipped (a : bs) cs as
+        EQ -> goEq $ Unzipped bs (a : cs) as
+        LT -> z
+
+zipperMatch
+  :: Unzipped MatchRe
+  -> TxRecord
+  -> InsertExceptT CurrencyM (Zipped MatchRe, MatchRes RawTx)
+zipperMatch (Unzipped bs cs as) x = go [] cs
+  where
+    go _ [] = return (Zipped bs $ cs ++ as, MatchFail)
+    go prev (m : ms) = do
+      res <- matches m x
+      case res of
+        MatchFail -> go (m : prev) ms
+        skipOrPass ->
+          let ps = reverse prev
+              ms' = maybe ms (: ms) (matchDec m)
+           in return (Zipped bs $ ps ++ ms' ++ as, skipOrPass)
+
+-- TODO all this unpacking left/error crap is annoying
+zipperMatch'
+  :: Zipped MatchRe
+  -> TxRecord
+  -> InsertExceptT CurrencyM (Zipped MatchRe, MatchRes RawTx)
+zipperMatch' z x = go z
+  where
+    go (Zipped bs (a : as)) = do
+      res <- matches a x
+      case res of
+        MatchFail -> go (Zipped (a : bs) as)
+        skipOrPass ->
+          return (Zipped (maybe bs (: bs) $ matchDec a) as, skipOrPass)
+    go z' = return (z', MatchFail)
+
+matchDec :: MatchRe -> Maybe MatchRe
+matchDec m = case spTimes m of
+  Just 1 -> Nothing
+  Just n -> Just $ m {spTimes = Just $ n - 1}
+  Nothing -> Just m
+
+matchAll :: [MatchGroup] -> [TxRecord] -> InsertExceptT CurrencyM ([RawTx], [TxRecord], [MatchRe])
+matchAll = go ([], [])
+  where
+    go (matched, unused) gs rs = case (gs, rs) of
+      (_, []) -> return (matched, [], unused)
+      ([], _) -> return (matched, rs, unused)
+      (g : gs', _) -> do
+        (ts, unmatched, us) <- matchGroup g rs
+        go (ts ++ matched, us ++ unused) gs' unmatched
+
+matchGroup :: MatchGroup -> [TxRecord] -> InsertExceptT CurrencyM ([RawTx], [TxRecord], [MatchRe])
+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) . spTimes) $ ud ++ un)
+
+matchDates :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM ([RawTx], [TxRecord], [MatchRe])
+matchDates ms = go ([], [], initZipper ms)
+  where
+    go (matched, unmatched, z) [] =
+      return
+        ( catMaybes matched
+        , reverse unmatched
+        , recoverZipper z
+        )
+    go (matched, unmatched, z) (r : rs) =
+      case zipperSlice findDate r z of
+        Left zipped -> go (matched, r : unmatched, zipped) rs
+        Right unzipped -> do
+          (z', res) <- zipperMatch unzipped r
+          let (m, u) = case res of
+                (MatchPass p) -> (Just p : matched, unmatched)
+                MatchSkip -> (Nothing : matched, unmatched)
+                MatchFail -> (matched, r : unmatched)
+          go (m, u, z') rs
+    findDate m r = maybe EQ (`compareDate` trDate r) $ spDate m
+
+matchNonDates :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM ([RawTx], [TxRecord], [MatchRe])
+matchNonDates ms = go ([], [], initZipper ms)
+  where
+    go (matched, unmatched, z) [] =
+      return
+        ( catMaybes matched
+        , reverse unmatched
+        , recoverZipper z
+        )
+    go (matched, unmatched, z) (r : rs) = do
+      (z', res) <- zipperMatch' z r
+      let (m, u) = case res of
+            MatchPass p -> (Just p : matched, unmatched)
+            MatchSkip -> (Nothing : matched, unmatched)
+            MatchFail -> (matched, r : unmatched)
+       in go (m, u, resetZipper z') rs
+
+balanceTx :: RawTx -> InsertExcept BalTx
+balanceTx t@Tx {txEntries = ss} = do
+  bs <- balanceEntries ss
+  return $ t {txEntries = bs}
+
+balanceEntries :: [RawEntry] -> InsertExcept [BalEntry]
+balanceEntries ss =
+  fmap concat
+    <$> mapM (uncurry bal)
+    $ groupByKey
+    $ fmap (\s -> (eCurrency s, s)) ss
+  where
+    haeValue s@Entry {eValue = Just v} = Right s {eValue = v}
+    haeValue s = Left s
+    bal cur rss
+      | length rss < 2 = throwError $ InsertException [BalanceError TooFewEntries cur rss]
+      | otherwise = case partitionEithers $ fmap haeValue rss of
+          ([noVal], val) -> return $ noVal {eValue = foldr (\s x -> x - eValue s) 0 val} : val
+          ([], val) -> return val
+          _ -> throwError $ InsertException [BalanceError NotOneBlank cur rss]
+
+groupByKey :: Ord k => [(k, v)] -> [(k, [v])]
+groupByKey = M.toList . M.fromListWith (++) . fmap (second (: []))

lib/Internal/Statement.hs

@@ -1,241 +0,0 @@
-{-# LANGUAGE RecordWildCards #-}
-
-module Internal.Statement
-  ( readImport
-  )
-where
-
-import Control.Monad.Error.Class
-import Control.Monad.Except
-import Data.Csv
-import Internal.Types.Main
-import Internal.Utils
-import RIO
-import qualified RIO.ByteString.Lazy as BL
-import RIO.FilePath
-import qualified RIO.List as L
-import qualified RIO.Map as M
-import qualified RIO.Text as T
-import RIO.Time
-import qualified RIO.Vector as V
-
--- TODO this probably won't scale well (pipes?)
-readImport :: (MonadUnliftIO m, MonadFinance m) => Statement -> m [BalTx]
-readImport Statement {..} = do
-  let ores = compileOptions stmtTxOpts
-  let cres = combineErrors $ compileMatch <$> stmtParsers
-  (compiledOptions, compiledMatches) <- liftIOExcept $ combineError ores cres (,)
-  let readStmt = readImport_ stmtSkipLines stmtDelim compiledOptions
-  records <- L.sort . concat <$> mapErrorsIO readStmt stmtPaths
-  m <- askDBState kmCurrency
-  fromEither $
-    flip runReader m $
-      runExceptT $
-        matchRecords compiledMatches records
-
-readImport_
-  :: (MonadUnliftIO m, MonadFinance m)
-  => Natural
-  -> Word
-  -> TxOptsRe
-  -> FilePath
-  -> m [TxRecord]
-readImport_ n delim tns p = do
-  dir <- askDBState kmConfigDir
-  res <- tryIO $ BL.readFile $ dir </> p
-  bs <- fromEither $ first (InsertException . (: []) . InsertIOError . showT) res
-  case decodeByNameWithP (parseTxRecord p tns) opts $ skip bs of
-    Left m -> throwIO $ InsertException [ParseError $ T.pack m]
-    Right (_, v) -> return $ catMaybes $ V.toList v
-  where
-    opts = defaultDecodeOptions {decDelimiter = fromIntegral delim}
-    skip = BL.intercalate "\n" . L.drop (fromIntegral n) . BL.split 10
-
--- TODO handle this better, this maybe thing is a hack to skip lines with
--- blank dates but will likely want to make this more flexible
-parseTxRecord :: FilePath -> TxOptsRe -> NamedRecord -> Parser (Maybe TxRecord)
-parseTxRecord p TxOpts {..} r = do
-  d <- r .: T.encodeUtf8 toDate
-  if d == ""
-    then return Nothing
-    else do
-      a <- parseRational toAmountFmt =<< r .: T.encodeUtf8 toAmount
-      e <- r .: T.encodeUtf8 toDesc
-      os <- M.fromList <$> mapM (\n -> (n,) <$> r .: T.encodeUtf8 n) toOther
-      d' <- parseTimeM True defaultTimeLocale (T.unpack toDateFmt) d
-      return $ Just $ TxRecord d' a e os p
-
-matchRecords :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM [BalTx]
-matchRecords ms rs = do
-  (matched, unmatched, notfound) <- matchAll (matchPriorities ms) rs
-  case (matched, unmatched, notfound) of
-    -- TODO record number of times each match hits for debugging
-    (ms_, [], []) -> liftInner $ combineErrors $ fmap balanceTx ms_
-    (_, us, ns) -> throwError $ InsertException [StatementError us ns]
-
-matchPriorities :: [MatchRe] -> [MatchGroup]
-matchPriorities =
-  fmap matchToGroup
-    . L.groupBy (\a b -> spPriority a == spPriority b)
-    . L.sortOn (Down . spPriority)
-
-matchToGroup :: [MatchRe] -> MatchGroup
-matchToGroup ms =
-  uncurry MatchGroup $
-    first (L.sortOn spDate) $
-      L.partition (isJust . spDate) ms
-
--- TDOO could use a better struct to flatten the maybe date subtype
-data MatchGroup = MatchGroup
-  { mgDate :: ![MatchRe]
-  , mgNoDate :: ![MatchRe]
-  }
-  deriving (Show)
-
-data Zipped a = Zipped ![a] ![a]
-
-data Unzipped a = Unzipped ![a] ![a] ![a]
-
-initZipper :: [a] -> Zipped a
-initZipper = Zipped []
-
-resetZipper :: Zipped a -> Zipped a
-resetZipper = initZipper . recoverZipper
-
-recoverZipper :: Zipped a -> [a]
-recoverZipper (Zipped as bs) = reverse as ++ bs
-
-zipperSlice
-  :: (a -> b -> Ordering)
-  -> b
-  -> Zipped a
-  -> Either (Zipped a) (Unzipped a)
-zipperSlice f x = go
-  where
-    go z@(Zipped _ []) = Left z
-    go z@(Zipped bs (a : as)) =
-      case f a x of
-        GT -> go $ Zipped (a : bs) as
-        EQ -> Right $ goEq (Unzipped bs [a] as)
-        LT -> Left z
-    goEq z@(Unzipped _ _ []) = z
-    goEq z@(Unzipped bs cs (a : as)) =
-      case f a x of
-        GT -> goEq $ Unzipped (a : bs) cs as
-        EQ -> goEq $ Unzipped bs (a : cs) as
-        LT -> z
-
-zipperMatch
-  :: Unzipped MatchRe
-  -> TxRecord
-  -> InsertExceptT CurrencyM (Zipped MatchRe, MatchRes RawTx)
-zipperMatch (Unzipped bs cs as) x = go [] cs
-  where
-    go _ [] = return (Zipped bs $ cs ++ as, MatchFail)
-    go prev (m : ms) = do
-      res <- matches m x
-      case res of
-        MatchFail -> go (m : prev) ms
-        skipOrPass ->
-          let ps = reverse prev
-              ms' = maybe ms (: ms) (matchDec m)
-           in return (Zipped bs $ ps ++ ms' ++ as, skipOrPass)
-
--- TODO all this unpacking left/error crap is annoying
-zipperMatch'
-  :: Zipped MatchRe
-  -> TxRecord
-  -> InsertExceptT CurrencyM (Zipped MatchRe, MatchRes RawTx)
-zipperMatch' z x = go z
-  where
-    go (Zipped bs (a : as)) = do
-      res <- matches a x
-      case res of
-        MatchFail -> go (Zipped (a : bs) as)
-        skipOrPass ->
-          return (Zipped (maybe bs (: bs) $ matchDec a) as, skipOrPass)
-    go z' = return (z', MatchFail)
-
-matchDec :: MatchRe -> Maybe MatchRe
-matchDec m = case spTimes m of
-  Just 1 -> Nothing
-  Just n -> Just $ m {spTimes = Just $ n - 1}
-  Nothing -> Just m
-
-matchAll :: [MatchGroup] -> [TxRecord] -> InsertExceptT CurrencyM ([RawTx], [TxRecord], [MatchRe])
-matchAll = go ([], [])
-  where
-    go (matched, unused) gs rs = case (gs, rs) of
-      (_, []) -> return (matched, [], unused)
-      ([], _) -> return (matched, rs, unused)
-      (g : gs', _) -> do
-        (ts, unmatched, us) <- matchGroup g rs
-        go (ts ++ matched, us ++ unused) gs' unmatched
-
-matchGroup :: MatchGroup -> [TxRecord] -> InsertExceptT CurrencyM ([RawTx], [TxRecord], [MatchRe])
-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) . spTimes) $ ud ++ un)
-
-matchDates :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM ([RawTx], [TxRecord], [MatchRe])
-matchDates ms = go ([], [], initZipper ms)
-  where
-    go (matched, unmatched, z) [] =
-      return
-        ( catMaybes matched
-        , reverse unmatched
-        , recoverZipper z
-        )
-    go (matched, unmatched, z) (r : rs) =
-      case zipperSlice findDate r z of
-        Left zipped -> go (matched, r : unmatched, zipped) rs
-        Right unzipped -> do
-          (z', res) <- zipperMatch unzipped r
-          let (m, u) = case res of
-                (MatchPass p) -> (Just p : matched, unmatched)
-                MatchSkip -> (Nothing : matched, unmatched)
-                MatchFail -> (matched, r : unmatched)
-          go (m, u, z') rs
-    findDate m r = maybe EQ (`compareDate` trDate r) $ spDate m
-
-matchNonDates :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM ([RawTx], [TxRecord], [MatchRe])
-matchNonDates ms = go ([], [], initZipper ms)
-  where
-    go (matched, unmatched, z) [] =
-      return
-        ( catMaybes matched
-        , reverse unmatched
-        , recoverZipper z
-        )
-    go (matched, unmatched, z) (r : rs) = do
-      (z', res) <- zipperMatch' z r
-      let (m, u) = case res of
-            MatchPass p -> (Just p : matched, unmatched)
-            MatchSkip -> (Nothing : matched, unmatched)
-            MatchFail -> (matched, r : unmatched)
-       in go (m, u, resetZipper z') rs
-
-balanceTx :: RawTx -> InsertExcept BalTx
-balanceTx t@Tx {txEntries = ss} = do
-  bs <- balanceEntries ss
-  return $ t {txEntries = bs}
-
-balanceEntries :: [RawEntry] -> InsertExcept [BalEntry]
-balanceEntries ss =
-  fmap concat
-    <$> mapM (uncurry bal)
-    $ groupByKey
-    $ fmap (\s -> (eCurrency s, s)) ss
-  where
-    haeValue s@Entry {eValue = Just v} = Right s {eValue = v}
-    haeValue s = Left s
-    bal cur rss
-      | length rss < 2 = throwError $ InsertException [BalanceError TooFewEntries cur rss]
-      | otherwise = case partitionEithers $ fmap haeValue rss of
-          ([noVal], val) -> return $ noVal {eValue = foldr (\s x -> x - eValue s) 0 val} : val
-          ([], val) -> return val
-          _ -> throwError $ InsertException [BalanceError NotOneBlank cur rss]
-
-groupByKey :: Ord k => [(k, v)] -> [(k, [v])]
-groupByKey = M.toList . M.fromListWith (++) . fmap (second (: []))