diff --git a/budget.cabal b/budget.cabal index 1ad76c4..a0d6323 100644 --- a/budget.cabal +++ b/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 diff --git a/lib/Internal/History.hs b/lib/Internal/History.hs index b4d58c2..09fd3f3 100644 --- a/lib/Internal/History.hs +++ b/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 (: [])) diff --git a/lib/Internal/Statement.hs b/lib/Internal/Statement.hs deleted file mode 100644 index 386d96c..0000000 --- a/lib/Internal/Statement.hs +++ /dev/null @@ -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 (: []))