From e6a39cb5ea4f45ec389010504d5caa0412ecc5d6 Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Sun, 12 Feb 2023 16:23:32 -0500 Subject: [PATCH] WIP track running balances in budget --- app/Main.hs | 13 +- budget.cabal | 76 +++++++++- dhall/Types.dhall | 5 +- lib/Internal/Config.hs | 2 - lib/Internal/Database/Model.hs | 47 ++++--- lib/Internal/Database/Ops.hs | 16 +-- lib/Internal/Insert.hs | 246 +++++++++++++++++++++------------ lib/Internal/Statement.hs | 12 +- lib/Internal/Types.hs | 17 +-- lib/Internal/Utils.hs | 47 +++---- package.yaml | 72 +++++++--- 11 files changed, 358 insertions(+), 195 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index b418112..f479df0 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,7 +1,8 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ImplicitPrelude #-} module Main (main) where +import Control.Monad.Reader import qualified Data.Text.IO as TI import Internal.Config import Internal.Database.Ops @@ -162,11 +163,11 @@ runSync c = do case res of Left es -> throwIO $ InsertException es Right s -> do - flip runReaderT (s $ takeDirectory c) $ do - es1 <- concat <$> mapM insertBudget (budget config) - es2 <- insertStatements config - let es = es1 ++ es2 - unless (null es) $ throwIO $ InsertException es + let run = mapReaderT $ flip runReaderT (s $ takeDirectory c) + es1 <- concat <$> mapM (run . insertBudget) (budget config) + es2 <- run $ insertStatements config + let es = es1 ++ es2 + unless (null es) $ throwIO $ InsertException es where err (InsertException es) = do liftIO $ mapM_ TI.putStrLn $ concatMap showError es diff --git a/budget.cabal b/budget.cabal index 90ea7b0..d2df83b 100644 --- a/budget.cabal +++ b/budget.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.35.1. +-- This file has been generated from package.yaml by hpack version 0.35.2. -- -- see: https://github.com/sol/hpack @@ -36,6 +36,42 @@ library Paths_budget hs-source-dirs: lib/ + default-extensions: + OverloadedStrings + FlexibleContexts + FlexibleInstances + InstanceSigs + MultiParamTypeClasses + EmptyCase + LambdaCase + MultiWayIf + NamedFieldPuns + TupleSections + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveLift + DeriveTraversable + DerivingStrategies + DeriveDataTypeable + EmptyDataDecls + PartialTypeSignatures + GeneralizedNewtypeDeriving + StandaloneDeriving + BangPatterns + TypeOperators + ScopedTypeVariables + TypeApplications + ConstraintKinds + RankNTypes + GADTs + DefaultSignatures + NoImplicitPrelude + FunctionalDependencies + DataKinds + TypeFamilies + BinaryLiterals + ViewPatterns ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -Wpartial-fields -Werror -O2 build-depends: base >=4.12 && <10 @@ -50,6 +86,7 @@ library , hashable , lens >=5.0.1 , monad-logger >=0.3.36 + , mtl , optparse-applicative , persistent >=2.13.3.1 , persistent-sqlite >=2.13.1.0 @@ -67,6 +104,42 @@ executable pwncash Paths_budget hs-source-dirs: app + default-extensions: + OverloadedStrings + FlexibleContexts + FlexibleInstances + InstanceSigs + MultiParamTypeClasses + EmptyCase + LambdaCase + MultiWayIf + NamedFieldPuns + TupleSections + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveLift + DeriveTraversable + DerivingStrategies + DeriveDataTypeable + EmptyDataDecls + PartialTypeSignatures + GeneralizedNewtypeDeriving + StandaloneDeriving + BangPatterns + TypeOperators + ScopedTypeVariables + TypeApplications + ConstraintKinds + RankNTypes + GADTs + DefaultSignatures + NoImplicitPrelude + FunctionalDependencies + DataKinds + TypeFamilies + BinaryLiterals + ViewPatterns ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -Wpartial-fields -Werror -O2 -threaded build-depends: base >=4.12 && <10 @@ -82,6 +155,7 @@ executable pwncash , hashable , lens >=5.0.1 , monad-logger >=0.3.36 + , mtl , optparse-applicative , persistent >=2.13.3.1 , persistent-sqlite >=2.13.1.0 diff --git a/dhall/Types.dhall b/dhall/Types.dhall index c098675..1ae7e69 100644 --- a/dhall/Types.dhall +++ b/dhall/Types.dhall @@ -187,7 +187,9 @@ let IncomeBucket = < PreTax | IntraTax | PostTax > let Amount = { amtValue : Decimal, amtDesc : Text } -let TimeAmount = { taWhen : DatePat, taAmt : Amount } +let AmountType = < FixedAmt | Percent | Target > + +let TimeAmount = { taWhen : DatePat, taAmt : Amount, taAmtType : AmountType } let Tax = { taxAcnt : AcntID, taxValue : Decimal } @@ -264,4 +266,5 @@ in { CurID , Allocation , Amount , TimeAmount + , AmountType } diff --git a/lib/Internal/Config.hs b/lib/Internal/Config.hs index db10590..30a07c7 100644 --- a/lib/Internal/Config.hs +++ b/lib/Internal/Config.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude #-} - module Internal.Config ( readConfig -- , readYaml diff --git a/lib/Internal/Database/Model.hs b/lib/Internal/Database/Model.hs index 42aa696..ea6b684 100644 --- a/lib/Internal/Database/Model.hs +++ b/lib/Internal/Database/Model.hs @@ -1,20 +1,6 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE NoImplicitPrelude #-} module Internal.Database.Model where @@ -84,13 +70,42 @@ data DBState = DBState , kmStatementInterval :: !Bounds , kmNewCommits :: ![Int] , kmConfigDir :: !FilePath - , kmBoundsCache :: !(MVar (M.Map (Bounds, DatePat) [Day])) } -type MappingT m a = ReaderT DBState (SqlPersistT m) a +type MappingT m = ReaderT DBState (SqlPersistT m) type KeySplit = Split AccountRId Rational CurrencyRId type KeyTx = Tx KeySplit type TreeR = Tree ([T.Text], AccountRId) + +type Balances = M.Map AccountRId Rational + +type BalanceM m = ReaderT (MVar Balances) m + +class MonadUnliftIO m => MonadFinance m where + askDBState :: (DBState -> a) -> m a + +instance MonadUnliftIO m => MonadFinance (ReaderT DBState m) where + askDBState = asks + +class MonadUnliftIO m => MonadBalance m where + askBalances :: m (MVar Balances) + + withBalances :: (Balances -> m a) -> m a + withBalances f = do + bs <- askBalances + withMVar bs f + + modifyBalances :: (Balances -> m (Balances, a)) -> m a + modifyBalances f = do + bs <- askBalances + modifyMVar bs f + + lookupBalance :: AccountRId -> m Rational + lookupBalance i = withBalances $ return . fromMaybe 0 . M.lookup i + + addBalance :: AccountRId -> Rational -> m () + addBalance i v = + modifyBalances $ return . (,()) . M.alter (Just . maybe v (v +)) i diff --git a/lib/Internal/Database/Ops.hs b/lib/Internal/Database/Ops.hs index 7bcddc4..7d90a27 100644 --- a/lib/Internal/Database/Ops.hs +++ b/lib/Internal/Database/Ops.hs @@ -1,11 +1,3 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE NoImplicitPrelude #-} - module Internal.Database.Ops ( migrate_ , nukeTables @@ -48,6 +40,7 @@ migrate_ c more = (openConnection c) ( \backend -> flip runSqlConn backend $ do + _ <- askLoggerIO runMigration migrateAll more ) @@ -198,7 +191,8 @@ updateCurrencies cs = do return $ currencyMap curs currency2Record :: Currency -> Entity CurrencyR -currency2Record c@Currency {..} = Entity (toKey c) $ CurrencyR curSymbol curFullname +currency2Record c@Currency {curSymbol, curFullname} = + Entity (toKey c) $ CurrencyR curSymbol curFullname currencyMap :: [Entity CurrencyR] -> CurrencyMap currencyMap = M.fromList . fmap (\e -> (currencyRSymbol $ entityVal e, entityKey e)) @@ -291,7 +285,7 @@ xs !? n n flattenAcntRoot :: AccountRoot -> [(AcntType, AccountTree)] -flattenAcntRoot AccountRoot_ {..} = +flattenAcntRoot AccountRoot_ {arIncome, arExpenses, arLiabilities, arAssets, arEquity} = ((IncomeT,) <$> arIncome) ++ ((ExpenseT,) <$> arExpenses) ++ ((LiabilityT,) <$> arLiabilities) @@ -315,7 +309,6 @@ getDBState c = do am <- updateAccounts $ accounts c cm <- updateCurrencies $ currencies c hs <- updateHashes c - v <- newMVar M.empty -- TODO not sure how I feel about this, probably will change this struct alot -- in the future so whatever...for now return $ concatEither2 bi si $ \b s f -> @@ -326,7 +319,6 @@ getDBState c = do , kmStatementInterval = s , kmNewCommits = hs , kmConfigDir = f - , kmBoundsCache = v } where bi = resolveBounds $ budgetInterval $ global c diff --git a/lib/Internal/Insert.hs b/lib/Internal/Insert.hs index 499e220..ee1f72d 100644 --- a/lib/Internal/Insert.hs +++ b/lib/Internal/Insert.hs @@ -1,8 +1,3 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE NoImplicitPrelude #-} - module Internal.Insert ( insertStatements , insertBudget @@ -17,6 +12,8 @@ import Internal.Statement import Internal.Types hiding (sign) import Internal.Utils import RIO hiding (to) +import qualified RIO.List as L +import qualified RIO.Map as M import qualified RIO.Text as T import RIO.Time @@ -43,12 +40,13 @@ expandModPat ModPat {mpStart = s, mpBy = b, mpUnit = u, mpRepeats = r} bs = Year -> addGregorianYearsClip expandCronPat :: Bounds -> CronPat -> EitherErrs [Day] -expandCronPat b CronPat {..} = concatEither3 yRes mRes dRes $ \ys ms ds -> - filter validWeekday $ - mapMaybe (uncurry3 toDay) $ - takeWhile (\((y, _), m, d) -> (y, m, d) <= (yb1, mb1, db1)) $ - dropWhile (\((y, _), m, d) -> (y, m, d) < (yb0, mb0, db0)) $ - [(y, m, d) | y <- (\y -> (y, isLeapYear y)) <$> ys, m <- ms, d <- ds] +expandCronPat b CronPat {cronYear, cronMonth, cronDay, cronWeekly} = + concatEither3 yRes mRes dRes $ \ys ms ds -> + filter validWeekday $ + mapMaybe (uncurry3 toDay) $ + takeWhile (\((y, _), m, d) -> (y, m, d) <= (yb1, mb1, db1)) $ + dropWhile (\((y, _), m, d) -> (y, m, d) < (yb0, mb0, db0)) $ + [(y, m, d) | y <- (\y -> (y, isLeapYear y)) <$> ys, m <- ms, d <- ds] where yRes = case cronYear of Nothing -> return [yb0 .. yb1] @@ -95,36 +93,36 @@ dayToWeekday :: Day -> Int dayToWeekday (ModifiedJulianDay d) = mod (fromIntegral d + 2) 7 withDates - :: MonadUnliftIO m + :: MonadFinance m => DatePat - -> (Day -> MappingT m a) - -> MappingT m (EitherErrs [a]) + -> (Day -> SqlPersistT m a) + -> SqlPersistT m (EitherErrs [a]) withDates dp f = do - bounds <- asks kmBudgetInterval + bounds <- lift $ askDBState kmBudgetInterval let days = expandDatePat bounds dp mapM (mapM f) days -------------------------------------------------------------------------------- -- budget -insertBudget :: MonadUnliftIO m => Budget -> MappingT m [InsertError] +insertBudget :: MonadFinance m => Budget -> SqlPersistT m [InsertError] insertBudget Budget {budgetLabel = name, income = is, transfers = es} = do es1 <- mapM (insertIncome name) is - es2 <- mapM (insertTransfer name) es - return $ concat $ es1 ++ es2 + es2 <- insertTransfers name es + return $ concat es1 ++ es2 -- TODO this hashes twice (not that it really matters) whenHash - :: (Hashable a, MonadUnliftIO m) + :: (Hashable a, MonadFinance m) => ConfigType -> a -> b - -> (Key CommitR -> MappingT m b) - -> MappingT m b + -> (Key CommitR -> SqlPersistT m b) + -> SqlPersistT m b whenHash t o def f = do let h = hash o - hs <- asks kmNewCommits - if h `elem` hs then f =<< lift (insert $ CommitR h t) else return def + hs <- lift $ askDBState kmNewCommits + if h `elem` hs then f =<< insert (CommitR h t) else return def -- TODO allow currency conversions here data BudgetSplit b = BudgetSplit @@ -147,26 +145,28 @@ data BudgetTx = BudgetTx , btDesc :: !T.Text } -insertIncome :: MonadUnliftIO m => T.Text -> Income -> MappingT m [InsertError] -insertIncome name i@Income {..} = - whenHash CTIncome i [] $ \c -> - unlessLeft (balanceIncome i) $ \balance -> do - res <- withDates incWhen $ \day -> do - let meta = BudgetMeta c day incCurrency name - let fromAllos b = concatMap (fromAllo meta incFrom (Just b)) - let pre = fromAllos PreTax incPretax - let tax = fmap (fromTax meta incFrom) incTaxes - let post = fromAllos PostTax incPosttax - let bal = - BudgetTx - { btMeta = meta - , btFrom = BudgetSplit incFrom $ Just PostTax - , btTo = BudgetSplit incToBal Nothing - , btValue = balance - , btDesc = "balance after deductions" - } - fmap concat $ mapM insertBudgetTx $ bal : (pre ++ tax ++ post) - unlessLefts res $ return . concat +insertIncome :: MonadFinance m => T.Text -> Income -> SqlPersistT m [InsertError] +insertIncome + name + i@Income {incWhen, incCurrency, incFrom, incPretax, incPosttax, incTaxes, incToBal} = + whenHash CTIncome i [] $ \c -> + unlessLeft (balanceIncome i) $ \balance -> do + res <- withDates incWhen $ \day -> do + let meta = BudgetMeta c day incCurrency name + let fromAllos b = concatMap (fromAllo meta incFrom (Just b)) + let pre = fromAllos PreTax incPretax + let tax = fmap (fromTax meta incFrom) incTaxes + let post = fromAllos PostTax incPosttax + let bal = + BudgetTx + { btMeta = meta + , btFrom = BudgetSplit incFrom $ Just PostTax + , btTo = BudgetSplit incToBal Nothing + , btValue = balance + , btDesc = "balance after deductions" + } + fmap concat $ mapM insertBudgetTx $ bal : (pre ++ tax ++ post) + unlessLefts res $ return . concat fromAllo :: BudgetMeta @@ -174,7 +174,8 @@ fromAllo -> Maybe IncomeBucket -> Allocation -> [BudgetTx] -fromAllo meta from ib Allocation {..} = fmap (toBT alloPath) alloAmts +fromAllo meta from ib Allocation {alloPath, alloAmts, alloBucket} = + fmap (toBT alloPath) alloAmts where toBT to (Amount desc v) = BudgetTx @@ -215,33 +216,98 @@ sumAllocation = sum . fmap (dec2Rat . amtValue) . alloAmts sumTaxes :: [Tax] -> Rational sumTaxes = sum . fmap (dec2Rat . taxValue) -insertTransfer :: MonadUnliftIO m => T.Text -> Transfer -> MappingT m [InsertError] -insertTransfer name t@Transfer {..} = - fmap concat $ whenHash CTExpense t [] $ \key -> do - forM transAmounts $ \(TimeAmount amt pat) -> do - res <- withDates pat $ \day -> insertBudgetTx $ budgetTx amt day key - unlessLefts res $ return . concat - where - meta d c = - BudgetMeta - { bmWhen = d - , bmCur = transCurrency - , bmCommit = c - , bmName = name - } - budgetTx (Amount desc v) d c = - BudgetTx - { btMeta = meta d c - , btFrom = BudgetSplit transFrom Nothing - , btTo = BudgetSplit transTo Nothing - , btValue = dec2Rat v - , btDesc = desc - } +insertTransfers :: MonadFinance m => T.Text -> [Transfer] -> SqlPersistT m [InsertError] +insertTransfers name ts = do + res <- expandTransfers name ts + unlessLefts res $ \txs -> + fmap concat <$> mapM insertBudgetTx $ balanceTransfers txs -insertBudgetTx :: MonadUnliftIO m => BudgetTx -> MappingT m [InsertError] -insertBudgetTx BudgetTx {..} = do +expandTransfers :: MonadFinance m => T.Text -> [Transfer] -> SqlPersistT m (EitherErrs [TransferTx]) +expandTransfers name ts = do + txs <- mapM (expandTransfer name) ts + return $ L.sortOn (bmWhen . trxMeta) . concat <$> concatEithersL txs + +-- TODO the entire budget needs to have this process applied to it +balanceTransfers :: [TransferTx] -> [BudgetTx] +balanceTransfers ts = snd $ L.mapAccumR go initBals $ L.sortOn (bmWhen . trxMeta) ts + where + initBals = M.fromList $ fmap (,0) $ L.nub $ (fmap trxTo ts ++ fmap trxTo ts) + updateBal x = M.update (Just . (+ x)) + lookupBal = M.findWithDefault (error "this should not happen") + go bals TransferTx {trxMeta, trxFrom, trxTo, trxValue, trxType, trxDesc} = + let bal = lookupBal trxTo bals + x = amtToMove bal trxType trxValue + t = + BudgetTx + { btMeta = trxMeta + , btFrom = BudgetSplit trxFrom Nothing + , btTo = BudgetSplit trxTo Nothing + , btValue = x + , btDesc = trxDesc + } + in (updateBal x trxFrom $ updateBal (-x) trxFrom bals, t) + -- TODO might need to query signs to make this intuitive; as it is this will + -- probably work, but for credit accounts I might need to supply a negative + -- target value + amtToMove _ FixedAmt x = x + amtToMove bal Percent x = -(x / 100 * bal) + amtToMove bal Target x = x - bal + +expandTransfer :: MonadFinance m => T.Text -> Transfer -> SqlPersistT m (EitherErrs [TransferTx]) +expandTransfer name t@Transfer {transAmounts, transTo, transCurrency, transFrom} = + whenHash CTExpense t (Right []) $ \key -> do + res <- forM transAmounts $ \(TimeAmount (Amount desc v) atype pat) -> + withDates pat $ \day -> + let meta = + BudgetMeta + { bmWhen = day + , bmCur = transCurrency + , bmCommit = key + , bmName = name + } + in return $ + TransferTx + { trxMeta = meta + , trxFrom = transFrom + , trxTo = transTo + , trxValue = dec2Rat v + , trxType = atype + , trxDesc = desc + } + return $ concat <$> concatEithersL res + +data TransferTx = TransferTx + { trxMeta :: !BudgetMeta + , trxFrom :: !AcntID + , trxTo :: !AcntID + , trxValue :: !Rational + , trxType :: AmountType + , trxDesc :: !T.Text + } + +-- amountBalance +-- :: (MonadFinance m, MonadBalance m) +-- => AmountType +-- -> AcntID +-- -> Rational +-- -> SqlPersistT m (EitherErr Rational) +-- amountBalance at i v = do +-- res <- lookupAccountKey i +-- case res of +-- Left e -> return $ Left e +-- Right k -> do +-- b <- lookupBalance k +-- return $ Right $ case at of +-- FixedAmt -> v +-- -- TODO what is the sign for this? +-- Percent -> v / 100 * b +-- -- TODO what is the sign for this? +-- Target -> b - v + +insertBudgetTx :: MonadFinance m => BudgetTx -> SqlPersistT m [InsertError] +insertBudgetTx BudgetTx {btFrom, btTo, btMeta, btValue, btDesc} = do res <- splitPair (bsAcnt btFrom) (bsAcnt btTo) (bmCur btMeta) btValue - unlessLefts_ res $ \(sFrom, sTo) -> lift $ do + unlessLefts_ res $ \(sFrom, sTo) -> do k <- insert $ TransactionR (bmCommit btMeta) (bmWhen btMeta) btDesc insertBudgetLabel name k IncomeBucketR sFrom btFrom insertBudgetLabel name k ExpenseBucketR sTo btTo @@ -262,12 +328,12 @@ insertBudgetLabel name k bucketType split bs = do forM_ (bsBucket bs) $ insert_ . bucketType bk splitPair - :: MonadUnliftIO m + :: MonadFinance m => AcntID -> AcntID -> CurID -> Rational - -> MappingT m (EitherErrs (KeySplit, KeySplit)) + -> SqlPersistT m (EitherErrs (KeySplit, KeySplit)) splitPair from to cur val = do s1 <- split from (-val) s2 <- split to val @@ -285,14 +351,14 @@ splitPair from to cur val = do -------------------------------------------------------------------------------- -- statements -insertStatements :: MonadUnliftIO m => Config -> MappingT m [InsertError] +insertStatements :: MonadFinance m => Config -> SqlPersistT m [InsertError] insertStatements conf = concat <$> mapM insertStatement (statements conf) -insertStatement :: MonadUnliftIO m => Statement -> MappingT m [InsertError] +insertStatement :: MonadFinance m => Statement -> SqlPersistT m [InsertError] insertStatement (StmtManual m) = insertManual m insertStatement (StmtImport i) = insertImport i -insertManual :: MonadUnliftIO m => Manual -> MappingT m [InsertError] +insertManual :: MonadFinance m => Manual -> SqlPersistT m [InsertError] insertManual m@Manual { manualDate = dp @@ -303,23 +369,23 @@ insertManual , manualDesc = e } = do whenHash CTManual m [] $ \c -> do - bounds <- asks kmStatementInterval + bounds <- lift $ askDBState kmStatementInterval -- let days = expandDatePat bounds dp let dayRes = expandDatePat bounds dp unlessLefts dayRes $ \days -> do txRes <- mapM tx days - unlessLefts_ (concatEithersL txRes) $ lift . mapM_ (insertTx c) + unlessLefts_ (concatEithersL txRes) $ mapM_ (insertTx c) where tx day = txPair day from to u (dec2Rat v) e -insertImport :: MonadUnliftIO m => Import -> MappingT m [InsertError] +insertImport :: MonadFinance m => Import -> SqlPersistT 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 <- expandBounds <$> asks kmStatementInterval + recoverIO (lift $ readImport i) $ \r -> unlessLefts r $ \bs -> do + bounds <- expandBounds <$> lift (askDBState kmStatementInterval) res <- mapM resolveTx $ filter (inBounds bounds . txDate) bs - unlessLefts_ (concatEithersL res) $ lift . mapM_ (insertTx c) + unlessLefts_ (concatEithersL res) $ mapM_ (insertTx c) where recoverIO x rest = do res <- tryIO x @@ -333,14 +399,14 @@ insertImport i = whenHash CTImport i [] $ \c -> do -- low-level transaction stuff txPair - :: MonadUnliftIO m + :: MonadFinance m => Day -> AcntID -> AcntID -> CurID -> Rational -> T.Text - -> MappingT m (EitherErrs KeyTx) + -> SqlPersistT m (EitherErrs KeyTx) txPair day from to cur val desc = resolveTx tx where split a v = Split {sAcnt = a, sValue = v, sComment = "", sCurrency = cur} @@ -352,12 +418,12 @@ 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 :: MonadFinance m => BalTx -> SqlPersistT m (EitherErrs KeyTx) resolveTx t@Tx {txSplits = ss} = do res <- concatEithersL <$> mapM resolveSplit ss return $ fmap (\kss -> t {txSplits = kss}) res -resolveSplit :: MonadUnliftIO m => BalSplit -> MappingT m (EitherErrs KeySplit) +resolveSplit :: MonadFinance m => BalSplit -> SqlPersistT m (EitherErrs KeySplit) resolveSplit s@Split {sAcnt = p, sCurrency = c, sValue = v} = do aid <- lookupAccountKey p cid <- lookupCurrency c @@ -380,14 +446,14 @@ 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 +lookupAccount :: MonadFinance m => AcntID -> SqlPersistT m (EitherErr (Key AccountR, AcntSign)) +lookupAccount p = lookupErr (DBKey AcntField) p <$> lift (askDBState kmAccount) -lookupAccountKey :: MonadUnliftIO m => AcntID -> MappingT m (EitherErr (Key AccountR)) +lookupAccountKey :: MonadFinance m => AcntID -> SqlPersistT m (EitherErr (Key AccountR)) lookupAccountKey = fmap (fmap fst) . lookupAccount -lookupAccountSign :: MonadUnliftIO m => AcntID -> MappingT m (EitherErr AcntSign) +lookupAccountSign :: MonadFinance m => AcntID -> SqlPersistT 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 +lookupCurrency :: MonadFinance m => T.Text -> SqlPersistT m (EitherErr (Key CurrencyR)) +lookupCurrency c = lookupErr (DBKey CurField) c <$> lift (askDBState kmCurrency) diff --git a/lib/Internal/Statement.hs b/lib/Internal/Statement.hs index 5576b73..a558bcb 100644 --- a/lib/Internal/Statement.hs +++ b/lib/Internal/Statement.hs @@ -1,8 +1,4 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE NoImplicitPrelude #-} module Internal.Statement ( readImport @@ -24,7 +20,7 @@ import qualified RIO.Vector as V -- TODO this probably won't scale well (pipes?) -readImport :: MonadUnliftIO m => Import -> MappingT m (EitherErrs [BalTx]) +readImport :: MonadFinance m => Import -> m (EitherErrs [BalTx]) readImport Import {..} = do let ores = plural $ compileOptions impTxOpts let cres = concatEithersL $ compileMatch <$> impMatches @@ -37,14 +33,14 @@ readImport Import {..} = do Left es -> return $ Left es readImport_ - :: MonadUnliftIO m + :: MonadFinance m => Natural -> Word -> TxOptsRe -> FilePath - -> MappingT m (EitherErr [TxRecord]) + -> m (EitherErr [TxRecord]) readImport_ n delim tns p = do - dir <- asks kmConfigDir + dir <- askDBState kmConfigDir bs <- liftIO $ BL.readFile $ dir p case decodeByNameWithP (parseTxRecord p tns) opts $ skip bs of Left m -> return $ Left $ ParseError $ T.pack m diff --git a/lib/Internal/Types.hs b/lib/Internal/Types.hs index 06f21b0..605d7be 100644 --- a/lib/Internal/Types.hs +++ b/lib/Internal/Types.hs @@ -1,17 +1,5 @@ {-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveLift #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE NoImplicitPrelude #-} module Internal.Types where @@ -45,6 +33,7 @@ makeHaskellTypesWith , MultipleConstructors "SplitNum" "(./dhall/Types.dhall).SplitNum" , MultipleConstructors "ExpenseBucket" "(./dhall/Types.dhall).ExpenseBucket" , MultipleConstructors "IncomeBucket" "(./dhall/Types.dhall).IncomeBucket" + , MultipleConstructors "AmountType" "(./dhall/Types.dhall).AmountType" , SingleConstructor "Currency" "Currency" "(./dhall/Types.dhall).Currency" , SingleConstructor "Gregorian" "Gregorian" "(./dhall/Types.dhall).Gregorian" , SingleConstructor "GregorianM" "GregorianM" "(./dhall/Types.dhall).GregorianM" @@ -303,6 +292,10 @@ instance PersistField ExpenseBucket where instance PersistFieldSql ExpenseBucket where sqlType _ = SqlString +deriving instance Eq AmountType + +deriving instance Hashable AmountType + deriving instance Eq TimeAmount deriving instance Hashable TimeAmount diff --git a/lib/Internal/Utils.hs b/lib/Internal/Utils.hs index b473fb3..eda228c 100644 --- a/lib/Internal/Utils.hs +++ b/lib/Internal/Utils.hs @@ -1,8 +1,3 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE NoImplicitPrelude #-} - module Internal.Utils ( compareDate , inBounds @@ -78,14 +73,14 @@ xGregToDay :: XGregorian -> Day xGregToDay XGregorian {xgYear = y, xgMonth = m, xgDay = d} = fromGregorian (fromIntegral y) m d gregTup :: Gregorian -> (Integer, Int, Int) -gregTup Gregorian {..} = +gregTup Gregorian {gYear, gMonth, gDay} = ( fromIntegral gYear , fromIntegral gMonth , fromIntegral gDay ) gregMTup :: GregorianM -> (Integer, Int) -gregMTup GregorianM {..} = +gregMTup GregorianM {gmYear, gmMonth} = ( fromIntegral gmYear , fromIntegral gmMonth ) @@ -145,20 +140,22 @@ expandBounds (d, n) = (d, addDays (fromIntegral n + 1) d) -- matching matches :: MatchRe -> TxRecord -> EitherErrs (MatchRes RawTx) -matches Match {..} r@TxRecord {..} = do - res <- concatEither3 val other desc $ \x y z -> x && y && z - if date && res - then maybe (Right MatchSkip) (fmap MatchPass . convert) mTx - else Right MatchFail - where - val = valMatches mVal trAmount - date = maybe True (`dateMatches` trDate) mDate - other = foldM (\a o -> (a &&) <$> otherMatches trOther o) True mOther - desc = maybe (return True) (matchMaybe trDesc . snd) mDesc - convert (ToTx cur a ss) = toTx cur a ss r +matches + Match {mTx, mOther, mVal, mDate, mDesc} + r@TxRecord {trDate, trAmount, trDesc, trOther} = do + res <- concatEither3 val other desc $ \x y z -> x && y && z + if date && res + then maybe (Right MatchSkip) (fmap MatchPass . convert) mTx + else Right MatchFail + where + val = valMatches mVal trAmount + date = maybe True (`dateMatches` trDate) mDate + other = foldM (\a o -> (a &&) <$> otherMatches trOther o) True mOther + desc = maybe (return True) (matchMaybe trDesc . snd) mDesc + convert (ToTx cur a ss) = toTx cur a ss r toTx :: SplitCur -> SplitAcnt -> [ExpSplit] -> TxRecord -> EitherErrs RawTx -toTx sc sa toSplits r@TxRecord {..} = +toTx sc sa toSplits r@TxRecord {trAmount, trDate, trDesc} = concatEithers2 acRes ssRes $ \(a_, c_) ss_ -> let fromSplit = Split @@ -178,7 +175,7 @@ toTx sc sa toSplits r@TxRecord {..} = ssRes = concatEithersL $ fmap (resolveSplit r) toSplits valMatches :: MatchVal -> Rational -> EitherErr Bool -valMatches MatchVal {..} x +valMatches MatchVal {mvDen, mvSign, mvNum, mvPrec} x | Just d_ <- mvDen, d_ >= p = Left $ MatchValPrecisionError d_ p | otherwise = Right $ @@ -251,8 +248,9 @@ parseRational (pat, re) s = case matchGroupsMaybe s re of _ -> msg "malformed decimal" where readT what t = case readMaybe $ T.unpack t of - Just d -> return $ fromInteger d + Just d -> return d _ -> msg $ T.unwords ["could not parse", what, t] + msg :: MonadFail m => T.Text -> m a msg m = fail $ T.unpack $ @@ -296,7 +294,7 @@ fmtRational precision x = T.concat [s, txt n', ".", pad 2 "0" $ txt d'] pad i c z = T.append (T.replicate (i - T.length z) c) z dec2Rat :: Decimal -> Rational -dec2Rat D {..} = +dec2Rat D {sign, whole, decimal, precision} = k * (fromIntegral whole + (fromIntegral decimal % (10 ^ precision))) where k = if sign then 1 else -1 @@ -364,7 +362,7 @@ showError other = (: []) $ case other of splits = T.intercalate ", " $ fmap (singleQuote . showSplit) rss showGregorian_ :: Gregorian -> T.Text -showGregorian_ Gregorian {..} = T.intercalate "-" $ showT <$> [gYear, gMonth, gDay] +showGregorian_ Gregorian {gYear, gMonth, gDay} = T.intercalate "-" $ showT <$> [gYear, gMonth, gDay] showTx :: TxRecord -> T.Text showTx TxRecord {trDate = d, trAmount = v, trDesc = e, trFile = f} = @@ -428,7 +426,8 @@ showYMD_ md = showMatchVal :: MatchVal -> Maybe T.Text showMatchVal MatchVal {mvSign = Nothing, mvNum = Nothing, mvDen = Nothing} = Nothing -showMatchVal MatchVal {..} = Just $ singleQuote $ keyVals [(k, v) | (k, Just v) <- kvs] +showMatchVal MatchVal {mvNum, mvDen, mvSign, mvPrec} = + Just $ singleQuote $ keyVals [(k, v) | (k, Just v) <- kvs] where kvs = [ ("sign", (\s -> if s then "+" else "-") <$> mvSign) diff --git a/package.yaml b/package.yaml index fe911f1..5adf743 100644 --- a/package.yaml +++ b/package.yaml @@ -10,15 +10,59 @@ extra-source-files: - README.md - ChangeLog.md -# Metadata used when publishing your package # synopsis: Short description of your package # category: Web -# To avoid duplicated efforts in documentation and dealing with the -# complications of embedding Haddock markup inside cabal files, it is -# common to point users to the README.md file. description: Please see the README on GitHub at +default-extensions: + - OverloadedStrings + - FlexibleContexts + - FlexibleInstances + - InstanceSigs + - MultiParamTypeClasses + - EmptyCase + - LambdaCase + - MultiWayIf + - NamedFieldPuns + - TupleSections + - DeriveFoldable + - DeriveFunctor + - DeriveGeneric + - DeriveLift + - DeriveTraversable + - DerivingStrategies + - DeriveDataTypeable + - EmptyDataDecls + - PartialTypeSignatures + - GeneralizedNewtypeDeriving + - StandaloneDeriving + - BangPatterns + - TypeOperators + - ScopedTypeVariables + - TypeApplications + - ConstraintKinds + - RankNTypes + - GADTs + - DefaultSignatures + - NoImplicitPrelude + - FunctionalDependencies + - DataKinds + - TypeFamilies + - BinaryLiterals + - ViewPatterns + +ghc-options: +- -Wall +- -Wcompat +- -Widentities +- -Wincomplete-record-updates +- -Wincomplete-uni-patterns +- -Wredundant-constraints +- -Wpartial-fields +- -Werror +- -O2 + dependencies: - base >= 4.12 && < 10 - rio >= 0.1.21.0 @@ -41,34 +85,16 @@ dependencies: - recursion-schemes - data-fix - filepath +- mtl library: source-dirs: lib/ - ghc-options: - - -Wall - - -Wcompat - - -Widentities - - -Wincomplete-record-updates - - -Wincomplete-uni-patterns - - -Wredundant-constraints - - -Wpartial-fields - - -Werror - - -O2 executables: pwncash: main: Main.hs source-dirs: app ghc-options: - - -Wall - - -Wcompat - - -Widentities - - -Wincomplete-record-updates - - -Wincomplete-uni-patterns - - -Wredundant-constraints - - -Wpartial-fields - - -Werror - - -O2 - -threaded dependencies: - budget