From 5dfbc3ef419e1c9e9800f79b2cb635dcb3cb7705 Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Mon, 29 May 2023 13:09:17 -0400 Subject: [PATCH 01/15] ADD local budget interval --- lib/Internal/Database/Ops.hs | 11 ++- lib/Internal/Insert.hs | 157 ++++++++++++++++++++--------------- lib/Internal/Types.hs | 1 + lib/Internal/Utils.hs | 19 ++++- 4 files changed, 117 insertions(+), 71 deletions(-) diff --git a/lib/Internal/Database/Ops.hs b/lib/Internal/Database/Ops.hs index f7c95a3..182f6f0 100644 --- a/lib/Internal/Database/Ops.hs +++ b/lib/Internal/Database/Ops.hs @@ -19,8 +19,15 @@ import Database.Esqueleto.Experimental ((==.), (^.)) import qualified Database.Esqueleto.Experimental as E import Database.Esqueleto.Internal.Internal (SqlSelect) import Database.Persist.Monad --- import Database.Persist.Sql hiding (delete, runMigration, (==.), (||.)) -import Database.Persist.Sqlite hiding (delete, deleteWhere, insert, insertKey, runMigration, (==.), (||.)) +import Database.Persist.Sqlite hiding + ( delete + , deleteWhere + , insert + , insertKey + , runMigration + , (==.) + , (||.) + ) import GHC.Err import Internal.Types import Internal.Utils diff --git a/lib/Internal/Insert.hs b/lib/Internal/Insert.hs index be2838c..6f06a70 100644 --- a/lib/Internal/Insert.hs +++ b/lib/Internal/Insert.hs @@ -95,6 +95,22 @@ expandMDYPat lower upper (Repeat RepeatPat {rpStart = s, rpBy = b, rpRepeats = r dayToWeekday :: Day -> Int dayToWeekday (ModifiedJulianDay d) = mod (fromIntegral d + 2) 7 +askDays + :: (MonadFinance m, MonadInsertError m) + => DatePat + -> Maybe Interval + -> m [Day] +askDays dp i = do + globalBounds <- askDBState kmBudgetInterval + case i of + Just i' -> do + localBounds <- liftExcept $ resolveBounds i' + let bounds = intersectBounds globalBounds localBounds + maybe (return []) expand bounds + Nothing -> expand globalBounds + where + expand bs = liftExcept $ expandDatePat bs dp + withDates :: (MonadSqlQuery m, MonadFinance m, MonadInsertError m) => DatePat @@ -105,15 +121,13 @@ withDates dp f = do days <- liftExcept $ expandDatePat bounds dp combineErrors $ fmap f days -foldDates - :: (MonadSqlQuery m, MonadFinance m, MonadInsertError m) - => DatePat +foldDays + :: MonadInsertError m + => (Day -> Day -> m a) -> Day - -> (Day -> Day -> m a) + -> [Day] -> m [a] -foldDates dp start f = do - bounds <- askDBState kmBudgetInterval - days <- liftExcept $ expandDatePat bounds dp +foldDays f start days = combineErrors $ snd $ L.mapAccumL (\prevDay day -> (day, f prevDay day)) start days @@ -145,11 +159,12 @@ insertBudget , bgtPretax , bgtTax , bgtPosttax + , bgtInterval } = whenHash CTBudget b () $ \key -> do intAllos <- combineError3 pre_ tax_ post_ (,,) - let res1 = mapErrors (insertIncome key bgtLabel intAllos) bgtIncomes - let res2 = expandTransfers key bgtLabel bgtTransfers + let res1 = mapErrors (insertIncome key bgtLabel intAllos bgtInterval) bgtIncomes + let res2 = expandTransfers key bgtLabel bgtInterval bgtTransfers txs <- combineError (concat <$> res1) res2 (++) m <- askDBState kmCurrency shadow <- liftExcept $ addShadowTransfers m bgtShadowTransfers txs @@ -160,7 +175,7 @@ insertBudget post_ = sortAllos bgtPosttax sortAllos = liftExcept . combineErrors . fmap sortAllo -type BoundAllocation = Allocation (Day, Day) +type BoundAllocation = Allocation Bounds type IntAllocations = ( [BoundAllocation PretaxValue] @@ -180,7 +195,7 @@ sortAllo a@Allocation {alloAmts = as} = do res <- case xs of [] -> resolveBounds start (y : _) -> resolveBounds_ (intStart $ amtWhen y) start - foldBounds (x {amtWhen = expandBounds res} : acc) xs + foldBounds (x {amtWhen = res} : acc) xs -- TODO this is going to be O(n*m), which might be a problem? addShadowTransfers @@ -209,35 +224,35 @@ fromShadow cm tx t@ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, st Just $ -- TODO does this actually share the same metadata as the "parent" tx? FlatTransfer - { cbtMeta = cbtMeta tx - , cbtWhen = cbtWhen tx - , cbtCur = stCurrency - , cbtFrom = stFrom - , cbtTo = stTo - , cbtValue = UnbalancedValue stType $ v * cvValue (cbtValue tx) - , cbtDesc = stDesc + { ftMeta = ftMeta tx + , ftWhen = ftWhen tx + , ftCur = stCurrency + , ftFrom = stFrom + , ftTo = stTo + , ftValue = UnbalancedValue stType $ v * cvValue (ftValue tx) + , ftDesc = stDesc } shadowMatches :: TransferMatcher -> UnbalancedTransfer -> InsertExcept Bool shadowMatches TransferMatcher {tmFrom, tmTo, tmDate, tmVal} tx = do - valRes <- valMatches tmVal $ cvValue $ cbtValue tx + valRes <- valMatches tmVal $ cvValue $ ftValue tx return $ - memberMaybe (taAcnt $ cbtFrom tx) tmFrom - && memberMaybe (taAcnt $ cbtTo tx) tmTo - && maybe True (`dateMatches` cbtWhen tx) tmDate + memberMaybe (taAcnt $ ftFrom tx) tmFrom + && memberMaybe (taAcnt $ ftTo tx) tmTo + && maybe True (`dateMatches` ftWhen tx) tmDate && valRes where memberMaybe x AcntSet {asList, asInclude} = (if asInclude then id else not) $ x `elem` asList balanceTransfers :: [UnbalancedTransfer] -> [BalancedTransfer] -balanceTransfers = snd . L.mapAccumR go M.empty . reverse . L.sortOn cbtWhen +balanceTransfers = snd . L.mapAccumR go M.empty . reverse . L.sortOn ftWhen where - go bals f@FlatTransfer {cbtFrom, cbtTo, cbtValue = UnbalancedValue {cvValue, cvType}} = - let balTo = M.findWithDefault 0 cbtTo bals + go bals f@FlatTransfer {ftFrom, ftTo, ftValue = UnbalancedValue {cvValue, cvType}} = + let balTo = M.findWithDefault 0 ftTo bals x = amtToMove balTo cvType cvValue - bals' = mapAdd_ cbtTo x $ mapAdd_ cbtFrom (-x) bals - in (bals', f {cbtValue = x}) + bals' = mapAdd_ ftTo x $ mapAdd_ ftFrom (-x) bals + in (bals', f {ftValue = x}) -- 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 @@ -255,13 +270,13 @@ data BudgetMeta = BudgetMeta deriving (Show) data FlatTransfer v = FlatTransfer - { cbtFrom :: !TaggedAcnt - , cbtTo :: !TaggedAcnt - , cbtValue :: !v - , cbtWhen :: !Day - , cbtDesc :: !T.Text - , cbtMeta :: !BudgetMeta - , cbtCur :: !BudgetCurrency + { ftFrom :: !TaggedAcnt + , ftTo :: !TaggedAcnt + , ftValue :: !v + , ftWhen :: !Day + , ftDesc :: !T.Text + , ftMeta :: !BudgetMeta + , ftCur :: !BudgetCurrency } deriving (Show) @@ -276,16 +291,18 @@ type UnbalancedTransfer = FlatTransfer UnbalancedValue type BalancedTransfer = FlatTransfer Rational insertIncome - :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m) + :: (MonadInsertError m, MonadFinance m) => CommitRId -> T.Text -> IntAllocations + -> Maybe Interval -> Income -> m [UnbalancedTransfer] insertIncome key name (intPre, intTax, intPost) + localInterval Income { incWhen , incCurrency @@ -304,7 +321,8 @@ insertIncome -- TODO this will scan the interval allocations fully each time -- iteration which is a total waste, but the fix requires turning this -- loop into a fold which I don't feel like doing now :( - res <- foldDates incWhen start (allocate precision gross) + days <- askDays incWhen localInterval + res <- foldDays (allocate precision gross) start days return $ concat res where start = fromGregorian' $ pStart incPayPeriod @@ -330,13 +348,13 @@ insertIncome balance = aftertaxGross - sumAllos post bal = FlatTransfer - { cbtMeta = meta - , cbtWhen = day - , cbtFrom = incFrom - , cbtCur = NoX incCurrency - , cbtTo = incToBal - , cbtValue = UnbalancedValue BTFixed balance - , cbtDesc = "balance after deductions" + { ftMeta = meta + , ftWhen = day + , ftFrom = incFrom + , ftCur = NoX incCurrency + , ftTo = incToBal + , ftValue = UnbalancedValue BTFixed balance + , ftDesc = "balance after deductions" } in if balance < 0 then throwError $ InsertException [IncomeError day name balance] @@ -404,13 +422,13 @@ allo2Trans -> UnbalancedTransfer allo2Trans meta day from FlatAllocation {faValue, faTo, faDesc, faCur} = FlatTransfer - { cbtMeta = meta - , cbtWhen = day - , cbtFrom = from - , cbtCur = faCur - , cbtTo = faTo - , cbtValue = UnbalancedValue BTFixed faValue - , cbtDesc = faDesc + { ftMeta = meta + , ftWhen = day + , ftFrom = from + , ftCur = faCur + , ftTo = faTo + , ftValue = UnbalancedValue BTFixed faValue + , ftDesc = faDesc } allocateTax @@ -501,12 +519,19 @@ expandTransfers :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m) => CommitRId -> T.Text + -> Maybe Interval -> [BudgetTransfer] -> m [UnbalancedTransfer] -expandTransfers key name ts = - fmap (L.sortOn cbtWhen . concat) $ - combineErrors $ - fmap (expandTransfer key name) ts +expandTransfers key name localInterval ts = do + txs <- + fmap (L.sortOn ftWhen . concat) $ + combineErrors $ + fmap (expandTransfer key name) ts + case localInterval of + Nothing -> return txs + Just i -> do + bounds <- liftExcept $ resolveBounds i + return $ filter (inBounds bounds . ftWhen) txs initialCurrency :: BudgetCurrency -> CurID initialCurrency (NoX c) = c @@ -533,28 +558,28 @@ expandTransfer key name Transfer {transAmounts, transTo, transCurrency, transFro let meta = BudgetMeta {bmCommit = key, bmName = name} return FlatTransfer - { cbtMeta = meta - , cbtWhen = day - , cbtCur = transCurrency - , cbtFrom = transFrom - , cbtTo = transTo - , cbtValue = UnbalancedValue y $ roundPrecision precision v - , cbtDesc = desc + { ftMeta = meta + , ftWhen = day + , ftCur = transCurrency + , ftFrom = transFrom + , ftTo = transTo + , ftValue = UnbalancedValue y $ roundPrecision precision v + , ftDesc = desc } insertBudgetTx :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m) => BalancedTransfer -> m () -insertBudgetTx FlatTransfer {cbtFrom, cbtTo, cbtMeta, cbtCur, cbtValue, cbtDesc, cbtWhen} = do - ((sFrom, sTo), exchange) <- splitPair cbtFrom cbtTo cbtCur cbtValue +insertBudgetTx FlatTransfer {ftFrom, ftTo, ftMeta, ftCur, ftValue, ftDesc, ftWhen} = do + ((sFrom, sTo), exchange) <- splitPair ftFrom ftTo ftCur ftValue insertPair sFrom sTo forM_ exchange $ uncurry insertPair where insertPair from to = do - k <- insert $ TransactionR (bmCommit cbtMeta) cbtWhen cbtDesc + k <- insert $ TransactionR (bmCommit ftMeta) ftWhen ftDesc insertBudgetLabel k from insertBudgetLabel k to insertBudgetLabel k split = do sk <- insertSplit k split - insert_ $ BudgetLabelR sk $ bmName cbtMeta + insert_ $ BudgetLabelR sk $ bmName ftMeta type SplitPair = (KeySplit, KeySplit) @@ -646,7 +671,7 @@ insertHistTransfer readHistStmt :: (MonadUnliftIO m, MonadFinance m) => Statement -> m (Maybe (CommitR, [KeyTx])) readHistStmt i = whenHash_ CTImport i $ do bs <- readImport i - bounds <- expandBounds <$> askDBState kmStatementInterval + bounds <- askDBState kmStatementInterval liftIOExceptT $ mapErrors resolveTx $ filter (inBounds bounds . txDate) bs insertHistStmt :: (MonadSqlQuery m) => CommitR -> [KeyTx] -> m () diff --git a/lib/Internal/Types.hs b/lib/Internal/Types.hs index 6b7fc77..ab12036 100644 --- a/lib/Internal/Types.hs +++ b/lib/Internal/Types.hs @@ -200,6 +200,7 @@ data Budget = Budget , bgtPosttax :: [MultiAllocation PosttaxValue] , bgtTransfers :: [BudgetTransfer] , bgtShadowTransfers :: [ShadowTransfer] + , bgtInterval :: !(Maybe Interval) } deriving instance Hashable PretaxValue diff --git a/lib/Internal/Utils.hs b/lib/Internal/Utils.hs index 729fe65..e5723f9 100644 --- a/lib/Internal/Utils.hs +++ b/lib/Internal/Utils.hs @@ -8,6 +8,7 @@ module Internal.Utils , fromGregorian' , resolveBounds , resolveBounds_ + , intersectBounds , liftInner , liftExceptT , liftExcept @@ -161,14 +162,26 @@ compareDate (In md offset) x = do fromGregorian' :: Gregorian -> Day fromGregorian' = uncurry3 fromGregorian . gregTup --- TODO misleading name -inBounds :: (Day, Day) -> Day -> Bool -inBounds (d0, d1) x = d0 <= x && x < d1 +inBounds :: Bounds -> Day -> Bool +inBounds bs = withinDays (expandBounds bs) + +withinDays :: (Day, Day) -> Day -> Bool +withinDays (d0, d1) x = d0 <= x && x < d1 resolveBounds :: Interval -> InsertExcept Bounds resolveBounds i@Interval {intStart = s} = resolveBounds_ (s {gYear = gYear s + 50}) i +-- TODO not DRY +intersectBounds :: Bounds -> Bounds -> Maybe Bounds +intersectBounds a b = + if b' > a' then Nothing else Just (a', fromIntegral $ diffDays b' a' - 1) + where + (a0, a1) = expandBounds a + (b0, b1) = expandBounds b + a' = max a0 a1 + b' = min b0 b1 + resolveBounds_ :: Gregorian -> Interval -> InsertExcept Bounds resolveBounds_ def Interval {intStart = s, intEnd = e} = case fromGregorian' <$> e of From 02747b4678dbed1c71caebc5c49be46ee7314d21 Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Mon, 29 May 2023 14:46:30 -0400 Subject: [PATCH 02/15] REF split up types module to keep compile times sane --- app/Main.hs | 2 +- budget.cabal | 6 +- lib/Internal/Config.hs | 12 +- lib/Internal/Database/Ops.hs | 2 +- lib/Internal/Insert.hs | 4 +- lib/Internal/Statement.hs | 2 +- lib/Internal/Types/Database.hs | 75 ++++++ lib/Internal/{Types.hs => Types/Dhall.hs} | 276 +--------------------- lib/Internal/Types/Main.hs | 226 ++++++++++++++++++ lib/Internal/{ => Types}/TH.hs | 3 +- lib/Internal/Utils.hs | 12 +- 11 files changed, 317 insertions(+), 303 deletions(-) create mode 100644 lib/Internal/Types/Database.hs rename lib/Internal/{Types.hs => Types/Dhall.hs} (69%) create mode 100644 lib/Internal/Types/Main.hs rename lib/Internal/{ => Types}/TH.hs (73%) diff --git a/app/Main.hs b/app/Main.hs index 8142e30..8710d96 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -11,7 +11,7 @@ import Database.Persist.Monad import Internal.Config import Internal.Database.Ops import Internal.Insert -import Internal.Types +import Internal.Types.Main import Internal.Utils import Options.Applicative import RIO diff --git a/budget.cabal b/budget.cabal index c3ae77e..e80aa97 100644 --- a/budget.cabal +++ b/budget.cabal @@ -29,8 +29,10 @@ library Internal.Database.Ops Internal.Insert Internal.Statement - Internal.TH - Internal.Types + Internal.Types.Database + Internal.Types.Dhall + Internal.Types.Main + Internal.Types.TH Internal.Utils other-modules: Paths_budget diff --git a/lib/Internal/Config.hs b/lib/Internal/Config.hs index 30a07c7..93df85b 100644 --- a/lib/Internal/Config.hs +++ b/lib/Internal/Config.hs @@ -1,21 +1,11 @@ module Internal.Config ( readConfig - -- , readYaml ) where --- import Control.Exception --- import Data.Yaml import Dhall hiding (record) -import Internal.Types +import Internal.Types.Main import RIO readConfig :: MonadUnliftIO m => FilePath -> m Config readConfig confpath = liftIO $ unfix <$> inputFile auto confpath - --- readYaml :: FromJSON a => FilePath -> IO a --- readYaml p = do --- r <- decodeFileEither p --- case r of --- Right a -> return a --- Left e -> throw e diff --git a/lib/Internal/Database/Ops.hs b/lib/Internal/Database/Ops.hs index 182f6f0..0e6acef 100644 --- a/lib/Internal/Database/Ops.hs +++ b/lib/Internal/Database/Ops.hs @@ -29,7 +29,7 @@ import Database.Persist.Sqlite hiding , (||.) ) import GHC.Err -import Internal.Types +import Internal.Types.Main import Internal.Utils import RIO hiding (LogFunc, isNothing, on, (^.)) import RIO.List ((\\)) diff --git a/lib/Internal/Insert.hs b/lib/Internal/Insert.hs index 6f06a70..bf4a6f6 100644 --- a/lib/Internal/Insert.hs +++ b/lib/Internal/Insert.hs @@ -11,7 +11,7 @@ import Control.Monad.Except import Data.Hashable import Database.Persist.Monad import Internal.Statement -import Internal.Types +import Internal.Types.Main import Internal.Utils import RIO hiding (to) import qualified RIO.List as L @@ -222,7 +222,6 @@ fromShadow cm tx t@ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, st then Nothing else Just $ - -- TODO does this actually share the same metadata as the "parent" tx? FlatTransfer { ftMeta = ftMeta tx , ftWhen = ftWhen tx @@ -391,6 +390,7 @@ workingDays wds start end daysFull = fromIntegral (length wds') * nFull daysTail = fromIntegral $ length $ takeWhile (< nPart) wds' in return $ fromIntegral $ daysFull + daysTail + -- TODO make an error here that says something to the effect of "Period must be positive" | otherwise = throwError $ InsertException undefined where interval = diffDays end start diff --git a/lib/Internal/Statement.hs b/lib/Internal/Statement.hs index e7a325e..cf09dcb 100644 --- a/lib/Internal/Statement.hs +++ b/lib/Internal/Statement.hs @@ -8,7 +8,7 @@ where import Control.Monad.Error.Class import Control.Monad.Except import Data.Csv -import Internal.Types +import Internal.Types.Main import Internal.Utils import RIO import qualified RIO.ByteString.Lazy as BL diff --git a/lib/Internal/Types/Database.hs b/lib/Internal/Types/Database.hs new file mode 100644 index 0000000..9e82ca6 --- /dev/null +++ b/lib/Internal/Types/Database.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | Types corresponding to the database model +module Internal.Types.Database where + +import Database.Persist.Sql hiding (Desc, In, Statement) +import Database.Persist.TH +import RIO +import qualified RIO.Text as T +import RIO.Time + +share + [mkPersist sqlSettings, mkMigrate "migrateAll"] + [persistLowerCase| +CommitR sql=commits + hash Int + type ConfigType + deriving Show Eq +CurrencyR sql=currencies + symbol T.Text + fullname T.Text + precision Int + deriving Show Eq +TagR sql=tags + symbol T.Text + fullname T.Text + deriving Show Eq +AccountR sql=accounts + name T.Text + fullpath T.Text + desc T.Text + deriving Show Eq +AccountPathR sql=account_paths + parent AccountRId OnDeleteCascade + child AccountRId OnDeleteCascade + depth Int + deriving Show Eq +TransactionR sql=transactions + commit CommitRId OnDeleteCascade + date Day + description T.Text + deriving Show Eq +SplitR sql=splits + transaction TransactionRId OnDeleteCascade + currency CurrencyRId OnDeleteCascade + account AccountRId OnDeleteCascade + memo T.Text + value Rational + deriving Show Eq +TagRelationR sql=tag_relations + split SplitRId OnDeleteCascade + tag TagRId OnDeleteCascade +BudgetLabelR sql=budget_labels + split SplitRId OnDeleteCascade + budgetName T.Text + deriving Show Eq +|] + +data ConfigType = CTBudget | CTManual | CTImport + deriving (Eq, Show, Read, Enum) + +instance PersistFieldSql ConfigType where + sqlType _ = SqlString + +instance PersistField ConfigType where + toPersistValue = PersistText . T.pack . show + + -- TODO these error messages *might* be good enough? + fromPersistValue (PersistText v) = + maybe (Left $ "could not parse: " <> v) Right $ readMaybe $ T.unpack v + fromPersistValue _ = Left "wrong type" diff --git a/lib/Internal/Types.hs b/lib/Internal/Types/Dhall.hs similarity index 69% rename from lib/Internal/Types.hs rename to lib/Internal/Types/Dhall.hs index ab12036..9a96a14 100644 --- a/lib/Internal/Types.hs +++ b/lib/Internal/Types/Dhall.hs @@ -4,29 +4,24 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE UndecidableInstances #-} -module Internal.Types where +-- | Types corresponding to the configuration tree (written in Dhall) +module Internal.Types.Dhall where import Control.Monad.Except import Data.Fix (Fix (..), foldFix) import Data.Functor.Foldable (embed) import qualified Data.Functor.Foldable.TH as TH import Database.Persist.Sql hiding (Desc, In, Statement) -import Database.Persist.TH import Dhall hiding (embed, maybe) import Dhall.TH -import Internal.TH (deriveProduct) +import Internal.Types.TH (deriveProduct) import Language.Haskell.TH.Syntax (Lift) import RIO import qualified RIO.Map as M -import qualified RIO.NonEmpty as NE import qualified RIO.Text as T import RIO.Time import Text.Regex.TDFA -------------------------------------------------------------------------------- --- DHALL CONFIG -------------------------------------------------------------------------------- - makeHaskellTypesWith (defaultGenerateOptions {generateToDhallInstance = False, generateFromDhallInstance = False}) [ MultipleConstructors "SqlConfig" "(./dhall/Types.dhall).SqlConfig" @@ -528,270 +523,5 @@ data StatementParser re = StatementParser deriving instance Show (StatementParser T.Text) --------------------------------------------------------------------------------- --- DATABASE MODEL --------------------------------------------------------------------------------- - -share - [mkPersist sqlSettings, mkMigrate "migrateAll"] - [persistLowerCase| -CommitR sql=commits - hash Int - type ConfigType - deriving Show Eq -CurrencyR sql=currencies - symbol T.Text - fullname T.Text - precision Int - deriving Show Eq -TagR sql=tags - symbol T.Text - fullname T.Text - deriving Show Eq -AccountR sql=accounts - name T.Text - fullpath T.Text - desc T.Text - deriving Show Eq -AccountPathR sql=account_paths - parent AccountRId OnDeleteCascade - child AccountRId OnDeleteCascade - depth Int - deriving Show Eq -TransactionR sql=transactions - commit CommitRId OnDeleteCascade - date Day - description T.Text - deriving Show Eq -SplitR sql=splits - transaction TransactionRId OnDeleteCascade - currency CurrencyRId OnDeleteCascade - account AccountRId OnDeleteCascade - memo T.Text - value Rational - deriving Show Eq -TagRelationR sql=tag_relations - split SplitRId OnDeleteCascade - tag TagRId OnDeleteCascade -BudgetLabelR sql=budget_labels - split SplitRId OnDeleteCascade - budgetName T.Text - deriving Show Eq -|] - --------------------------------------------------------------------------------- --- database cache types - -data ConfigHashes = ConfigHashes - { chIncome :: ![Int] - , chExpense :: ![Int] - , chManual :: ![Int] - , chImport :: ![Int] - } - -data ConfigType = CTBudget | CTManual | CTImport - deriving (Eq, Show, Read, Enum) - -instance PersistFieldSql ConfigType where - sqlType _ = SqlString - -instance PersistField ConfigType where - toPersistValue = PersistText . T.pack . show - - -- TODO these error messages *might* be good enough? - fromPersistValue (PersistText v) = - maybe (Left $ "could not parse: " <> v) Right $ readMaybe $ T.unpack v - fromPersistValue _ = Left "wrong type" - -type AccountMap = M.Map AcntID (AccountRId, AcntSign, AcntType) - -type CurrencyMap = M.Map CurID (CurrencyRId, Natural) - -type TagMap = M.Map TagID TagRId - -data DBState = DBState - { kmCurrency :: !CurrencyMap - , kmAccount :: !AccountMap - , kmTag :: !TagMap - , kmBudgetInterval :: !Bounds - , kmStatementInterval :: !Bounds - , kmNewCommits :: ![Int] - , kmOldCommits :: ![Int] - , kmConfigDir :: !FilePath - , kmTagAll :: ![Entity TagR] - , kmAcntPaths :: ![AccountPathR] - , kmAcntsOld :: ![Entity AccountR] - , kmCurrenciesOld :: ![Entity CurrencyR] - } - -type CurrencyM = Reader CurrencyMap - -type KeySplit = Entry AccountRId Rational CurrencyRId TagRId - -type KeyTx = Tx KeySplit - -type TreeR = Tree ([T.Text], AccountRId) - -type Balances = M.Map AccountRId Rational - -type BalanceM = ReaderT (MVar Balances) - -type MonadFinance = MonadReader DBState - -askDBState :: MonadFinance m => (DBState -> a) -> m a -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 - -------------------------------------------------------------------------------- --- misc - -data AcntType - = AssetT - | EquityT - | ExpenseT - | IncomeT - | LiabilityT - deriving (Show, Eq, Ord, Lift, Hashable, Generic, Read, FromDhall) - -atName :: AcntType -> T.Text -atName AssetT = "asset" -atName EquityT = "equity" -atName ExpenseT = "expense" -atName IncomeT = "income" -atName LiabilityT = "liability" - -data AcntPath = AcntPath - { apType :: !AcntType - , apChildren :: ![T.Text] - } - deriving (Eq, Ord, Show, Lift, Hashable, Generic, Read, FromDhall) - -data TxRecord = TxRecord - { trDate :: !Day - , trAmount :: !Rational - , trDesc :: !T.Text - , trOther :: !(M.Map T.Text T.Text) - , trFile :: !FilePath - } - deriving (Show, Eq, Ord) - -type Bounds = (Day, Natural) - -data Keyed a = Keyed - { kKey :: !Int64 - , kVal :: !a - } - deriving (Eq, Show, Functor) - -data Tree a = Branch !a ![Tree a] | Leaf !a deriving (Show) - -data AcntSign = Credit | Debit - deriving (Show) - -sign2Int :: AcntSign -> Int -sign2Int Debit = 1 -sign2Int Credit = 1 - -accountSign :: AcntType -> AcntSign -accountSign AssetT = Debit -accountSign ExpenseT = Debit -accountSign IncomeT = Credit -accountSign LiabilityT = Credit -accountSign EquityT = Credit - -type RawSplit = Entry AcntID (Maybe Rational) CurID TagID - -type BalSplit = Entry AcntID Rational CurID TagID - -type RawTx = Tx RawSplit - -type BalTx = Tx BalSplit - -data MatchRes a = MatchPass !a | MatchFail | MatchSkip - --------------------------------------------------------------------------------- --- exception types - -data BalanceType = TooFewSplits | NotOneBlank deriving (Show) - -data MatchType = MatchNumeric | MatchText deriving (Show) - -data SplitIDType = AcntField | CurField | TagField deriving (Show) - -data LookupSuberr - = SplitIDField !SplitIDType - | SplitValField - | MatchField !MatchType - | DBKey !SplitIDType - deriving (Show) - -data AllocationSuberr - = NoAllocations - | ExceededTotal - | MissingBlank - | TooManyBlanks - deriving (Show) - -data PatternSuberr = ZeroLength | ZeroRepeats deriving (Show) - -data InsertError - = RegexError !T.Text - | MatchValPrecisionError !Natural !Natural - | AccountError !AcntID !(NE.NonEmpty AcntType) - | InsertIOError !T.Text - | ParseError !T.Text - | ConversionError !T.Text - | LookupError !LookupSuberr !T.Text - | BalanceError !BalanceType !CurID ![RawSplit] - | IncomeError !Day !T.Text !Rational - | PatternError !Natural !Natural !(Maybe Natural) !PatternSuberr - | BoundsError !Gregorian !(Maybe Gregorian) - | StatementError ![TxRecord] ![MatchRe] - | PeriodError !Day !Day - deriving (Show) - -newtype InsertException = InsertException [InsertError] - deriving (Show, Semigroup) via [InsertError] - -instance Exception InsertException - -type MonadInsertError = MonadError InsertException - -type InsertExceptT = ExceptT InsertException - -type InsertExcept = InsertExceptT Identity - -data XGregorian = XGregorian - { xgYear :: !Int - , xgMonth :: !Int - , xgDay :: !Int - , xgDayOfWeek :: !Int - } - -type MatchRe = StatementParser (T.Text, Regex) - -type TxOptsRe = TxOpts (T.Text, Regex) - -type FieldMatcherRe = FieldMatcher (T.Text, Regex) - instance Show (StatementParser (T.Text, Regex)) where show = show . fmap fst diff --git a/lib/Internal/Types/Main.hs b/lib/Internal/Types/Main.hs new file mode 100644 index 0000000..94b354f --- /dev/null +++ b/lib/Internal/Types/Main.hs @@ -0,0 +1,226 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | Other types used throughout the program; kept in its own module to prevent +-- circular imports +module Internal.Types.Main + ( module Internal.Types.Main + , module Internal.Types.Dhall + , module Internal.Types.Database + ) +where + +import Control.Monad.Except +import Database.Persist.Sql hiding (Desc, In, Statement) +import Dhall hiding (embed, maybe) +import Internal.Types.Database +import Internal.Types.Dhall +import Language.Haskell.TH.Syntax (Lift) +import RIO +import qualified RIO.Map as M +import qualified RIO.NonEmpty as NE +import qualified RIO.Text as T +import RIO.Time +import Text.Regex.TDFA + +-------------------------------------------------------------------------------- +-- database cache types + +data ConfigHashes = ConfigHashes + { chIncome :: ![Int] + , chExpense :: ![Int] + , chManual :: ![Int] + , chImport :: ![Int] + } + +type AccountMap = M.Map AcntID (AccountRId, AcntSign, AcntType) + +type CurrencyMap = M.Map CurID (CurrencyRId, Natural) + +type TagMap = M.Map TagID TagRId + +data DBState = DBState + { kmCurrency :: !CurrencyMap + , kmAccount :: !AccountMap + , kmTag :: !TagMap + , kmBudgetInterval :: !Bounds + , kmStatementInterval :: !Bounds + , kmNewCommits :: ![Int] + , kmOldCommits :: ![Int] + , kmConfigDir :: !FilePath + , kmTagAll :: ![Entity TagR] + , kmAcntPaths :: ![AccountPathR] + , kmAcntsOld :: ![Entity AccountR] + , kmCurrenciesOld :: ![Entity CurrencyR] + } + +type CurrencyM = Reader CurrencyMap + +type KeySplit = Entry AccountRId Rational CurrencyRId TagRId + +type KeyTx = Tx KeySplit + +type TreeR = Tree ([T.Text], AccountRId) + +type Balances = M.Map AccountRId Rational + +type BalanceM = ReaderT (MVar Balances) + +type MonadFinance = MonadReader DBState + +askDBState :: MonadFinance m => (DBState -> a) -> m a +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 + +------------------------------------------------------------------------------- +-- misc + +data AcntType + = AssetT + | EquityT + | ExpenseT + | IncomeT + | LiabilityT + deriving (Show, Eq, Ord, Lift, Hashable, Generic, Read, FromDhall) + +atName :: AcntType -> T.Text +atName AssetT = "asset" +atName EquityT = "equity" +atName ExpenseT = "expense" +atName IncomeT = "income" +atName LiabilityT = "liability" + +data AcntPath = AcntPath + { apType :: !AcntType + , apChildren :: ![T.Text] + } + deriving (Eq, Ord, Show, Lift, Hashable, Generic, Read, FromDhall) + +data TxRecord = TxRecord + { trDate :: !Day + , trAmount :: !Rational + , trDesc :: !T.Text + , trOther :: !(M.Map T.Text T.Text) + , trFile :: !FilePath + } + deriving (Show, Eq, Ord) + +-- TODO pick a better name for this (something like DayInterval or something) +type Bounds = (Day, Natural) + +data Keyed a = Keyed + { kKey :: !Int64 + , kVal :: !a + } + deriving (Eq, Show, Functor) + +data Tree a = Branch !a ![Tree a] | Leaf !a deriving (Show) + +data AcntSign = Credit | Debit + deriving (Show) + +sign2Int :: AcntSign -> Int +sign2Int Debit = 1 +sign2Int Credit = 1 + +accountSign :: AcntType -> AcntSign +accountSign AssetT = Debit +accountSign ExpenseT = Debit +accountSign IncomeT = Credit +accountSign LiabilityT = Credit +accountSign EquityT = Credit + +type RawSplit = Entry AcntID (Maybe Rational) CurID TagID + +type BalSplit = Entry AcntID Rational CurID TagID + +type RawTx = Tx RawSplit + +type BalTx = Tx BalSplit + +data MatchRes a = MatchPass !a | MatchFail | MatchSkip + +-------------------------------------------------------------------------------- +-- exception types + +data BalanceType = TooFewSplits | NotOneBlank deriving (Show) + +data MatchType = MatchNumeric | MatchText deriving (Show) + +data SplitIDType = AcntField | CurField | TagField deriving (Show) + +data LookupSuberr + = SplitIDField !SplitIDType + | SplitValField + | MatchField !MatchType + | DBKey !SplitIDType + deriving (Show) + +data AllocationSuberr + = NoAllocations + | ExceededTotal + | MissingBlank + | TooManyBlanks + deriving (Show) + +data PatternSuberr = ZeroLength | ZeroRepeats deriving (Show) + +data InsertError + = RegexError !T.Text + | MatchValPrecisionError !Natural !Natural + | AccountError !AcntID !(NE.NonEmpty AcntType) + | InsertIOError !T.Text + | ParseError !T.Text + | ConversionError !T.Text + | LookupError !LookupSuberr !T.Text + | BalanceError !BalanceType !CurID ![RawSplit] + | IncomeError !Day !T.Text !Rational + | PatternError !Natural !Natural !(Maybe Natural) !PatternSuberr + | BoundsError !Gregorian !(Maybe Gregorian) + | StatementError ![TxRecord] ![MatchRe] + | PeriodError !Day !Day + deriving (Show) + +newtype InsertException = InsertException [InsertError] + deriving (Show, Semigroup) via [InsertError] + +instance Exception InsertException + +type MonadInsertError = MonadError InsertException + +type InsertExceptT = ExceptT InsertException + +type InsertExcept = InsertExceptT Identity + +data XGregorian = XGregorian + { xgYear :: !Int + , xgMonth :: !Int + , xgDay :: !Int + , xgDayOfWeek :: !Int + } + +type MatchRe = StatementParser (T.Text, Regex) + +type TxOptsRe = TxOpts (T.Text, Regex) + +type FieldMatcherRe = FieldMatcher (T.Text, Regex) diff --git a/lib/Internal/TH.hs b/lib/Internal/Types/TH.hs similarity index 73% rename from lib/Internal/TH.hs rename to lib/Internal/Types/TH.hs index 51c0ce1..d9b0b26 100644 --- a/lib/Internal/TH.hs +++ b/lib/Internal/Types/TH.hs @@ -1,4 +1,5 @@ -module Internal.TH where +-- | Helper functions so I don't need to write lots of dhall instances +module Internal.Types.TH where import Language.Haskell.TH.Syntax (Dec (..), Q (..), Type (..), mkName) import RIO diff --git a/lib/Internal/Utils.hs b/lib/Internal/Utils.hs index e5723f9..a1d268b 100644 --- a/lib/Internal/Utils.hs +++ b/lib/Internal/Utils.hs @@ -27,15 +27,6 @@ module Internal.Utils , combineErrorIOM3 , collectErrorsIO , mapErrorsIO - -- , leftToMaybe - -- , concatEithers2 - -- , concatEithers3 - -- , concatEither3 - -- , concatEither2 - -- , concatEitherL - -- , concatEithersL - -- , concatEither2M - -- , concatEithers2M , parseRational , showError , unlessLeft_ @@ -51,7 +42,6 @@ module Internal.Utils , sndOf3 , thdOf3 , xGregToDay - -- , plural , compileMatch , compileOptions , dateMatches @@ -66,7 +56,7 @@ import Control.Monad.Except import Control.Monad.Reader import Data.Time.Format.ISO8601 import GHC.Real -import Internal.Types +import Internal.Types.Main import RIO import qualified RIO.List as L import qualified RIO.Map as M From 62b39b61aa62a1bf2f97c38c5ddc09a5649f95b9 Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Mon, 29 May 2023 15:56:15 -0400 Subject: [PATCH 03/15] REF split history and budget --- app/Main.hs | 3 +- budget.cabal | 3 +- lib/Internal/{Insert.hs => Budget.hs} | 783 +++++++++----------------- lib/Internal/Database/Ops.hs | 56 +- lib/Internal/History.hs | 133 +++++ lib/Internal/Types/Main.hs | 33 +- lib/Internal/Utils.hs | 182 +++++- 7 files changed, 603 insertions(+), 590 deletions(-) rename lib/Internal/{Insert.hs => Budget.hs} (59%) create mode 100644 lib/Internal/History.hs diff --git a/app/Main.hs b/app/Main.hs index 8710d96..53579ff 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -8,9 +8,10 @@ import Control.Monad.Logger import Control.Monad.Reader import qualified Data.Text.IO as TI import Database.Persist.Monad +import Internal.Budget import Internal.Config import Internal.Database.Ops -import Internal.Insert +import Internal.History import Internal.Types.Main import Internal.Utils import Options.Applicative diff --git a/budget.cabal b/budget.cabal index e80aa97..f50c6e1 100644 --- a/budget.cabal +++ b/budget.cabal @@ -25,9 +25,10 @@ source-repository head library exposed-modules: + Internal.Budget Internal.Config Internal.Database.Ops - Internal.Insert + Internal.History Internal.Statement Internal.Types.Database Internal.Types.Dhall diff --git a/lib/Internal/Insert.hs b/lib/Internal/Budget.hs similarity index 59% rename from lib/Internal/Insert.hs rename to lib/Internal/Budget.hs index bf4a6f6..aabe2db 100644 --- a/lib/Internal/Insert.hs +++ b/lib/Internal/Budget.hs @@ -1,16 +1,8 @@ -module Internal.Insert - ( insertBudget - , splitHistory - , insertHistTransfer - , readHistStmt - , insertHistStmt - ) -where +module Internal.Budget (insertBudget) where import Control.Monad.Except -import Data.Hashable import Database.Persist.Monad -import Internal.Statement +import Internal.Database.Ops import Internal.Types.Main import Internal.Utils import RIO hiding (to) @@ -20,132 +12,6 @@ import qualified RIO.NonEmpty as NE import qualified RIO.Text as T import RIO.Time --------------------------------------------------------------------------------- --- intervals - -expandDatePat :: Bounds -> DatePat -> InsertExcept [Day] -expandDatePat b (Cron cp) = expandCronPat b cp -expandDatePat i (Mod mp) = return $ expandModPat mp i - -expandModPat :: ModPat -> Bounds -> [Day] -expandModPat ModPat {mpStart = s, mpBy = b, mpUnit = u, mpRepeats = r} bs = - takeWhile (<= upper) $ - (`addFun` start) . (* b') - <$> maybe id (take . fromIntegral) r [0 ..] - where - (lower, upper) = expandBounds bs - start = maybe lower fromGregorian' s - b' = fromIntegral b - addFun = case u of - Day -> addDays - Week -> addDays . (* 7) - Month -> addGregorianMonthsClip - Year -> addGregorianYearsClip - -expandCronPat :: Bounds -> CronPat -> InsertExcept [Day] -expandCronPat b CronPat {cpYear, cpMonth, cpDay, cpWeekly} = - combineError3 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 cpYear of - Nothing -> return [yb0 .. yb1] - Just pat -> do - ys <- expandMDYPat (fromIntegral yb0) (fromIntegral yb1) pat - return $ dropWhile (< yb0) $ fromIntegral <$> ys - mRes = expandMD 12 cpMonth - dRes = expandMD 31 cpDay - (s, e) = expandBounds b - (yb0, mb0, db0) = toGregorian s - (yb1, mb1, db1) = toGregorian $ addDays (-1) e - expandMD lim = - fmap (fromIntegral <$>) - . maybe (return [1 .. lim]) (expandMDYPat 1 lim) - expandW (OnDay x) = [fromEnum x] - expandW (OnDays xs) = fromEnum <$> xs - ws = maybe [] expandW cpWeekly - validWeekday = if null ws then const True else \day -> dayToWeekday day `elem` ws - toDay (y, leap) m d - | m == 2 && (not leap && d > 28 || leap && d > 29) = Nothing - | m `elem` [4, 6, 9, 11] && d > 30 = Nothing - | otherwise = Just $ fromGregorian y m d - -expandMDYPat :: Natural -> Natural -> MDYPat -> InsertExcept [Natural] -expandMDYPat lower upper (Single x) = return [x | lower <= x && x <= upper] -expandMDYPat lower upper (Multi xs) = return $ dropWhile (<= lower) $ takeWhile (<= upper) xs -expandMDYPat lower upper (After x) = return [max lower x .. upper] -expandMDYPat lower upper (Before x) = return [lower .. min upper x] -expandMDYPat lower upper (Between x y) = return [max lower x .. min upper y] -expandMDYPat lower upper (Repeat RepeatPat {rpStart = s, rpBy = b, rpRepeats = r}) - | b < 1 = throwError $ InsertException [PatternError s b r ZeroLength] - | otherwise = do - k <- limit r - return $ dropWhile (<= lower) $ takeWhile (<= k) [s + i * b | i <- [0 ..]] - where - limit Nothing = return upper - limit (Just n) - -- this guard not only produces the error for the user but also protects - -- from an underflow below it - | n < 1 = throwError $ InsertException [PatternError s b r ZeroRepeats] - | otherwise = return $ min (s + b * (n - 1)) upper - -dayToWeekday :: Day -> Int -dayToWeekday (ModifiedJulianDay d) = mod (fromIntegral d + 2) 7 - -askDays - :: (MonadFinance m, MonadInsertError m) - => DatePat - -> Maybe Interval - -> m [Day] -askDays dp i = do - globalBounds <- askDBState kmBudgetInterval - case i of - Just i' -> do - localBounds <- liftExcept $ resolveBounds i' - let bounds = intersectBounds globalBounds localBounds - maybe (return []) expand bounds - Nothing -> expand globalBounds - where - expand bs = liftExcept $ expandDatePat bs dp - -withDates - :: (MonadSqlQuery m, MonadFinance m, MonadInsertError m) - => DatePat - -> (Day -> m a) - -> m [a] -withDates dp f = do - bounds <- askDBState kmBudgetInterval - days <- liftExcept $ expandDatePat bounds dp - combineErrors $ fmap f days - -foldDays - :: MonadInsertError m - => (Day -> Day -> m a) - -> Day - -> [Day] - -> m [a] -foldDays f start days = - combineErrors $ - snd $ - L.mapAccumL (\prevDay day -> (day, f prevDay day)) start days - --------------------------------------------------------------------------------- --- budget - --- each budget (designated at the top level by a 'name') is processed in the --- following steps --- 1. expand all transactions given the desired date range and date patterns for --- each directive in the budget --- 2. sort all transactions by date --- 3. propagate all balances forward, and while doing so assign values to each --- transaction (some of which depend on the 'current' balance of the --- target account) --- 4. assign shadow transactions (TODO) --- 5. insert all transactions - insertBudget :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m) => Budget @@ -175,75 +41,6 @@ insertBudget post_ = sortAllos bgtPosttax sortAllos = liftExcept . combineErrors . fmap sortAllo -type BoundAllocation = Allocation Bounds - -type IntAllocations = - ( [BoundAllocation PretaxValue] - , [BoundAllocation TaxValue] - , [BoundAllocation PosttaxValue] - ) - --- TODO this should actually error if there is no ultimate end date? -sortAllo :: MultiAllocation v -> InsertExcept (BoundAllocation v) -sortAllo a@Allocation {alloAmts = as} = do - bs <- foldBounds [] $ L.sortOn amtWhen as - return $ a {alloAmts = reverse bs} - where - foldBounds acc [] = return acc - foldBounds acc (x : xs) = do - let start = amtWhen x - res <- case xs of - [] -> resolveBounds start - (y : _) -> resolveBounds_ (intStart $ amtWhen y) start - foldBounds (x {amtWhen = res} : acc) xs - --- TODO this is going to be O(n*m), which might be a problem? -addShadowTransfers - :: CurrencyMap - -> [ShadowTransfer] - -> [UnbalancedTransfer] - -> InsertExcept [UnbalancedTransfer] -addShadowTransfers cm ms txs = - fmap catMaybes $ - combineErrors $ - fmap (uncurry (fromShadow cm)) $ - [(t, m) | t <- txs, m <- ms] - -fromShadow - :: CurrencyMap - -> UnbalancedTransfer - -> ShadowTransfer - -> InsertExcept (Maybe UnbalancedTransfer) -fromShadow cm tx t@ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stType} = do - res <- shadowMatches (stMatch t) tx - v <- roundPrecisionCur (initialCurrency stCurrency) cm stRatio - return $ - if not res - then Nothing - else - Just $ - FlatTransfer - { ftMeta = ftMeta tx - , ftWhen = ftWhen tx - , ftCur = stCurrency - , ftFrom = stFrom - , ftTo = stTo - , ftValue = UnbalancedValue stType $ v * cvValue (ftValue tx) - , ftDesc = stDesc - } - -shadowMatches :: TransferMatcher -> UnbalancedTransfer -> InsertExcept Bool -shadowMatches TransferMatcher {tmFrom, tmTo, tmDate, tmVal} tx = do - valRes <- valMatches tmVal $ cvValue $ ftValue tx - return $ - memberMaybe (taAcnt $ ftFrom tx) tmFrom - && memberMaybe (taAcnt $ ftTo tx) tmTo - && maybe True (`dateMatches` ftWhen tx) tmDate - && valRes - where - memberMaybe x AcntSet {asList, asInclude} = - (if asInclude then id else not) $ x `elem` asList - balanceTransfers :: [UnbalancedTransfer] -> [BalancedTransfer] balanceTransfers = snd . L.mapAccumR go M.empty . reverse . L.sortOn ftWhen where @@ -259,35 +56,71 @@ balanceTransfers = snd . L.mapAccumR go M.empty . reverse . L.sortOn ftWhen amtToMove bal BTPercent x = -(x / 100 * bal) amtToMove bal BTTarget x = x - bal +-- TODO this seems too general for this module mapAdd_ :: (Ord k, Num v) => k -> v -> M.Map k v -> M.Map k v mapAdd_ k v = M.alter (maybe (Just v) (Just . (+ v))) k -data BudgetMeta = BudgetMeta - { bmCommit :: !CommitRId - , bmName :: !T.Text - } - deriving (Show) +insertBudgetTx + :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m) + => BalancedTransfer + -> m () +insertBudgetTx FlatTransfer {ftFrom, ftTo, ftMeta, ftCur, ftValue, ftDesc, ftWhen} = do + ((sFrom, sTo), exchange) <- entryPair ftFrom ftTo ftCur ftValue + insertPair sFrom sTo + forM_ exchange $ uncurry insertPair + where + insertPair from to = do + k <- insert $ TransactionR (bmCommit ftMeta) ftWhen ftDesc + insertBudgetLabel k from + insertBudgetLabel k to + insertBudgetLabel k split = do + sk <- insertSplit k split + insert_ $ BudgetLabelR sk $ bmName ftMeta -data FlatTransfer v = FlatTransfer - { ftFrom :: !TaggedAcnt - , ftTo :: !TaggedAcnt - , ftValue :: !v - , ftWhen :: !Day - , ftDesc :: !T.Text - , ftMeta :: !BudgetMeta - , ftCur :: !BudgetCurrency - } - deriving (Show) +entryPair + :: (MonadInsertError m, MonadFinance m) + => TaggedAcnt + -> TaggedAcnt + -> BudgetCurrency + -> Rational + -> m (SplitPair, Maybe SplitPair) +entryPair from to cur val = case cur of + NoX curid -> (,Nothing) <$> pair curid from to val + X Exchange {xFromCur, xToCur, xAcnt, xRate} -> do + let middle = TaggedAcnt xAcnt [] + let res1 = pair xFromCur from middle val + let res2 = pair xToCur middle to (val * roundPrecision 3 xRate) + combineError res1 res2 $ \a b -> (a, Just b) + where + pair curid from_ to_ v = do + let s1 = split curid from_ (-v) + let s2 = split curid to_ v + combineError s1 s2 (,) + split c TaggedAcnt {taAcnt, taTags} v = + resolveSplit $ + Entry + { eAcnt = taAcnt + , eValue = v + , eComment = "" + , eCurrency = c + , eTags = taTags + } -data UnbalancedValue = UnbalancedValue - { cvType :: !BudgetTransferType - , cvValue :: !Rational - } - deriving (Show) +sortAllo :: MultiAllocation v -> InsertExcept (DaySpanAllocation v) +sortAllo a@Allocation {alloAmts = as} = do + bs <- foldSpan [] $ L.sortOn amtWhen as + return $ a {alloAmts = reverse bs} + where + foldSpan acc [] = return acc + foldSpan acc (x : xs) = do + let start = amtWhen x + res <- case xs of + [] -> resolveDaySpan start + (y : _) -> resolveDaySpan_ (intStart $ amtWhen y) start + foldSpan (x {amtWhen = res} : acc) xs -type UnbalancedTransfer = FlatTransfer UnbalancedValue - -type BalancedTransfer = FlatTransfer Rational +-------------------------------------------------------------------------------- +-- Income insertIncome :: (MonadInsertError m, MonadFinance m) @@ -359,8 +192,6 @@ insertIncome then throwError $ InsertException [IncomeError day name balance] else return (bal : fmap (allo2Trans meta day incFrom) (pre ++ tax ++ post)) -type PeriodScaler = Natural -> Double -> Double - -- TODO we probably don't need to check for 1/0 each time periodScaler :: PeriodType @@ -398,21 +229,58 @@ workingDays wds start end wds' = L.sort $ (\x -> diff (fromWeekday x) startDay) <$> L.nub wds diff a b = fromIntegral $ mod (fromEnum a - fromEnum b) 7 -allocatePre - :: Natural - -> Rational - -> [FlatAllocation PretaxValue] - -> (M.Map T.Text Rational, [FlatAllocation Rational]) -allocatePre precision gross = L.mapAccumR go M.empty +foldDays + :: MonadInsertError m + => (Day -> Day -> m a) + -> Day + -> [Day] + -> m [a] +foldDays f start days = + combineErrors $ + snd $ + L.mapAccumL (\prevDay day -> (day, f prevDay day)) start days + +checkAcntType + :: (MonadInsertError m, MonadFinance m) + => AcntType + -> AcntID + -> m AcntID +checkAcntType t = checkAcntTypes (t :| []) + +checkAcntTypes + :: (MonadInsertError m, MonadFinance m) + => NE.NonEmpty AcntType + -> AcntID + -> m AcntID +checkAcntTypes ts i = go =<< lookupAccountType i where - go m f@FlatAllocation {faValue} = - let c = preCategory faValue - p = preValue faValue - v = - if prePercent faValue - then (roundPrecision 3 p / 100) * gross - else roundPrecision precision p - in (mapAdd_ c v m, f {faValue = v}) + go t + | t `L.elem` ts = return i + | otherwise = throwError $ InsertException [AccountError i ts] + +flattenAllo :: SingleAllocation v -> [FlatAllocation v] +flattenAllo Allocation {alloAmts, alloCur, alloTo} = fmap go alloAmts + where + go Amount {amtValue, amtDesc} = + FlatAllocation + { faCur = NoX alloCur + , faTo = alloTo + , faValue = amtValue + , faDesc = amtDesc + } + +-- ASSUME allocations are sorted +selectAllos :: Day -> DaySpanAllocation v -> [FlatAllocation v] +selectAllos day Allocation {alloAmts, alloCur, alloTo} = + go <$> filter ((`inDaySpan` day) . amtWhen) alloAmts + where + go Amount {amtValue, amtDesc} = + FlatAllocation + { faCur = NoX alloCur + , faTo = alloTo + , faValue = amtValue + , faDesc = amtDesc + } allo2Trans :: BudgetMeta @@ -431,6 +299,22 @@ allo2Trans meta day from FlatAllocation {faValue, faTo, faDesc, faCur} = , ftDesc = faDesc } +allocatePre + :: Natural + -> Rational + -> [FlatAllocation PretaxValue] + -> (M.Map T.Text Rational, [FlatAllocation Rational]) +allocatePre precision gross = L.mapAccumR go M.empty + where + go m f@FlatAllocation {faValue} = + let c = preCategory faValue + p = preValue faValue + v = + if prePercent faValue + then (roundPrecision 3 p / 100) * gross + else roundPrecision precision p + in (mapAdd_ c v m, f {faValue = v}) + allocateTax :: Natural -> Rational @@ -451,19 +335,6 @@ allocateTax precision gross preDeds f = fmap (fmap go) let taxDed = roundPrecision precision $ f precision tpDeductible in foldBracket f precision (agi - taxDed) tpBrackets -allocatePost - :: Natural - -> Rational - -> [FlatAllocation PosttaxValue] - -> [FlatAllocation Rational] -allocatePost precision aftertax = fmap (fmap go) - where - go PosttaxValue {postValue, postPercent} = - let v = postValue - in if postPercent - then aftertax * roundPrecision 3 v / 100 - else roundPrecision precision v - -- | Compute effective tax percentage of a bracket -- The algorithm can be thought of in three phases: -- 1. Find the highest tax bracket by looping backward until the AGI is less @@ -483,37 +354,21 @@ foldBracket f precision agi bs = fst $ foldr go (0, agi) $ L.sortOn tbLowerLimit p = roundPrecision 3 tbPercent / 100 in if remain >= l then (acc + p * (remain - l), l) else a -data FlatAllocation v = FlatAllocation - { faValue :: !v - , faDesc :: !T.Text - , faTo :: !TaggedAcnt - , faCur :: !BudgetCurrency - } - deriving (Functor, Show) - -flattenAllo :: SingleAllocation v -> [FlatAllocation v] -flattenAllo Allocation {alloAmts, alloCur, alloTo} = fmap go alloAmts +allocatePost + :: Natural + -> Rational + -> [FlatAllocation PosttaxValue] + -> [FlatAllocation Rational] +allocatePost precision aftertax = fmap (fmap go) where - go Amount {amtValue, amtDesc} = - FlatAllocation - { faCur = NoX alloCur - , faTo = alloTo - , faValue = amtValue - , faDesc = amtDesc - } + go PosttaxValue {postValue, postPercent} = + let v = postValue + in if postPercent + then aftertax * roundPrecision 3 v / 100 + else roundPrecision precision v --- ASSUME allocations are sorted -selectAllos :: Day -> BoundAllocation v -> [FlatAllocation v] -selectAllos day Allocation {alloAmts, alloCur, alloTo} = - go <$> filter ((`inBounds` day) . amtWhen) alloAmts - where - go Amount {amtValue, amtDesc} = - FlatAllocation - { faCur = NoX alloCur - , faTo = alloTo - , faValue = amtValue - , faDesc = amtDesc - } +-------------------------------------------------------------------------------- +-- Transfer expandTransfers :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m) @@ -530,12 +385,8 @@ expandTransfers key name localInterval ts = do case localInterval of Nothing -> return txs Just i -> do - bounds <- liftExcept $ resolveBounds i - return $ filter (inBounds bounds . ftWhen) txs - -initialCurrency :: BudgetCurrency -> CurID -initialCurrency (NoX c) = c -initialCurrency (X Exchange {xFromCur = c}) = c + bounds <- liftExcept $ resolveDaySpan i + return $ filter (inDaySpan bounds . ftWhen) txs expandTransfer :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m) @@ -567,248 +418,116 @@ expandTransfer key name Transfer {transAmounts, transTo, transCurrency, transFro , ftDesc = desc } -insertBudgetTx :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m) => BalancedTransfer -> m () -insertBudgetTx FlatTransfer {ftFrom, ftTo, ftMeta, ftCur, ftValue, ftDesc, ftWhen} = do - ((sFrom, sTo), exchange) <- splitPair ftFrom ftTo ftCur ftValue - insertPair sFrom sTo - forM_ exchange $ uncurry insertPair +withDates + :: (MonadSqlQuery m, MonadFinance m, MonadInsertError m) + => DatePat + -> (Day -> m a) + -> m [a] +withDates dp f = do + bounds <- askDBState kmBudgetInterval + days <- liftExcept $ expandDatePat bounds dp + combineErrors $ fmap f days + +-------------------------------------------------------------------------------- +-- shadow transfers + +-- TODO this is going to be O(n*m), which might be a problem? +addShadowTransfers + :: CurrencyMap + -> [ShadowTransfer] + -> [UnbalancedTransfer] + -> InsertExcept [UnbalancedTransfer] +addShadowTransfers cm ms txs = + fmap catMaybes $ + combineErrors $ + fmap (uncurry (fromShadow cm)) $ + [(t, m) | t <- txs, m <- ms] + +fromShadow + :: CurrencyMap + -> UnbalancedTransfer + -> ShadowTransfer + -> InsertExcept (Maybe UnbalancedTransfer) +fromShadow cm tx t@ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stType} = do + res <- shadowMatches (stMatch t) tx + v <- roundPrecisionCur (initialCurrency stCurrency) cm stRatio + return $ + if not res + then Nothing + else + Just $ + FlatTransfer + { ftMeta = ftMeta tx + , ftWhen = ftWhen tx + , ftCur = stCurrency + , ftFrom = stFrom + , ftTo = stTo + , ftValue = UnbalancedValue stType $ v * cvValue (ftValue tx) + , ftDesc = stDesc + } + +shadowMatches :: TransferMatcher -> UnbalancedTransfer -> InsertExcept Bool +shadowMatches TransferMatcher {tmFrom, tmTo, tmDate, tmVal} tx = do + valRes <- valMatches tmVal $ cvValue $ ftValue tx + return $ + memberMaybe (taAcnt $ ftFrom tx) tmFrom + && memberMaybe (taAcnt $ ftTo tx) tmTo + && maybe True (`dateMatches` ftWhen tx) tmDate + && valRes where - insertPair from to = do - k <- insert $ TransactionR (bmCommit ftMeta) ftWhen ftDesc - insertBudgetLabel k from - insertBudgetLabel k to - insertBudgetLabel k split = do - sk <- insertSplit k split - insert_ $ BudgetLabelR sk $ bmName ftMeta + memberMaybe x AcntSet {asList, asInclude} = + (if asInclude then id else not) $ x `elem` asList + +-------------------------------------------------------------------------------- +-- random + +initialCurrency :: BudgetCurrency -> CurID +initialCurrency (NoX c) = c +initialCurrency (X Exchange {xFromCur = c}) = c + +data UnbalancedValue = UnbalancedValue + { cvType :: !BudgetTransferType + , cvValue :: !Rational + } + deriving (Show) + +type UnbalancedTransfer = FlatTransfer UnbalancedValue + +type BalancedTransfer = FlatTransfer Rational + +data FlatTransfer v = FlatTransfer + { ftFrom :: !TaggedAcnt + , ftTo :: !TaggedAcnt + , ftValue :: !v + , ftWhen :: !Day + , ftDesc :: !T.Text + , ftMeta :: !BudgetMeta + , ftCur :: !BudgetCurrency + } + deriving (Show) + +data BudgetMeta = BudgetMeta + { bmCommit :: !CommitRId + , bmName :: !T.Text + } + deriving (Show) + +type IntAllocations = + ( [DaySpanAllocation PretaxValue] + , [DaySpanAllocation TaxValue] + , [DaySpanAllocation PosttaxValue] + ) + +type DaySpanAllocation = Allocation DaySpan type SplitPair = (KeySplit, KeySplit) -splitPair - :: (MonadInsertError m, MonadFinance m) - => TaggedAcnt - -> TaggedAcnt - -> BudgetCurrency - -> Rational - -> m (SplitPair, Maybe SplitPair) -splitPair from to cur val = case cur of - NoX curid -> (,Nothing) <$> pair curid from to val - X Exchange {xFromCur, xToCur, xAcnt, xRate} -> do - let middle = TaggedAcnt xAcnt [] - let res1 = pair xFromCur from middle val - let res2 = pair xToCur middle to (val * roundPrecision 3 xRate) - combineError res1 res2 $ \a b -> (a, Just b) - where - pair curid from_ to_ v = do - let s1 = split curid from_ (-v) - let s2 = split curid to_ v - combineError s1 s2 (,) - split c TaggedAcnt {taAcnt, taTags} v = - resolveSplit $ - Entry - { eAcnt = taAcnt - , eValue = v - , eComment = "" - , eCurrency = c - , eTags = taTags - } +type PeriodScaler = Natural -> Double -> Double -checkAcntType - :: (MonadInsertError m, MonadFinance m) - => AcntType - -> AcntID - -> m AcntID -checkAcntType t = checkAcntTypes (t :| []) - -checkAcntTypes - :: (MonadInsertError m, MonadFinance m) - => NE.NonEmpty AcntType - -> AcntID - -> m AcntID -checkAcntTypes ts i = go =<< lookupAccountType i - where - go t - | t `L.elem` ts = return i - | otherwise = throwError $ InsertException [AccountError i ts] - --------------------------------------------------------------------------------- --- statements - -splitHistory :: [History] -> ([HistTransfer], [Statement]) -splitHistory = partitionEithers . fmap go - where - go (HistTransfer x) = Left x - go (HistStatement x) = Right x - --- insertStatement --- :: (MonadUnliftIO m, MonadSqlQuery m, MonadFinance m) --- => History --- -> m () --- insertStatement (HistTransfer m) = liftIOExceptT $ insertManual m --- insertStatement (HistStatement i) = insertImport i - -insertHistTransfer - :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m) - => HistTransfer - -> m () -insertHistTransfer - m@Transfer - { transFrom = from - , transTo = to - , transCurrency = u - , transAmounts = amts - } = do - whenHash CTManual m () $ \c -> do - bounds <- askDBState kmStatementInterval - let precRes = lookupCurrencyPrec u - let go Amount {amtWhen, amtValue, amtDesc} = do - let dayRes = liftExcept $ expandDatePat bounds amtWhen - (days, precision) <- combineError dayRes precRes (,) - let tx day = txPair day from to u (roundPrecision precision amtValue) amtDesc - keys <- combineErrors $ fmap tx days - mapM_ (insertTx c) keys - void $ combineErrors $ fmap go amts - -readHistStmt :: (MonadUnliftIO m, MonadFinance m) => Statement -> m (Maybe (CommitR, [KeyTx])) -readHistStmt i = whenHash_ CTImport i $ do - bs <- readImport i - bounds <- askDBState kmStatementInterval - liftIOExceptT $ mapErrors resolveTx $ filter (inBounds bounds . txDate) bs - -insertHistStmt :: (MonadSqlQuery m) => CommitR -> [KeyTx] -> m () -insertHistStmt c ks = do - ck <- insert c - mapM_ (insertTx ck) ks - --- insertImport --- :: (MonadUnliftIO m, MonadSqlQuery m, MonadFinance m) --- => Statement --- -> m () --- 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 --- bs <- readImport i --- bounds <- expandBounds <$> askDBState kmStatementInterval --- keys <- liftIOExceptT $ mapErrors resolveTx $ filter (inBounds bounds . txDate) bs --- mapM_ (insertTx c) keys - --------------------------------------------------------------------------------- --- low-level transaction stuff - --- TODO tags here? -txPair - :: (MonadInsertError m, MonadFinance m) - => Day - -> AcntID - -> AcntID - -> CurID - -> Rational - -> T.Text - -> m KeyTx -txPair day from to cur val desc = resolveTx tx - where - split a v = - Entry - { eAcnt = a - , eValue = v - , eComment = "" - , eCurrency = cur - , eTags = [] - } - tx = - Tx - { txDescr = desc - , txDate = day - , txSplits = [split from (-val), split to val] - } - -resolveTx :: (MonadInsertError m, MonadFinance m) => BalTx -> m KeyTx -resolveTx t@Tx {txSplits = ss} = - fmap (\kss -> t {txSplits = kss}) $ - combineErrors $ - fmap resolveSplit ss - -resolveSplit :: (MonadInsertError m, MonadFinance m) => BalSplit -> m KeySplit -resolveSplit s@Entry {eAcnt, eCurrency, eValue, eTags} = do - let aRes = lookupAccountKey eAcnt - let cRes = lookupCurrencyKey eCurrency - let sRes = lookupAccountSign eAcnt - let tagRes = combineErrors $ fmap lookupTag eTags - -- TODO correct sign here? - -- TODO lenses would be nice here - combineError (combineError3 aRes cRes sRes (,,)) tagRes $ - \(aid, cid, sign) tags -> - s - { eAcnt = aid - , eCurrency = cid - , eValue = eValue * fromIntegral (sign2Int sign) - , eTags = tags - } - -insertTx :: MonadSqlQuery m => CommitRId -> KeyTx -> m () -insertTx c Tx {txDate = d, txDescr = e, txSplits = ss} = do - k <- insert $ TransactionR c d e - mapM_ (insertSplit k) ss - -insertSplit :: MonadSqlQuery m => TransactionRId -> KeySplit -> m SplitRId -insertSplit t Entry {eAcnt, eCurrency, eValue, eComment, eTags} = do - k <- insert $ SplitR t eCurrency eAcnt eComment eValue - mapM_ (insert_ . TagRelationR k) eTags - return k - -lookupAccount :: (MonadInsertError m, MonadFinance m) => AcntID -> m (AccountRId, AcntSign, AcntType) -lookupAccount = lookupFinance AcntField kmAccount - -lookupAccountKey :: (MonadInsertError m, MonadFinance m) => AcntID -> m AccountRId -lookupAccountKey = fmap fstOf3 . lookupAccount - -lookupAccountSign :: (MonadInsertError m, MonadFinance m) => AcntID -> m AcntSign -lookupAccountSign = fmap sndOf3 . lookupAccount - -lookupAccountType :: (MonadInsertError m, MonadFinance m) => AcntID -> m AcntType -lookupAccountType = fmap thdOf3 . lookupAccount - -lookupCurrency :: (MonadInsertError m, MonadFinance m) => T.Text -> m (CurrencyRId, Natural) -lookupCurrency = lookupFinance CurField kmCurrency - -lookupCurrencyKey :: (MonadInsertError m, MonadFinance m) => AcntID -> m CurrencyRId -lookupCurrencyKey = fmap fst . lookupCurrency - -lookupCurrencyPrec :: (MonadInsertError m, MonadFinance m) => AcntID -> m Natural -lookupCurrencyPrec = fmap snd . lookupCurrency - -lookupTag :: (MonadInsertError m, MonadFinance m) => TagID -> m TagRId -lookupTag = lookupFinance TagField kmTag - -lookupFinance - :: (MonadInsertError m, MonadFinance m) - => SplitIDType - -> (DBState -> M.Map T.Text a) - -> T.Text - -> m a -lookupFinance t f c = (liftExcept . lookupErr (DBKey t) c) =<< askDBState f - --- TODO this hashes twice (not that it really matters) - -whenHash - :: (Hashable a, MonadFinance m, MonadSqlQuery m) - => ConfigType - -> a - -> b - -> (CommitRId -> m b) - -> m b -whenHash t o def f = do - let h = hash o - hs <- askDBState kmNewCommits - if h `elem` hs then f =<< insert (CommitR h t) else return def - -whenHash_ - :: (Hashable a, MonadFinance m) - => ConfigType - -> a - -> m b - -> m (Maybe (CommitR, b)) -whenHash_ t o f = do - let h = hash o - let c = CommitR h t - hs <- askDBState kmNewCommits - if h `elem` hs then Just . (c,) <$> f else return Nothing +data FlatAllocation v = FlatAllocation + { faValue :: !v + , faDesc :: !T.Text + , faTo :: !TaggedAcnt + , faCur :: !BudgetCurrency + } + deriving (Functor, Show) diff --git a/lib/Internal/Database/Ops.hs b/lib/Internal/Database/Ops.hs index 0e6acef..9676269 100644 --- a/lib/Internal/Database/Ops.hs +++ b/lib/Internal/Database/Ops.hs @@ -8,6 +8,10 @@ module Internal.Database.Ops , flattenAcntRoot , paths2IDs , mkPool + , whenHash + , whenHash_ + , insertSplit + , resolveSplit ) where @@ -24,6 +28,7 @@ import Database.Persist.Sqlite hiding , deleteWhere , insert , insertKey + , insert_ , runMigration , (==.) , (||.) @@ -319,8 +324,8 @@ getDBState c = do , kmCurrenciesOld = cs } where - bi = liftExcept $ resolveBounds $ budgetInterval $ global c - si = liftExcept $ resolveBounds $ statementInterval $ global c + bi = liftExcept $ resolveDaySpan $ budgetInterval $ global c + si = liftExcept $ resolveDaySpan $ statementInterval $ global c (acnts, paths, am) = indexAcntRoot $ accounts c cs = currency2Record <$> currencies c ts = toRecord <$> tags c @@ -371,3 +376,50 @@ deleteE q = unsafeLiftSql "esqueleto-delete" (E.delete q) selectE :: (MonadSqlQuery m, SqlSelect a r) => E.SqlQuery a -> m [r] selectE q = unsafeLiftSql "esqueleto-select" (E.select q) + +whenHash + :: (Hashable a, MonadFinance m, MonadSqlQuery m) + => ConfigType + -> a + -> b + -> (CommitRId -> m b) + -> m b +whenHash t o def f = do + let h = hash o + hs <- askDBState kmNewCommits + if h `elem` hs then f =<< insert (CommitR h t) else return def + +whenHash_ + :: (Hashable a, MonadFinance m) + => ConfigType + -> a + -> m b + -> m (Maybe (CommitR, b)) +whenHash_ t o f = do + let h = hash o + let c = CommitR h t + hs <- askDBState kmNewCommits + if h `elem` hs then Just . (c,) <$> f else return Nothing + +insertSplit :: MonadSqlQuery m => TransactionRId -> KeySplit -> m SplitRId +insertSplit t Entry {eAcnt, eCurrency, eValue, eComment, eTags} = do + k <- insert $ SplitR t eCurrency eAcnt eComment eValue + mapM_ (insert_ . TagRelationR k) eTags + return k + +resolveSplit :: (MonadInsertError m, MonadFinance m) => BalSplit -> m KeySplit +resolveSplit s@Entry {eAcnt, eCurrency, eValue, eTags} = do + let aRes = lookupAccountKey eAcnt + let cRes = lookupCurrencyKey eCurrency + let sRes = lookupAccountSign eAcnt + let tagRes = combineErrors $ fmap lookupTag eTags + -- TODO correct sign here? + -- TODO lenses would be nice here + combineError (combineError3 aRes cRes sRes (,,)) tagRes $ + \(aid, cid, sign) tags -> + s + { eAcnt = aid + , eCurrency = cid + , eValue = eValue * fromIntegral (sign2Int sign) + , eTags = tags + } diff --git a/lib/Internal/History.hs b/lib/Internal/History.hs new file mode 100644 index 0000000..92284bb --- /dev/null +++ b/lib/Internal/History.hs @@ -0,0 +1,133 @@ +module Internal.History + ( splitHistory + , insertHistTransfer + , readHistStmt + , insertHistStmt + ) +where + +import Control.Monad.Except +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.Text as T +import RIO.Time + +-------------------------------------------------------------------------------- +-- budget + +-- each budget (designated at the top level by a 'name') is processed in the +-- following steps +-- 1. expand all transactions given the desired date range and date patterns for +-- each directive in the budget +-- 2. sort all transactions by date +-- 3. propagate all balances forward, and while doing so assign values to each +-- transaction (some of which depend on the 'current' balance of the +-- target account) +-- 4. assign shadow transactions (TODO) +-- 5. insert all transactions + +-------------------------------------------------------------------------------- +-- statements + +splitHistory :: [History] -> ([HistTransfer], [Statement]) +splitHistory = partitionEithers . fmap go + where + go (HistTransfer x) = Left x + go (HistStatement x) = Right x + +-- insertStatement +-- :: (MonadUnliftIO m, MonadSqlQuery m, MonadFinance m) +-- => History +-- -> m () +-- insertStatement (HistTransfer m) = liftIOExceptT $ insertManual m +-- insertStatement (HistStatement i) = insertImport i + +insertHistTransfer + :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m) + => HistTransfer + -> m () +insertHistTransfer + m@Transfer + { transFrom = from + , transTo = to + , transCurrency = u + , transAmounts = amts + } = do + whenHash CTManual m () $ \c -> do + bounds <- askDBState kmStatementInterval + let precRes = lookupCurrencyPrec u + let go Amount {amtWhen, amtValue, amtDesc} = do + let dayRes = liftExcept $ expandDatePat bounds amtWhen + (days, precision) <- combineError dayRes precRes (,) + let tx day = txPair day from to u (roundPrecision precision amtValue) amtDesc + keys <- combineErrors $ fmap tx days + mapM_ (insertTx c) keys + void $ combineErrors $ fmap go amts + +readHistStmt :: (MonadUnliftIO m, MonadFinance m) => Statement -> m (Maybe (CommitR, [KeyTx])) +readHistStmt i = whenHash_ CTImport i $ do + bs <- readImport i + bounds <- askDBState kmStatementInterval + liftIOExceptT $ mapErrors resolveTx $ filter (inDaySpan bounds . txDate) bs + +insertHistStmt :: (MonadSqlQuery m) => CommitR -> [KeyTx] -> m () +insertHistStmt c ks = do + ck <- insert c + mapM_ (insertTx ck) ks + +-- insertImport +-- :: (MonadUnliftIO m, MonadSqlQuery m, MonadFinance m) +-- => Statement +-- -> m () +-- 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 +-- bs <- readImport i +-- bounds <- expandBounds <$> askDBState kmStatementInterval +-- keys <- liftIOExceptT $ mapErrors resolveTx $ filter (inBounds bounds . txDate) bs +-- mapM_ (insertTx c) keys + +-------------------------------------------------------------------------------- +-- low-level transaction stuff + +-- TODO tags here? +txPair + :: (MonadInsertError m, MonadFinance m) + => Day + -> AcntID + -> AcntID + -> CurID + -> Rational + -> T.Text + -> m KeyTx +txPair day from to cur val desc = resolveTx tx + where + split a v = + Entry + { eAcnt = a + , eValue = v + , eComment = "" + , eCurrency = cur + , eTags = [] + } + tx = + Tx + { txDescr = desc + , txDate = day + , txSplits = [split from (-val), split to val] + } + +resolveTx :: (MonadInsertError m, MonadFinance m) => BalTx -> m KeyTx +resolveTx t@Tx {txSplits = ss} = + fmap (\kss -> t {txSplits = kss}) $ + combineErrors $ + fmap resolveSplit ss + +insertTx :: MonadSqlQuery m => CommitRId -> KeyTx -> m () +insertTx c Tx {txDate = d, txDescr = e, txSplits = ss} = do + k <- insert $ TransactionR c d e + mapM_ (insertSplit k) ss diff --git a/lib/Internal/Types/Main.hs b/lib/Internal/Types/Main.hs index 94b354f..7b4d127 100644 --- a/lib/Internal/Types/Main.hs +++ b/lib/Internal/Types/Main.hs @@ -44,8 +44,8 @@ data DBState = DBState { kmCurrency :: !CurrencyMap , kmAccount :: !AccountMap , kmTag :: !TagMap - , kmBudgetInterval :: !Bounds - , kmStatementInterval :: !Bounds + , kmBudgetInterval :: !DaySpan + , kmStatementInterval :: !DaySpan , kmNewCommits :: ![Int] , kmOldCommits :: ![Int] , kmConfigDir :: !FilePath @@ -63,35 +63,11 @@ type KeyTx = Tx KeySplit type TreeR = Tree ([T.Text], AccountRId) -type Balances = M.Map AccountRId Rational - -type BalanceM = ReaderT (MVar Balances) - type MonadFinance = MonadReader DBState askDBState :: MonadFinance m => (DBState -> a) -> m a 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 - ------------------------------------------------------------------------------- -- misc @@ -125,8 +101,7 @@ data TxRecord = TxRecord } deriving (Show, Eq, Ord) --- TODO pick a better name for this (something like DayInterval or something) -type Bounds = (Day, Natural) +type DaySpan = (Day, Natural) data Keyed a = Keyed { kKey :: !Int64 @@ -196,7 +171,7 @@ data InsertError | BalanceError !BalanceType !CurID ![RawSplit] | IncomeError !Day !T.Text !Rational | PatternError !Natural !Natural !(Maybe Natural) !PatternSuberr - | BoundsError !Gregorian !(Maybe Gregorian) + | DaySpanError !Gregorian !(Maybe Gregorian) | StatementError ![TxRecord] ![MatchRe] | PeriodError !Day !Day deriving (Show) diff --git a/lib/Internal/Utils.hs b/lib/Internal/Utils.hs index a1d268b..fa392bc 100644 --- a/lib/Internal/Utils.hs +++ b/lib/Internal/Utils.hs @@ -1,14 +1,15 @@ module Internal.Utils ( compareDate + , expandDatePat + , askDays , fromWeekday - , inBounds - , expandBounds + , inDaySpan , fmtRational , matches , fromGregorian' - , resolveBounds - , resolveBounds_ - , intersectBounds + , resolveDaySpan + , resolveDaySpan_ + , intersectDaySpan , liftInner , liftExceptT , liftExcept @@ -48,6 +49,12 @@ module Internal.Utils , valMatches , roundPrecision , roundPrecisionCur + , lookupAccountKey + , lookupAccountSign + , lookupAccountType + , lookupCurrencyKey + , lookupCurrencyPrec + , lookupTag ) where @@ -66,6 +73,96 @@ import RIO.Time import Text.Regex.TDFA import Text.Regex.TDFA.Text +-------------------------------------------------------------------------------- +-- intervals + +expandDatePat :: DaySpan -> DatePat -> InsertExcept [Day] +expandDatePat b (Cron cp) = expandCronPat b cp +expandDatePat i (Mod mp) = return $ expandModPat mp i + +expandModPat :: ModPat -> DaySpan -> [Day] +expandModPat ModPat {mpStart = s, mpBy = b, mpUnit = u, mpRepeats = r} bs = + takeWhile (<= upper) $ + (`addFun` start) . (* b') + <$> maybe id (take . fromIntegral) r [0 ..] + where + (lower, upper) = fromDaySpan bs + start = maybe lower fromGregorian' s + b' = fromIntegral b + addFun = case u of + Day -> addDays + Week -> addDays . (* 7) + Month -> addGregorianMonthsClip + Year -> addGregorianYearsClip + +expandCronPat :: DaySpan -> CronPat -> InsertExcept [Day] +expandCronPat b CronPat {cpYear, cpMonth, cpDay, cpWeekly} = + combineError3 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 cpYear of + Nothing -> return [yb0 .. yb1] + Just pat -> do + ys <- expandMDYPat (fromIntegral yb0) (fromIntegral yb1) pat + return $ dropWhile (< yb0) $ fromIntegral <$> ys + mRes = expandMD 12 cpMonth + dRes = expandMD 31 cpDay + (s, e) = fromDaySpan b + (yb0, mb0, db0) = toGregorian s + (yb1, mb1, db1) = toGregorian $ addDays (-1) e + expandMD lim = + fmap (fromIntegral <$>) + . maybe (return [1 .. lim]) (expandMDYPat 1 lim) + expandW (OnDay x) = [fromEnum x] + expandW (OnDays xs) = fromEnum <$> xs + ws = maybe [] expandW cpWeekly + validWeekday = if null ws then const True else \day -> dayToWeekday day `elem` ws + toDay (y, leap) m d + | m == 2 && (not leap && d > 28 || leap && d > 29) = Nothing + | m `elem` [4, 6, 9, 11] && d > 30 = Nothing + | otherwise = Just $ fromGregorian y m d + +expandMDYPat :: Natural -> Natural -> MDYPat -> InsertExcept [Natural] +expandMDYPat lower upper (Single x) = return [x | lower <= x && x <= upper] +expandMDYPat lower upper (Multi xs) = return $ dropWhile (<= lower) $ takeWhile (<= upper) xs +expandMDYPat lower upper (After x) = return [max lower x .. upper] +expandMDYPat lower upper (Before x) = return [lower .. min upper x] +expandMDYPat lower upper (Between x y) = return [max lower x .. min upper y] +expandMDYPat lower upper (Repeat RepeatPat {rpStart = s, rpBy = b, rpRepeats = r}) + | b < 1 = throwError $ InsertException [PatternError s b r ZeroLength] + | otherwise = do + k <- limit r + return $ dropWhile (<= lower) $ takeWhile (<= k) [s + i * b | i <- [0 ..]] + where + limit Nothing = return upper + limit (Just n) + -- this guard not only produces the error for the user but also protects + -- from an underflow below it + | n < 1 = throwError $ InsertException [PatternError s b r ZeroRepeats] + | otherwise = return $ min (s + b * (n - 1)) upper + +dayToWeekday :: Day -> Int +dayToWeekday (ModifiedJulianDay d) = mod (fromIntegral d + 2) 7 + +askDays + :: (MonadFinance m, MonadInsertError m) + => DatePat + -> Maybe Interval + -> m [Day] +askDays dp i = do + globalSpan <- askDBState kmBudgetInterval + case i of + Just i' -> do + localSpan <- liftExcept $ resolveDaySpan i' + maybe (return []) expand $ intersectDaySpan globalSpan localSpan + Nothing -> expand globalSpan + where + expand = liftExcept . (`expandDatePat` dp) + -------------------------------------------------------------------------------- -- dates @@ -152,39 +249,42 @@ compareDate (In md offset) x = do fromGregorian' :: Gregorian -> Day fromGregorian' = uncurry3 fromGregorian . gregTup -inBounds :: Bounds -> Day -> Bool -inBounds bs = withinDays (expandBounds bs) +inDaySpan :: DaySpan -> Day -> Bool +inDaySpan bs = withinDays (fromDaySpan bs) withinDays :: (Day, Day) -> Day -> Bool withinDays (d0, d1) x = d0 <= x && x < d1 -resolveBounds :: Interval -> InsertExcept Bounds -resolveBounds i@Interval {intStart = s} = - resolveBounds_ (s {gYear = gYear s + 50}) i +resolveDaySpan :: Interval -> InsertExcept DaySpan +resolveDaySpan i@Interval {intStart = s} = + resolveDaySpan_ (s {gYear = gYear s + 50}) i --- TODO not DRY -intersectBounds :: Bounds -> Bounds -> Maybe Bounds -intersectBounds a b = - if b' > a' then Nothing else Just (a', fromIntegral $ diffDays b' a' - 1) +intersectDaySpan :: DaySpan -> DaySpan -> Maybe DaySpan +intersectDaySpan a b = + if b' > a' then Nothing else Just $ toDaySpan (a', b') where - (a0, a1) = expandBounds a - (b0, b1) = expandBounds b + (a0, a1) = fromDaySpan a + (b0, b1) = fromDaySpan b a' = max a0 a1 b' = min b0 b1 -resolveBounds_ :: Gregorian -> Interval -> InsertExcept Bounds -resolveBounds_ def Interval {intStart = s, intEnd = e} = +resolveDaySpan_ :: Gregorian -> Interval -> InsertExcept DaySpan +resolveDaySpan_ def Interval {intStart = s, intEnd = e} = case fromGregorian' <$> e of - Nothing -> return $ toBounds $ fromGregorian' def + Nothing -> return $ toDaySpan_ $ fromGregorian' def Just e_ - | s_ < e_ -> return $ toBounds e_ - | otherwise -> throwError $ InsertException [BoundsError s e] + | s_ < e_ -> return $ toDaySpan_ e_ + | otherwise -> throwError $ InsertException [DaySpanError s e] where s_ = fromGregorian' s - toBounds end = (s_, fromIntegral $ diffDays end s_ - 1) + toDaySpan_ end = toDaySpan (s_, end) -expandBounds :: Bounds -> (Day, Day) -expandBounds (d, n) = (d, addDays (fromIntegral n + 1) d) +fromDaySpan :: DaySpan -> (Day, Day) +fromDaySpan (d, n) = (d, addDays (fromIntegral n + 1) d) + +-- ASSUME a < b +toDaySpan :: (Day, Day) -> DaySpan +toDaySpan (a, b) = (a, fromIntegral $ diffDays b a - 1) -------------------------------------------------------------------------------- -- matching @@ -457,7 +557,7 @@ acntPath2Text (AcntPath t cs) = T.intercalate "/" (atName t : cs) showError :: InsertError -> [T.Text] showError other = case other of (StatementError ts ms) -> (showTx <$> ts) ++ (showMatch <$> ms) - (BoundsError a b) -> + (DaySpanError a b) -> [T.unwords ["Could not create bounds from", showGregorian_ a, "and", showGreg b]] where showGreg (Just g) = showGregorian_ g @@ -794,3 +894,35 @@ matchGroupsMaybe q re = case regexec re q of Right (Just (_, _, _, xs)) -> xs -- this should never fail as regexec always returns Right Left _ -> [] + +lookupAccount :: (MonadInsertError m, MonadFinance m) => AcntID -> m (AccountRId, AcntSign, AcntType) +lookupAccount = lookupFinance AcntField kmAccount + +lookupAccountKey :: (MonadInsertError m, MonadFinance m) => AcntID -> m AccountRId +lookupAccountKey = fmap fstOf3 . lookupAccount + +lookupAccountSign :: (MonadInsertError m, MonadFinance m) => AcntID -> m AcntSign +lookupAccountSign = fmap sndOf3 . lookupAccount + +lookupAccountType :: (MonadInsertError m, MonadFinance m) => AcntID -> m AcntType +lookupAccountType = fmap thdOf3 . lookupAccount + +lookupCurrency :: (MonadInsertError m, MonadFinance m) => T.Text -> m (CurrencyRId, Natural) +lookupCurrency = lookupFinance CurField kmCurrency + +lookupCurrencyKey :: (MonadInsertError m, MonadFinance m) => AcntID -> m CurrencyRId +lookupCurrencyKey = fmap fst . lookupCurrency + +lookupCurrencyPrec :: (MonadInsertError m, MonadFinance m) => AcntID -> m Natural +lookupCurrencyPrec = fmap snd . lookupCurrency + +lookupTag :: (MonadInsertError m, MonadFinance m) => TagID -> m TagRId +lookupTag = lookupFinance TagField kmTag + +lookupFinance + :: (MonadInsertError m, MonadFinance m) + => SplitIDType + -> (DBState -> M.Map T.Text a) + -> T.Text + -> m a +lookupFinance t f c = (liftExcept . lookupErr (DBKey t) c) =<< askDBState f From 627704704e53605dd04eeec969c927eba0668193 Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Mon, 29 May 2023 15:58:27 -0400 Subject: [PATCH 04/15] REF remove config module --- app/Main.hs | 5 ++++- budget.cabal | 1 - lib/Internal/Config.hs | 11 ----------- 3 files changed, 4 insertions(+), 13 deletions(-) delete mode 100644 lib/Internal/Config.hs diff --git a/app/Main.hs b/app/Main.hs index 53579ff..a8ba0d8 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -8,8 +8,8 @@ import Control.Monad.Logger import Control.Monad.Reader import qualified Data.Text.IO as TI import Database.Persist.Monad +import Dhall hiding (double, record) import Internal.Budget -import Internal.Config import Internal.Database.Ops import Internal.History import Internal.Types.Main @@ -191,3 +191,6 @@ runSync c = do exitFailure -- showBalances + +readConfig :: MonadUnliftIO m => FilePath -> m Config +readConfig confpath = liftIO $ unfix <$> Dhall.inputFile Dhall.auto confpath diff --git a/budget.cabal b/budget.cabal index f50c6e1..1ad76c4 100644 --- a/budget.cabal +++ b/budget.cabal @@ -26,7 +26,6 @@ source-repository head library exposed-modules: Internal.Budget - Internal.Config Internal.Database.Ops Internal.History Internal.Statement diff --git a/lib/Internal/Config.hs b/lib/Internal/Config.hs deleted file mode 100644 index 93df85b..0000000 --- a/lib/Internal/Config.hs +++ /dev/null @@ -1,11 +0,0 @@ -module Internal.Config - ( readConfig - ) -where - -import Dhall hiding (record) -import Internal.Types.Main -import RIO - -readConfig :: MonadUnliftIO m => FilePath -> m Config -readConfig confpath = liftIO $ unfix <$> inputFile auto confpath From ff0393dc02730bc190c2f493a31c4309935485d7 Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Mon, 29 May 2023 16:11:19 -0400 Subject: [PATCH 05/15] REF remove "split" lingo --- lib/Internal/Budget.hs | 29 ++++++++++++++------ lib/Internal/Database/Ops.hs | 14 +++++----- lib/Internal/History.hs | 29 ++++---------------- lib/Internal/Statement.hs | 12 ++++---- lib/Internal/Types/Database.hs | 6 ++-- lib/Internal/Types/Dhall.hs | 14 +++++----- lib/Internal/Types/Main.hs | 24 ++++++++-------- lib/Internal/Utils.hs | 50 +++++++++++++++++----------------- 8 files changed, 86 insertions(+), 92 deletions(-) diff --git a/lib/Internal/Budget.hs b/lib/Internal/Budget.hs index aabe2db..935bedb 100644 --- a/lib/Internal/Budget.hs +++ b/lib/Internal/Budget.hs @@ -12,6 +12,17 @@ import qualified RIO.NonEmpty as NE import qualified RIO.Text as T import RIO.Time +-- each budget (designated at the top level by a 'name') is processed in the +-- following steps +-- 1. expand all transactions given the desired date range and date patterns for +-- each directive in the budget +-- 2. sort all transactions by date +-- 3. propagate all balances forward, and while doing so assign values to each +-- transaction (some of which depend on the 'current' balance of the +-- target account) +-- 4. assign shadow transactions (TODO) +-- 5. insert all transactions + insertBudget :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m) => Budget @@ -73,8 +84,8 @@ insertBudgetTx FlatTransfer {ftFrom, ftTo, ftMeta, ftCur, ftValue, ftDesc, ftWhe k <- insert $ TransactionR (bmCommit ftMeta) ftWhen ftDesc insertBudgetLabel k from insertBudgetLabel k to - insertBudgetLabel k split = do - sk <- insertSplit k split + insertBudgetLabel k entry = do + sk <- insertEntry k entry insert_ $ BudgetLabelR sk $ bmName ftMeta entryPair @@ -83,7 +94,7 @@ entryPair -> TaggedAcnt -> BudgetCurrency -> Rational - -> m (SplitPair, Maybe SplitPair) + -> m (EntryPair, Maybe EntryPair) entryPair from to cur val = case cur of NoX curid -> (,Nothing) <$> pair curid from to val X Exchange {xFromCur, xToCur, xAcnt, xRate} -> do @@ -93,11 +104,11 @@ entryPair from to cur val = case cur of combineError res1 res2 $ \a b -> (a, Just b) where pair curid from_ to_ v = do - let s1 = split curid from_ (-v) - let s2 = split curid to_ v + let s1 = entry curid from_ (-v) + let s2 = entry curid to_ v combineError s1 s2 (,) - split c TaggedAcnt {taAcnt, taTags} v = - resolveSplit $ + entry c TaggedAcnt {taAcnt, taTags} v = + resolveEntry $ Entry { eAcnt = taAcnt , eValue = v @@ -368,7 +379,7 @@ allocatePost precision aftertax = fmap (fmap go) else roundPrecision precision v -------------------------------------------------------------------------------- --- Transfer +-- Standalone Transfer expandTransfers :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m) @@ -520,7 +531,7 @@ type IntAllocations = type DaySpanAllocation = Allocation DaySpan -type SplitPair = (KeySplit, KeySplit) +type EntryPair = (KeyEntry, KeyEntry) type PeriodScaler = Natural -> Double -> Double diff --git a/lib/Internal/Database/Ops.hs b/lib/Internal/Database/Ops.hs index 9676269..e32df5b 100644 --- a/lib/Internal/Database/Ops.hs +++ b/lib/Internal/Database/Ops.hs @@ -10,8 +10,8 @@ module Internal.Database.Ops , mkPool , whenHash , whenHash_ - , insertSplit - , resolveSplit + , insertEntry + , resolveEntry ) where @@ -401,14 +401,14 @@ whenHash_ t o f = do hs <- askDBState kmNewCommits if h `elem` hs then Just . (c,) <$> f else return Nothing -insertSplit :: MonadSqlQuery m => TransactionRId -> KeySplit -> m SplitRId -insertSplit t Entry {eAcnt, eCurrency, eValue, eComment, eTags} = do - k <- insert $ SplitR t eCurrency eAcnt eComment eValue +insertEntry :: MonadSqlQuery m => TransactionRId -> KeyEntry -> m EntryRId +insertEntry t Entry {eAcnt, eCurrency, eValue, eComment, eTags} = do + k <- insert $ EntryR t eCurrency eAcnt eComment eValue mapM_ (insert_ . TagRelationR k) eTags return k -resolveSplit :: (MonadInsertError m, MonadFinance m) => BalSplit -> m KeySplit -resolveSplit s@Entry {eAcnt, eCurrency, eValue, eTags} = do +resolveEntry :: (MonadInsertError m, MonadFinance m) => BalEntry -> m KeyEntry +resolveEntry s@Entry {eAcnt, eCurrency, eValue, eTags} = do let aRes = lookupAccountKey eAcnt let cRes = lookupCurrencyKey eCurrency let sRes = lookupAccountSign eAcnt diff --git a/lib/Internal/History.hs b/lib/Internal/History.hs index 92284bb..72d50a4 100644 --- a/lib/Internal/History.hs +++ b/lib/Internal/History.hs @@ -16,23 +16,6 @@ import RIO hiding (to) import qualified RIO.Text as T import RIO.Time --------------------------------------------------------------------------------- --- budget - --- each budget (designated at the top level by a 'name') is processed in the --- following steps --- 1. expand all transactions given the desired date range and date patterns for --- each directive in the budget --- 2. sort all transactions by date --- 3. propagate all balances forward, and while doing so assign values to each --- transaction (some of which depend on the 'current' balance of the --- target account) --- 4. assign shadow transactions (TODO) --- 5. insert all transactions - --------------------------------------------------------------------------------- --- statements - splitHistory :: [History] -> ([HistTransfer], [Statement]) splitHistory = partitionEithers . fmap go where @@ -118,16 +101,16 @@ txPair day from to cur val desc = resolveTx tx Tx { txDescr = desc , txDate = day - , txSplits = [split from (-val), split to val] + , txEntries = [split from (-val), split to val] } resolveTx :: (MonadInsertError m, MonadFinance m) => BalTx -> m KeyTx -resolveTx t@Tx {txSplits = ss} = - fmap (\kss -> t {txSplits = kss}) $ +resolveTx t@Tx {txEntries = ss} = + fmap (\kss -> t {txEntries = kss}) $ combineErrors $ - fmap resolveSplit ss + fmap resolveEntry ss insertTx :: MonadSqlQuery m => CommitRId -> KeyTx -> m () -insertTx c Tx {txDate = d, txDescr = e, txSplits = ss} = do +insertTx c Tx {txDate = d, txDescr = e, txEntries = ss} = do k <- insert $ TransactionR c d e - mapM_ (insertSplit k) ss + mapM_ (insertEntry k) ss diff --git a/lib/Internal/Statement.hs b/lib/Internal/Statement.hs index cf09dcb..386d96c 100644 --- a/lib/Internal/Statement.hs +++ b/lib/Internal/Statement.hs @@ -217,12 +217,12 @@ matchNonDates ms = go ([], [], initZipper ms) in go (m, u, resetZipper z') rs balanceTx :: RawTx -> InsertExcept BalTx -balanceTx t@Tx {txSplits = ss} = do - bs <- balanceSplits ss - return $ t {txSplits = bs} +balanceTx t@Tx {txEntries = ss} = do + bs <- balanceEntries ss + return $ t {txEntries = bs} -balanceSplits :: [RawSplit] -> InsertExcept [BalSplit] -balanceSplits ss = +balanceEntries :: [RawEntry] -> InsertExcept [BalEntry] +balanceEntries ss = fmap concat <$> mapM (uncurry bal) $ groupByKey @@ -231,7 +231,7 @@ balanceSplits ss = haeValue s@Entry {eValue = Just v} = Right s {eValue = v} haeValue s = Left s bal cur rss - | length rss < 2 = throwError $ InsertException [BalanceError TooFewSplits 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 diff --git a/lib/Internal/Types/Database.hs b/lib/Internal/Types/Database.hs index 9e82ca6..6ea5506 100644 --- a/lib/Internal/Types/Database.hs +++ b/lib/Internal/Types/Database.hs @@ -44,7 +44,7 @@ TransactionR sql=transactions date Day description T.Text deriving Show Eq -SplitR sql=splits +EntryR sql=entries transaction TransactionRId OnDeleteCascade currency CurrencyRId OnDeleteCascade account AccountRId OnDeleteCascade @@ -52,10 +52,10 @@ SplitR sql=splits value Rational deriving Show Eq TagRelationR sql=tag_relations - split SplitRId OnDeleteCascade + entry EntryRId OnDeleteCascade tag TagRId OnDeleteCascade BudgetLabelR sql=budget_labels - split SplitRId OnDeleteCascade + entry EntryRId OnDeleteCascade budgetName T.Text deriving Show Eq |] diff --git a/lib/Internal/Types/Dhall.hs b/lib/Internal/Types/Dhall.hs index 9a96a14..ea29dbf 100644 --- a/lib/Internal/Types/Dhall.hs +++ b/lib/Internal/Types/Dhall.hs @@ -421,7 +421,7 @@ data History | HistStatement !Statement deriving (Eq, Generic, Hashable, FromDhall) -type EntryGetter = Entry SplitAcnt (Maybe EntryNumGetter) SplitCur TagID +type EntryGetter = Entry EntryAcnt (Maybe EntryNumGetter) EntryCur TagID instance FromDhall EntryGetter @@ -436,7 +436,7 @@ deriving instance (Eq a, Eq v, Eq c, Eq t) => Eq (Entry a v c t) data Tx s = Tx { txDescr :: !T.Text , txDate :: !Day - , txSplits :: ![s] + , txEntries :: ![s] } deriving (Generic) @@ -463,7 +463,7 @@ data Statement = Statement } deriving (Eq, Hashable, Generic, FromDhall) --- | the value of a field in split (text version) +-- | the value of a field in entry (text version) -- can either be a raw (constant) value, a lookup from the record, or a map -- between the lookup and some other value data EntryTextGetter t @@ -473,9 +473,9 @@ data EntryTextGetter t | Map2T !(FieldMap (T.Text, T.Text) t) deriving (Eq, Generic, Hashable, Show, FromDhall) -type SplitCur = EntryTextGetter CurID +type EntryCur = EntryTextGetter CurID -type SplitAcnt = EntryTextGetter AcntID +type EntryAcnt = EntryTextGetter AcntID deriving instance (Show k, Show v) => Show (Field k v) @@ -504,8 +504,8 @@ data FieldMatcher re deriving instance Show (FieldMatcher T.Text) data TxGetter = TxGetter - { tgCurrency :: !SplitCur - , tgAcnt :: !SplitAcnt + { tgCurrency :: !EntryCur + , tgAcnt :: !EntryAcnt , tgEntries :: ![EntryGetter] } deriving (Eq, Generic, Hashable, Show, FromDhall) diff --git a/lib/Internal/Types/Main.hs b/lib/Internal/Types/Main.hs index 7b4d127..9605d41 100644 --- a/lib/Internal/Types/Main.hs +++ b/lib/Internal/Types/Main.hs @@ -57,9 +57,9 @@ data DBState = DBState type CurrencyM = Reader CurrencyMap -type KeySplit = Entry AccountRId Rational CurrencyRId TagRId +type KeyEntry = Entry AccountRId Rational CurrencyRId TagRId -type KeyTx = Tx KeySplit +type KeyTx = Tx KeyEntry type TreeR = Tree ([T.Text], AccountRId) @@ -125,30 +125,30 @@ accountSign IncomeT = Credit accountSign LiabilityT = Credit accountSign EquityT = Credit -type RawSplit = Entry AcntID (Maybe Rational) CurID TagID +type RawEntry = Entry AcntID (Maybe Rational) CurID TagID -type BalSplit = Entry AcntID Rational CurID TagID +type BalEntry = Entry AcntID Rational CurID TagID -type RawTx = Tx RawSplit +type RawTx = Tx RawEntry -type BalTx = Tx BalSplit +type BalTx = Tx BalEntry data MatchRes a = MatchPass !a | MatchFail | MatchSkip -------------------------------------------------------------------------------- -- exception types -data BalanceType = TooFewSplits | NotOneBlank deriving (Show) +data BalanceType = TooFewEntries | NotOneBlank deriving (Show) data MatchType = MatchNumeric | MatchText deriving (Show) -data SplitIDType = AcntField | CurField | TagField deriving (Show) +data EntryIDType = AcntField | CurField | TagField deriving (Show) data LookupSuberr - = SplitIDField !SplitIDType - | SplitValField + = EntryIDField !EntryIDType + | EntryValField | MatchField !MatchType - | DBKey !SplitIDType + | DBKey !EntryIDType deriving (Show) data AllocationSuberr @@ -168,7 +168,7 @@ data InsertError | ParseError !T.Text | ConversionError !T.Text | LookupError !LookupSuberr !T.Text - | BalanceError !BalanceType !CurID ![RawSplit] + | BalanceError !BalanceType !CurID ![RawEntry] | IncomeError !Day !T.Text !Rational | PatternError !Natural !Natural !(Maybe Natural) !PatternSuberr | DaySpanError !Gregorian !(Maybe Gregorian) diff --git a/lib/Internal/Utils.hs b/lib/Internal/Utils.hs index fa392bc..fcca4d1 100644 --- a/lib/Internal/Utils.hs +++ b/lib/Internal/Utils.hs @@ -306,10 +306,10 @@ matches desc = maybe (return True) (matchMaybe trDesc . snd) spDesc convert (TxGetter cur a ss) = MatchPass <$> toTx cur a ss r -toTx :: SplitCur -> SplitAcnt -> [EntryGetter] -> TxRecord -> InsertExceptT CurrencyM RawTx -toTx sc sa toSplits r@TxRecord {trAmount, trDate, trDesc} = do - combineError3 acntRes curRes ssRes $ \a c ss -> - let fromSplit = +toTx :: EntryCur -> EntryAcnt -> [EntryGetter] -> TxRecord -> InsertExceptT CurrencyM RawTx +toTx sc sa toEntries r@TxRecord {trAmount, trDate, trDesc} = do + combineError3 acntRes curRes ssRes $ \a c es -> + let fromEntry = Entry { eAcnt = a , eCurrency = c @@ -320,12 +320,12 @@ toTx sc sa toSplits r@TxRecord {trAmount, trDate, trDesc} = do in Tx { txDate = trDate , txDescr = trDesc - , txSplits = fromSplit : ss + , txEntries = fromEntry : es } where acntRes = liftInner $ resolveAcnt r sa curRes = liftInner $ resolveCurrency r sc - ssRes = combineErrors $ fmap (resolveEntry r) toSplits + ssRes = combineErrors $ fmap (resolveEntry r) toEntries valMatches :: ValMatcher -> Rational -> InsertExcept Bool valMatches ValMatcher {vmDen, vmSign, vmNum, vmPrec} x @@ -351,7 +351,7 @@ otherMatches dict m = case m of where lookup_ t n = lookupErr (MatchField t) n dict -resolveEntry :: TxRecord -> EntryGetter -> InsertExceptT CurrencyM RawSplit +resolveEntry :: TxRecord -> EntryGetter -> InsertExceptT CurrencyM RawEntry resolveEntry r s@Entry {eAcnt, eValue, eCurrency} = do m <- ask liftInner $ combineErrorM3 acntRes curRes valRes $ \a c v -> do @@ -447,18 +447,18 @@ collectErrorsIO = mapErrorsIO id resolveValue :: TxRecord -> EntryNumGetter -> InsertExcept Double resolveValue TxRecord {trOther, trAmount} s = case s of - (LookupN t) -> readDouble =<< lookupErr SplitValField t trOther + (LookupN t) -> readDouble =<< lookupErr EntryValField t trOther (ConstN c) -> return c AmountN m -> return $ (* m) $ fromRational trAmount -resolveAcnt :: TxRecord -> SplitAcnt -> InsertExcept T.Text -resolveAcnt = resolveSplitField AcntField +resolveAcnt :: TxRecord -> EntryAcnt -> InsertExcept T.Text +resolveAcnt = resolveEntryField AcntField -resolveCurrency :: TxRecord -> SplitCur -> InsertExcept T.Text -resolveCurrency = resolveSplitField CurField +resolveCurrency :: TxRecord -> EntryCur -> InsertExcept T.Text +resolveCurrency = resolveEntryField CurField -resolveSplitField :: SplitIDType -> TxRecord -> SplitAcnt -> InsertExcept T.Text -resolveSplitField t TxRecord {trOther = o} s = case s of +resolveEntryField :: EntryIDType -> TxRecord -> EntryAcnt -> InsertExcept T.Text +resolveEntryField t TxRecord {trOther = o} s = case s of ConstT p -> return p LookupT f -> lookup_ f o MapT (Field f m) -> do @@ -469,7 +469,7 @@ resolveSplitField t TxRecord {trOther = o} s = case s of lookup_ (k1, k2) m where lookup_ :: (Ord k, Show k) => k -> M.Map k v -> InsertExcept v - lookup_ = lookupErr (SplitIDField t) + lookup_ = lookupErr (EntryIDField t) lookupErr :: (Ord k, Show k) => LookupSuberr -> k -> M.Map k v -> InsertExcept v lookupErr what k m = case M.lookup k m of @@ -596,8 +596,8 @@ showError other = case other of [T.unwords ["Could not find field", f, "when resolving", what]] where what = case t of - SplitIDField st -> T.unwords ["split", idName st, "ID"] - SplitValField -> "split value" + EntryIDField st -> T.unwords ["entry", idName st, "ID"] + EntryValField -> "entry value" MatchField mt -> T.unwords [matchName mt, "match"] DBKey st -> T.unwords ["database", idName st, "ID key"] -- TODO this should be its own function @@ -629,15 +629,15 @@ showError other = case other of [ msg , "for currency" , singleQuote cur - , "and for splits" - , splits + , "and for entries" + , entries ] ] where msg = case t of - TooFewSplits -> "Need at least two splits to balance" - NotOneBlank -> "Exactly one split must be blank" - splits = T.intercalate ", " $ fmap (singleQuote . showSplit) rss + TooFewEntries -> "Need at least two entries to balance" + NotOneBlank -> "Exactly one entries must be blank" + entries = T.intercalate ", " $ fmap (singleQuote . showEntry) rss showGregorian_ :: Gregorian -> T.Text showGregorian_ Gregorian {gYear, gMonth, gDay} = T.intercalate "-" $ showT <$> [gYear, gMonth, gDay] @@ -725,8 +725,8 @@ showMatchOther (Val (Field f mv)) = , singleQuote $ fromMaybe "*" $ showValMatcher mv ] -showSplit :: RawSplit -> T.Text -showSplit Entry {eAcnt, eValue, eComment} = +showEntry :: RawEntry -> T.Text +showEntry Entry {eAcnt, eValue, eComment} = keyVals [ ("account", eAcnt) , ("value", T.pack $ show ((fromRational <$> eValue) :: Maybe Float)) @@ -921,7 +921,7 @@ lookupTag = lookupFinance TagField kmTag lookupFinance :: (MonadInsertError m, MonadFinance m) - => SplitIDType + => EntryIDType -> (DBState -> M.Map T.Text a) -> T.Text -> m a From 092d771f30e79a60759a741c6d4ee1269e18be7e Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Mon, 29 May 2023 16:36:59 -0400 Subject: [PATCH 06/15] ENH check period date once --- lib/Internal/Budget.hs | 36 +++++++++++++++++------------------- 1 file changed, 17 insertions(+), 19 deletions(-) diff --git a/lib/Internal/Budget.hs b/lib/Internal/Budget.hs index 935bedb..088d533 100644 --- a/lib/Internal/Budget.hs +++ b/lib/Internal/Budget.hs @@ -20,7 +20,7 @@ import RIO.Time -- 3. propagate all balances forward, and while doing so assign values to each -- transaction (some of which depend on the 'current' balance of the -- target account) --- 4. assign shadow transactions (TODO) +-- 4. assign shadow transactions -- 5. insert all transactions insertBudget @@ -203,20 +203,18 @@ insertIncome then throwError $ InsertException [IncomeError day name balance] else return (bal : fmap (allo2Trans meta day incFrom) (pre ++ tax ++ post)) --- TODO we probably don't need to check for 1/0 each time periodScaler :: PeriodType -> Day -> Day -> InsertExcept PeriodScaler -periodScaler pt prev cur = do - n <- workingDays wds prev cur - return $ scale (fromIntegral n) +periodScaler pt prev cur = return scale where + n = fromIntegral $ workingDays wds prev cur wds = case pt of Hourly HourlyPeriod {hpWorkingDays} -> hpWorkingDays Daily ds -> ds - scale n precision x = case pt of + scale precision x = case pt of Hourly HourlyPeriod {hpAnnualHours, hpDailyHours} -> fromRational (rnd $ x / fromIntegral hpAnnualHours) * fromIntegral hpDailyHours @@ -225,17 +223,14 @@ periodScaler pt prev cur = do where rnd = roundPrecision precision -workingDays :: [Weekday] -> Day -> Day -> InsertExcept Natural -workingDays wds start end - | interval > 0 = - let (nFull, nPart) = divMod interval 7 - daysFull = fromIntegral (length wds') * nFull - daysTail = fromIntegral $ length $ takeWhile (< nPart) wds' - in return $ fromIntegral $ daysFull + daysTail - -- TODO make an error here that says something to the effect of "Period must be positive" - | otherwise = throwError $ InsertException undefined +-- ASSUME start < end +workingDays :: [Weekday] -> Day -> Day -> Natural +workingDays wds start end = fromIntegral $ daysFull + daysTail where interval = diffDays end start + (nFull, nPart) = divMod interval 7 + daysFull = fromIntegral (length wds') * nFull + daysTail = fromIntegral $ length $ takeWhile (< nPart) wds' startDay = dayOfWeek start wds' = L.sort $ (\x -> diff (fromWeekday x) startDay) <$> L.nub wds diff a b = fromIntegral $ mod (fromEnum a - fromEnum b) 7 @@ -246,10 +241,13 @@ foldDays -> Day -> [Day] -> m [a] -foldDays f start days = - combineErrors $ - snd $ - L.mapAccumL (\prevDay day -> (day, f prevDay day)) start days +foldDays f start days + -- TODO throw real error here + | any (start >) days = throwError undefined + | otherwise = + combineErrors $ + snd $ + L.mapAccumL (\prevDay day -> (day, f prevDay day)) start days checkAcntType :: (MonadInsertError m, MonadFinance m) From 1555e9071f1c040cd3e902093f3994abaaec2f24 Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Mon, 29 May 2023 16:46:20 -0400 Subject: [PATCH 07/15] FIX actually throw error when folding periods/days --- lib/Internal/Budget.hs | 19 ++++++++++++------- 1 file changed, 12 insertions(+), 7 deletions(-) diff --git a/lib/Internal/Budget.hs b/lib/Internal/Budget.hs index 088d533..d343d6a 100644 --- a/lib/Internal/Budget.hs +++ b/lib/Internal/Budget.hs @@ -1,6 +1,7 @@ module Internal.Budget (insertBudget) where import Control.Monad.Except +import Data.Foldable import Database.Persist.Monad import Internal.Database.Ops import Internal.Types.Main @@ -235,19 +236,23 @@ workingDays wds start end = fromIntegral $ daysFull + daysTail wds' = L.sort $ (\x -> diff (fromWeekday x) startDay) <$> L.nub wds diff a b = fromIntegral $ mod (fromEnum a - fromEnum b) 7 +-- ASSUME days is a sorted list foldDays :: MonadInsertError m => (Day -> Day -> m a) -> Day -> [Day] -> m [a] -foldDays f start days - -- TODO throw real error here - | any (start >) days = throwError undefined - | otherwise = - combineErrors $ - snd $ - L.mapAccumL (\prevDay day -> (day, f prevDay day)) start days +foldDays f start days = case NE.nonEmpty days of + Nothing -> return [] + Just ds + | any (start >) ds -> + throwError $ + InsertException [PeriodError start $ minimum ds] + | otherwise -> + combineErrors $ + snd $ + L.mapAccumL (\prevDay day -> (day, f prevDay day)) start days checkAcntType :: (MonadInsertError m, MonadFinance m) From b586f958cbb3dad09eee08a3777bc8e0bc723751 Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Mon, 29 May 2023 17:06:38 -0400 Subject: [PATCH 08/15] ENH check all income accounts --- lib/Internal/Budget.hs | 45 +++++++++++++++++++++++++++++------------- 1 file changed, 31 insertions(+), 14 deletions(-) diff --git a/lib/Internal/Budget.hs b/lib/Internal/Budget.hs index d343d6a..6e59e9c 100644 --- a/lib/Internal/Budget.hs +++ b/lib/Internal/Budget.hs @@ -134,6 +134,9 @@ sortAllo a@Allocation {alloAmts = as} = do -------------------------------------------------------------------------------- -- Income +-- TODO this will scan the interval allocations fully each time +-- iteration which is a total waste, but the fix requires turning this +-- loop into a fold which I don't feel like doing now :( insertIncome :: (MonadInsertError m, MonadFinance m) => CommitRId @@ -157,18 +160,23 @@ insertIncome , incToBal , incGross , incPayPeriod - } = do - -- TODO check that the other accounts are not income somewhere here - _ <- checkAcntType IncomeT $ taAcnt incFrom - precision <- lookupCurrencyPrec incCurrency - let gross = roundPrecision precision incGross - -- TODO this will scan the interval allocations fully each time - -- iteration which is a total waste, but the fix requires turning this - -- loop into a fold which I don't feel like doing now :( - days <- askDays incWhen localInterval - res <- foldDays (allocate precision gross) start days - return $ concat res + } = + combineErrorM + (combineError incRes nonIncRes (,)) + (combineError precRes dayRes (,)) + $ \_ (precision, days) -> do + let gross = roundPrecision precision incGross + concat <$> foldDays (allocate precision gross) start days where + incRes = isIncomeAcnt $ taAcnt incFrom + nonIncRes = + mapErrors isNotIncomeAcnt $ + taAcnt incToBal + : (alloAcnt <$> incPretax) + ++ (alloAcnt <$> incTaxes) + ++ (alloAcnt <$> incPosttax) + precRes = lookupCurrencyPrec incCurrency + dayRes = askDays incWhen localInterval start = fromGregorian' $ pStart incPayPeriod pType' = pType incPayPeriod meta = BudgetMeta key name @@ -254,19 +262,25 @@ foldDays f start days = case NE.nonEmpty days of snd $ L.mapAccumL (\prevDay day -> (day, f prevDay day)) start days +isIncomeAcnt :: (MonadInsertError m, MonadFinance m) => AcntID -> m () +isIncomeAcnt = checkAcntType IncomeT + +isNotIncomeAcnt :: (MonadInsertError m, MonadFinance m) => AcntID -> m () +isNotIncomeAcnt = checkAcntTypes (AssetT :| [EquityT, ExpenseT, LiabilityT]) + checkAcntType :: (MonadInsertError m, MonadFinance m) => AcntType -> AcntID - -> m AcntID + -> m () checkAcntType t = checkAcntTypes (t :| []) checkAcntTypes :: (MonadInsertError m, MonadFinance m) => NE.NonEmpty AcntType -> AcntID - -> m AcntID -checkAcntTypes ts i = go =<< lookupAccountType i + -> m () +checkAcntTypes ts i = void $ go =<< lookupAccountType i where go t | t `L.elem` ts = return i @@ -499,6 +513,9 @@ initialCurrency :: BudgetCurrency -> CurID initialCurrency (NoX c) = c initialCurrency (X Exchange {xFromCur = c}) = c +alloAcnt :: Allocation w v -> AcntID +alloAcnt = taAcnt . alloTo + data UnbalancedValue = UnbalancedValue { cvType :: !BudgetTransferType , cvValue :: !Rational From c3ab976407fc5fd8fd3f4cbbcf801b935ff7728c Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Mon, 29 May 2023 17:14:01 -0400 Subject: [PATCH 09/15] ENH check accounts in multiallocations --- lib/Internal/Budget.hs | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/lib/Internal/Budget.hs b/lib/Internal/Budget.hs index 6e59e9c..8414b53 100644 --- a/lib/Internal/Budget.hs +++ b/lib/Internal/Budget.hs @@ -40,7 +40,7 @@ insertBudget , bgtInterval } = whenHash CTBudget b () $ \key -> do - intAllos <- combineError3 pre_ tax_ post_ (,,) + (intAllos, _) <- combineError intAlloRes acntRes (,) let res1 = mapErrors (insertIncome key bgtLabel intAllos bgtInterval) bgtIncomes let res2 = expandTransfers key bgtLabel bgtInterval bgtTransfers txs <- combineError (concat <$> res1) res2 (++) @@ -48,10 +48,16 @@ insertBudget shadow <- liftExcept $ addShadowTransfers m bgtShadowTransfers txs void $ mapErrors insertBudgetTx $ balanceTransfers $ txs ++ shadow where + acntRes = mapErrors isNotIncomeAcnt alloAcnts + intAlloRes = combineError3 pre_ tax_ post_ (,,) pre_ = sortAllos bgtPretax tax_ = sortAllos bgtTax post_ = sortAllos bgtPosttax - sortAllos = liftExcept . combineErrors . fmap sortAllo + sortAllos = liftExcept . mapErrors sortAllo + alloAcnts = + (alloAcnt <$> bgtPretax) + ++ (alloAcnt <$> bgtTax) + ++ (alloAcnt <$> bgtPosttax) balanceTransfers :: [UnbalancedTransfer] -> [BalancedTransfer] balanceTransfers = snd . L.mapAccumR go M.empty . reverse . L.sortOn ftWhen From 55487982ec7809910e90c5895550c09b6608b97a Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Mon, 29 May 2023 17:16:13 -0400 Subject: [PATCH 10/15] REF remove dead code --- lib/Internal/History.hs | 19 ------------------- 1 file changed, 19 deletions(-) diff --git a/lib/Internal/History.hs b/lib/Internal/History.hs index 72d50a4..b4d58c2 100644 --- a/lib/Internal/History.hs +++ b/lib/Internal/History.hs @@ -22,13 +22,6 @@ splitHistory = partitionEithers . fmap go go (HistTransfer x) = Left x go (HistStatement x) = Right x --- insertStatement --- :: (MonadUnliftIO m, MonadSqlQuery m, MonadFinance m) --- => History --- -> m () --- insertStatement (HistTransfer m) = liftIOExceptT $ insertManual m --- insertStatement (HistStatement i) = insertImport i - insertHistTransfer :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m) => HistTransfer @@ -62,18 +55,6 @@ insertHistStmt c ks = do ck <- insert c mapM_ (insertTx ck) ks --- insertImport --- :: (MonadUnliftIO m, MonadSqlQuery m, MonadFinance m) --- => Statement --- -> m () --- 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 --- bs <- readImport i --- bounds <- expandBounds <$> askDBState kmStatementInterval --- keys <- liftIOExceptT $ mapErrors resolveTx $ filter (inBounds bounds . txDate) bs --- mapM_ (insertTx c) keys - -------------------------------------------------------------------------------- -- low-level transaction stuff From ba557639c28836fd8ff81d851d2ee4477fdfcab1 Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Mon, 29 May 2023 17:19:49 -0400 Subject: [PATCH 11/15] REF combine statement with history --- budget.cabal | 1 - lib/Internal/History.hs | 231 +++++++++++++++++++++++++++++++++++- lib/Internal/Statement.hs | 241 -------------------------------------- 3 files changed, 230 insertions(+), 243 deletions(-) delete mode 100644 lib/Internal/Statement.hs 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 (: [])) From 971cfa1c920f493874c3bc1daef270ca5f2af673 Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Mon, 29 May 2023 17:32:28 -0400 Subject: [PATCH 12/15] REF remove dead comments --- lib/Internal/History.hs | 3 --- 1 file changed, 3 deletions(-) diff --git a/lib/Internal/History.hs b/lib/Internal/History.hs index 09fd3f3..bbf52c9 100644 --- a/lib/Internal/History.hs +++ b/lib/Internal/History.hs @@ -154,7 +154,6 @@ 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] @@ -170,7 +169,6 @@ matchToGroup ms = 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] @@ -226,7 +224,6 @@ zipperMatch (Unzipped bs cs as) x = go [] cs 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 From 2a6aa23836cfdbd614fec33fff2e6b733ab09991 Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Mon, 29 May 2023 17:33:59 -0400 Subject: [PATCH 13/15] REF move database to same level module --- app/Main.hs | 2 +- budget.cabal | 2 +- lib/Internal/Budget.hs | 2 +- lib/Internal/Database/Ops.hs | 425 ----------------------------------- lib/Internal/History.hs | 2 +- 5 files changed, 4 insertions(+), 429 deletions(-) delete mode 100644 lib/Internal/Database/Ops.hs diff --git a/app/Main.hs b/app/Main.hs index a8ba0d8..69208e7 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -10,7 +10,7 @@ import qualified Data.Text.IO as TI import Database.Persist.Monad import Dhall hiding (double, record) import Internal.Budget -import Internal.Database.Ops +import Internal.Database import Internal.History import Internal.Types.Main import Internal.Utils diff --git a/budget.cabal b/budget.cabal index a0d6323..aa0f2b3 100644 --- a/budget.cabal +++ b/budget.cabal @@ -26,7 +26,7 @@ source-repository head library exposed-modules: Internal.Budget - Internal.Database.Ops + Internal.Database Internal.History Internal.Types.Database Internal.Types.Dhall diff --git a/lib/Internal/Budget.hs b/lib/Internal/Budget.hs index 8414b53..ec92a72 100644 --- a/lib/Internal/Budget.hs +++ b/lib/Internal/Budget.hs @@ -3,7 +3,7 @@ module Internal.Budget (insertBudget) where import Control.Monad.Except import Data.Foldable import Database.Persist.Monad -import Internal.Database.Ops +import Internal.Database import Internal.Types.Main import Internal.Utils import RIO hiding (to) diff --git a/lib/Internal/Database/Ops.hs b/lib/Internal/Database/Ops.hs deleted file mode 100644 index e32df5b..0000000 --- a/lib/Internal/Database/Ops.hs +++ /dev/null @@ -1,425 +0,0 @@ -module Internal.Database.Ops - ( runDB - , nukeTables - , updateHashes - , updateDBState - , getDBState - , tree2Records - , flattenAcntRoot - , paths2IDs - , mkPool - , whenHash - , whenHash_ - , insertEntry - , resolveEntry - ) -where - -import Conduit -import Control.Monad.Except -import Control.Monad.Logger -import Data.Hashable -import Database.Esqueleto.Experimental ((==.), (^.)) -import qualified Database.Esqueleto.Experimental as E -import Database.Esqueleto.Internal.Internal (SqlSelect) -import Database.Persist.Monad -import Database.Persist.Sqlite hiding - ( delete - , deleteWhere - , insert - , insertKey - , insert_ - , runMigration - , (==.) - , (||.) - ) -import GHC.Err -import Internal.Types.Main -import Internal.Utils -import RIO hiding (LogFunc, isNothing, on, (^.)) -import RIO.List ((\\)) -import qualified RIO.List as L -import qualified RIO.Map as M -import qualified RIO.NonEmpty as N -import qualified RIO.Text as T - -runDB - :: MonadUnliftIO m - => SqlConfig - -> SqlQueryT (NoLoggingT m) a - -> m a -runDB c more = - runNoLoggingT $ do - pool <- mkPool c - runSqlQueryT pool $ do - _ <- lift askLoggerIO - runMigration migrateAll - more - -mkPool :: (MonadLoggerIO m, MonadUnliftIO m) => SqlConfig -> m ConnectionPool -mkPool c = case c of - Sqlite p -> createSqlitePool p 10 - -- conn <- open p - -- wrapConnection conn logfn - Postgres -> error "postgres not implemented" - -nukeTables :: MonadSqlQuery m => m () -nukeTables = do - deleteWhere ([] :: [Filter CommitR]) - deleteWhere ([] :: [Filter CurrencyR]) - deleteWhere ([] :: [Filter AccountR]) - deleteWhere ([] :: [Filter TransactionR]) - --- showBalances :: MonadUnliftIO m => SqlPersistT m () --- showBalances = do --- xs <- select $ do --- (accounts :& splits :& txs) <- --- from --- $ table @AccountR --- `innerJoin` table @SplitR --- `on` (\(a :& s) -> a ^. AccountRId ==. s ^. SplitRAccount) --- `innerJoin` table @TransactionR --- `on` (\(_ :& s :& t) -> s ^. SplitRTransaction ==. t ^. TransactionRId) --- where_ $ --- isNothing (txs ^. TransactionRBucket) --- &&. ( (accounts ^. AccountRFullpath `like` val "asset" ++. (%)) --- ||. (accounts ^. AccountRFullpath `like` val "liability" ++. (%)) --- ) --- groupBy (accounts ^. AccountRFullpath, accounts ^. AccountRName) --- return --- ( accounts ^. AccountRFullpath --- , accounts ^. AccountRName --- , sum_ $ splits ^. SplitRValue --- ) --- -- TODO super stetchy table printing thingy --- liftIO $ do --- putStrLn $ T.unpack $ fmt "Account" "Balance" --- putStrLn $ T.unpack $ fmt (T.replicate 60 "-") (T.replicate 15 "-") --- mapM_ (putStrLn . T.unpack . fmtBalance) xs --- where --- fmtBalance (path, name, bal) = fmt (toFullPath path name) (toBal bal) --- fmt a b = T.unwords ["| ", pad 60 a, " | ", pad 15 b, " |"] --- pad n xs = T.append xs $ T.replicate (n - T.length xs) " " --- toFullPath path name = T.unwords [unValue @T.Text path, "/", unValue @T.Text name] --- toBal = maybe "???" (fmtRational 2) . unValue - -hashConfig :: Config -> [Int] -hashConfig - Config_ - { budget = bs - , statements = ss - } = (hash <$> bs) ++ (hash <$> ms) ++ (hash <$> ps) - where - (ms, ps) = partitionEithers $ fmap go ss - go (HistTransfer x) = Left x - go (HistStatement x) = Right x - -setDiff :: Eq a => [a] -> [a] -> ([a], [a]) --- setDiff = setDiff' (==) -setDiff as bs = (as \\ bs, bs \\ as) - --- setDiff' :: Eq a => (a -> b -> Bool) -> [a] -> [b] -> ([a], [b]) --- setDiff' f = go [] --- where --- go inA [] bs = (inA, bs) --- go inA as [] = (as ++ inA, []) --- go inA (a:as) bs = case inB a bs of --- Just bs' -> go inA as bs' --- Nothing -> go (a:inA) as bs --- inB _ [] = Nothing --- inB a (b:bs) --- | f a b = Just bs --- | otherwise = inB a bs - -getDBHashes :: MonadSqlQuery m => m [Int] -getDBHashes = fmap (commitRHash . entityVal) <$> dumpTbl - -nukeDBHash :: MonadSqlQuery m => Int -> m () -nukeDBHash h = deleteE $ do - c <- E.from E.table - E.where_ (c ^. CommitRHash ==. E.val h) - -nukeDBHashes :: MonadSqlQuery m => [Int] -> m () -nukeDBHashes = mapM_ nukeDBHash - -getConfigHashes :: MonadSqlQuery m => Config -> m ([Int], [Int]) -getConfigHashes c = do - let ch = hashConfig c - dh <- getDBHashes - return $ setDiff dh ch - -dumpTbl :: (MonadSqlQuery m, PersistEntity r) => m [Entity r] -dumpTbl = selectE $ E.from E.table - -deleteAccount :: MonadSqlQuery m => Entity AccountR -> m () -deleteAccount e = deleteE $ do - c <- E.from $ E.table @AccountR - E.where_ (c ^. AccountRId ==. E.val k) - where - k = entityKey e - -deleteCurrency :: MonadSqlQuery m => Entity CurrencyR -> m () -deleteCurrency e = deleteE $ do - c <- E.from $ E.table @CurrencyR - E.where_ (c ^. CurrencyRId ==. E.val k) - where - k = entityKey e - -deleteTag :: MonadSqlQuery m => Entity TagR -> m () -deleteTag e = deleteE $ do - c <- E.from $ E.table @TagR - E.where_ (c ^. TagRId ==. E.val k) - where - k = entityKey e - --- TODO slip-n-slide code... -insertFull - :: (PersistRecordBackend r SqlBackend, Typeable r, MonadSqlQuery m) - => Entity r - -> m () -insertFull (Entity k v) = insertKey k v - -currency2Record :: Currency -> Entity CurrencyR -currency2Record c@Currency {curSymbol, curFullname, curPrecision} = - Entity (toKey c) $ CurrencyR curSymbol curFullname (fromIntegral curPrecision) - -currencyMap :: [Entity CurrencyR] -> CurrencyMap -currencyMap = - M.fromList - . fmap - ( \e -> - ( currencyRSymbol $ entityVal e - , (entityKey e, fromIntegral $ currencyRPrecision $ entityVal e) - ) - ) - -toKey :: (ToBackendKey SqlBackend b, Hashable a) => a -> Key b -toKey = toSqlKey . fromIntegral . hash - -tree2Entity :: AcntType -> [T.Text] -> T.Text -> T.Text -> Entity AccountR -tree2Entity t parents name des = - Entity (toSqlKey $ fromIntegral h) $ - AccountR name (toPath parents) des - where - p = AcntPath t (reverse (name : parents)) - h = hash p - toPath = T.intercalate "/" . (atName t :) . reverse - -tree2Records - :: AcntType - -> AccountTree - -> ([Entity AccountR], [AccountPathR], [(AcntPath, (AccountRId, AcntSign, AcntType))]) -tree2Records t = go [] - where - go ps (Placeholder d n cs) = - let e = tree2Entity t (fmap snd ps) n d - k = entityKey e - (as, aps, ms) = L.unzip3 $ fmap (go ((k, n) : ps)) cs - a0 = acnt k n (fmap snd ps) d - paths = expand k $ fmap fst ps - in (a0 : concat as, paths ++ concat aps, concat ms) - go ps (Account d n) = - let e = tree2Entity t (fmap snd ps) n d - k = entityKey e - in ( [acnt k n (fmap snd ps) d] - , expand k $ fmap fst ps - , [(AcntPath t $ reverse $ n : fmap snd ps, (k, sign, t))] - ) - toPath = T.intercalate "/" . (atName t :) . reverse - acnt k n ps = Entity k . AccountR n (toPath ps) - expand h0 hs = (\(h, d) -> AccountPathR h h0 d) <$> zip (h0 : hs) [0 ..] - sign = accountSign t - -paths2IDs :: [(AcntPath, a)] -> [(AcntID, a)] -paths2IDs = - uncurry zip - . first trimNames - . L.unzip - . L.sortOn fst - . fmap (first pathList) - where - pathList (AcntPath t []) = atName t :| [] - pathList (AcntPath t ns) = N.reverse $ atName t :| ns - --- none of these errors should fire assuming that input is sorted and unique -trimNames :: [N.NonEmpty T.Text] -> [AcntID] -trimNames = fmap (T.intercalate "_" . reverse) . trimAll 0 - where - trimAll _ [] = [] - trimAll i (y : ys) = case L.foldl' (matchPre i) (y, [], []) ys of - (a, [], bs) -> reverse $ trim i a : bs - (a, as, bs) -> reverse bs ++ trimAll (i + 1) (reverse $ a : as) - matchPre i (y, ys, old) new = case (y !? i, new !? i) of - (Nothing, Just _) -> - case ys of - [] -> (new, [], trim i y : old) - _ -> err "unsorted input" - (Just _, Nothing) -> err "unsorted input" - (Nothing, Nothing) -> err "duplicated inputs" - (Just a, Just b) - | a == b -> (new, y : ys, old) - | otherwise -> - let next = case ys of - [] -> [trim i y] - _ -> trimAll (i + 1) (reverse $ y : ys) - in (new, [], reverse next ++ old) - trim i = N.take (i + 1) - err msg = errorWithoutStackTrace $ "Import.Database.Ops.hs: " ++ msg - -(!?) :: N.NonEmpty a -> Int -> Maybe a -xs !? n - | n < 0 = Nothing - -- Definition adapted from GHC.List - | otherwise = - foldr - ( \x r k -> case k of - 0 -> Just x - _ -> r (k - 1) - ) - (const Nothing) - xs - n - -flattenAcntRoot :: AccountRoot -> [(AcntType, AccountTree)] -flattenAcntRoot AccountRoot_ {arIncome, arExpenses, arLiabilities, arAssets, arEquity} = - ((IncomeT,) <$> arIncome) - ++ ((ExpenseT,) <$> arExpenses) - ++ ((LiabilityT,) <$> arLiabilities) - ++ ((AssetT,) <$> arAssets) - ++ ((EquityT,) <$> arEquity) - -indexAcntRoot :: AccountRoot -> ([Entity AccountR], [AccountPathR], AccountMap) -indexAcntRoot r = - ( concat ars - , concat aprs - , M.fromList $ paths2IDs $ concat ms - ) - where - (ars, aprs, ms) = L.unzip3 $ uncurry tree2Records <$> flattenAcntRoot r - -getDBState - :: (MonadInsertError m, MonadSqlQuery m) - => Config - -> m (FilePath -> DBState) -getDBState c = do - (del, new) <- getConfigHashes c - -- TODO not sure how I feel about this, probably will change this struct alot - -- in the future so whatever...for now - combineError bi si $ \b s f -> - -- TODO this can be cleaned up, half of it is meant to be queried when - -- determining how to insert budgets/history and the rest is just - -- holdover data to delete upon successful insertion - DBState - { kmCurrency = currencyMap cs - , kmAccount = am - , kmBudgetInterval = b - , kmStatementInterval = s - , kmNewCommits = new - , kmOldCommits = del - , kmConfigDir = f - , kmTag = tagMap ts - , kmTagAll = ts - , kmAcntPaths = paths - , kmAcntsOld = acnts - , kmCurrenciesOld = cs - } - where - bi = liftExcept $ resolveDaySpan $ budgetInterval $ global c - si = liftExcept $ resolveDaySpan $ statementInterval $ global c - (acnts, paths, am) = indexAcntRoot $ accounts c - cs = currency2Record <$> currencies c - ts = toRecord <$> tags c - toRecord t@Tag {tagID, tagDesc} = Entity (toKey t) $ TagR tagID tagDesc - tagMap = M.fromList . fmap (\e -> (tagRSymbol $ entityVal e, entityKey e)) - -updateHashes :: (MonadFinance m, MonadSqlQuery m) => m () -updateHashes = do - old <- askDBState kmOldCommits - nukeDBHashes old - -updateTags :: (MonadFinance m, MonadSqlQuery m) => m () -updateTags = do - tags <- askDBState kmTagAll - tags' <- selectE $ E.from $ E.table @TagR - let (toIns, toDel) = setDiff tags tags' - mapM_ deleteTag toDel - mapM_ insertFull toIns - -updateAccounts :: (MonadFinance m, MonadSqlQuery m) => m () -updateAccounts = do - acnts <- askDBState kmAcntsOld - paths <- askDBState kmAcntPaths - acnts' <- dumpTbl - let (toIns, toDel) = setDiff acnts acnts' - deleteWhere ([] :: [Filter AccountPathR]) - mapM_ deleteAccount toDel - mapM_ insertFull toIns - mapM_ insert paths - -updateCurrencies :: (MonadFinance m, MonadSqlQuery m) => m () -updateCurrencies = do - curs <- askDBState kmCurrenciesOld - curs' <- selectE $ E.from $ E.table @CurrencyR - let (toIns, toDel) = setDiff curs curs' - mapM_ deleteCurrency toDel - mapM_ insertFull toIns - -updateDBState :: (MonadFinance m, MonadSqlQuery m) => m () -updateDBState = do - updateHashes - updateTags - updateAccounts - updateCurrencies - -deleteE :: (MonadSqlQuery m) => E.SqlQuery () -> m () -deleteE q = unsafeLiftSql "esqueleto-delete" (E.delete q) - -selectE :: (MonadSqlQuery m, SqlSelect a r) => E.SqlQuery a -> m [r] -selectE q = unsafeLiftSql "esqueleto-select" (E.select q) - -whenHash - :: (Hashable a, MonadFinance m, MonadSqlQuery m) - => ConfigType - -> a - -> b - -> (CommitRId -> m b) - -> m b -whenHash t o def f = do - let h = hash o - hs <- askDBState kmNewCommits - if h `elem` hs then f =<< insert (CommitR h t) else return def - -whenHash_ - :: (Hashable a, MonadFinance m) - => ConfigType - -> a - -> m b - -> m (Maybe (CommitR, b)) -whenHash_ t o f = do - let h = hash o - let c = CommitR h t - hs <- askDBState kmNewCommits - if h `elem` hs then Just . (c,) <$> f else return Nothing - -insertEntry :: MonadSqlQuery m => TransactionRId -> KeyEntry -> m EntryRId -insertEntry t Entry {eAcnt, eCurrency, eValue, eComment, eTags} = do - k <- insert $ EntryR t eCurrency eAcnt eComment eValue - mapM_ (insert_ . TagRelationR k) eTags - return k - -resolveEntry :: (MonadInsertError m, MonadFinance m) => BalEntry -> m KeyEntry -resolveEntry s@Entry {eAcnt, eCurrency, eValue, eTags} = do - let aRes = lookupAccountKey eAcnt - let cRes = lookupCurrencyKey eCurrency - let sRes = lookupAccountSign eAcnt - let tagRes = combineErrors $ fmap lookupTag eTags - -- TODO correct sign here? - -- TODO lenses would be nice here - combineError (combineError3 aRes cRes sRes (,,)) tagRes $ - \(aid, cid, sign) tags -> - s - { eAcnt = aid - , eCurrency = cid - , eValue = eValue * fromIntegral (sign2Int sign) - , eTags = tags - } diff --git a/lib/Internal/History.hs b/lib/Internal/History.hs index bbf52c9..a537288 100644 --- a/lib/Internal/History.hs +++ b/lib/Internal/History.hs @@ -9,7 +9,7 @@ where import Control.Monad.Except import Data.Csv import Database.Persist.Monad -import Internal.Database.Ops +import Internal.Database import Internal.Types.Main import Internal.Utils import RIO hiding (to) From 5bd3746c3f423e099e8464b7d3413045edbe824b Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Mon, 29 May 2023 18:14:43 -0400 Subject: [PATCH 14/15] REF split db state with stuff to be updated later --- app/Main.hs | 13 +- lib/Internal/Database.hs | 416 +++++++++++++++++++++++++++++++++++++ lib/Internal/History.hs | 23 +- lib/Internal/Types/Main.hs | 14 +- 4 files changed, 446 insertions(+), 20 deletions(-) create mode 100644 lib/Internal/Database.hs diff --git a/app/Main.hs b/app/Main.hs index 69208e7..666c943 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -169,23 +169,26 @@ runSync c = do -- _ <- askLoggerIO -- get the current DB state - s <- runSqlQueryT pool $ do + (state, updates) <- runSqlQueryT pool $ do runMigration migrateAll - fmap (\f -> f $ takeDirectory c) $ liftIOExceptT $ getDBState config + liftIOExceptT $ getDBState config -- read desired statements from disk - bSs <- flip runReaderT s $ catMaybes <$> mapErrorsIO readHistStmt hSs + bSs <- + flip runReaderT state $ + catMaybes <$> mapErrorsIO (readHistStmt root) hSs -- update the DB - runSqlQueryT pool $ withTransaction $ flip runReaderT s $ do + runSqlQueryT pool $ withTransaction $ flip runReaderT state $ do let hTransRes = mapErrors insertHistTransfer hTs let bgtRes = mapErrors insertBudget $ budget config - updateDBState -- TODO this will only work if foreign keys are deferred + updateDBState updates -- TODO this will only work if foreign keys are deferred res <- runExceptT $ do mapM_ (uncurry insertHistStmt) bSs combineError hTransRes bgtRes $ \_ _ -> () rerunnableIO $ fromEither res where + root = takeDirectory c err (InsertException es) = do liftIO $ mapM_ TI.putStrLn $ concatMap showError es exitFailure diff --git a/lib/Internal/Database.hs b/lib/Internal/Database.hs new file mode 100644 index 0000000..0f429a1 --- /dev/null +++ b/lib/Internal/Database.hs @@ -0,0 +1,416 @@ +module Internal.Database + ( runDB + , nukeTables + , updateHashes + , updateDBState + , getDBState + , tree2Records + , flattenAcntRoot + , paths2IDs + , mkPool + , whenHash + , whenHash_ + , insertEntry + , resolveEntry + ) +where + +import Conduit +import Control.Monad.Except +import Control.Monad.Logger +import Data.Hashable +import Database.Esqueleto.Experimental ((==.), (^.)) +import qualified Database.Esqueleto.Experimental as E +import Database.Esqueleto.Internal.Internal (SqlSelect) +import Database.Persist.Monad +import Database.Persist.Sqlite hiding + ( delete + , deleteWhere + , insert + , insertKey + , insert_ + , runMigration + , (==.) + , (||.) + ) +import GHC.Err +import Internal.Types.Main +import Internal.Utils +import RIO hiding (LogFunc, isNothing, on, (^.)) +import RIO.List ((\\)) +import qualified RIO.List as L +import qualified RIO.Map as M +import qualified RIO.NonEmpty as N +import qualified RIO.Text as T + +runDB + :: MonadUnliftIO m + => SqlConfig + -> SqlQueryT (NoLoggingT m) a + -> m a +runDB c more = + runNoLoggingT $ do + pool <- mkPool c + runSqlQueryT pool $ do + _ <- lift askLoggerIO + runMigration migrateAll + more + +mkPool :: (MonadLoggerIO m, MonadUnliftIO m) => SqlConfig -> m ConnectionPool +mkPool c = case c of + Sqlite p -> createSqlitePool p 10 + -- conn <- open p + -- wrapConnection conn logfn + Postgres -> error "postgres not implemented" + +nukeTables :: MonadSqlQuery m => m () +nukeTables = do + deleteWhere ([] :: [Filter CommitR]) + deleteWhere ([] :: [Filter CurrencyR]) + deleteWhere ([] :: [Filter AccountR]) + deleteWhere ([] :: [Filter TransactionR]) + +-- showBalances :: MonadUnliftIO m => SqlPersistT m () +-- showBalances = do +-- xs <- select $ do +-- (accounts :& splits :& txs) <- +-- from +-- $ table @AccountR +-- `innerJoin` table @SplitR +-- `on` (\(a :& s) -> a ^. AccountRId ==. s ^. SplitRAccount) +-- `innerJoin` table @TransactionR +-- `on` (\(_ :& s :& t) -> s ^. SplitRTransaction ==. t ^. TransactionRId) +-- where_ $ +-- isNothing (txs ^. TransactionRBucket) +-- &&. ( (accounts ^. AccountRFullpath `like` val "asset" ++. (%)) +-- ||. (accounts ^. AccountRFullpath `like` val "liability" ++. (%)) +-- ) +-- groupBy (accounts ^. AccountRFullpath, accounts ^. AccountRName) +-- return +-- ( accounts ^. AccountRFullpath +-- , accounts ^. AccountRName +-- , sum_ $ splits ^. SplitRValue +-- ) +-- -- TODO super stetchy table printing thingy +-- liftIO $ do +-- putStrLn $ T.unpack $ fmt "Account" "Balance" +-- putStrLn $ T.unpack $ fmt (T.replicate 60 "-") (T.replicate 15 "-") +-- mapM_ (putStrLn . T.unpack . fmtBalance) xs +-- where +-- fmtBalance (path, name, bal) = fmt (toFullPath path name) (toBal bal) +-- fmt a b = T.unwords ["| ", pad 60 a, " | ", pad 15 b, " |"] +-- pad n xs = T.append xs $ T.replicate (n - T.length xs) " " +-- toFullPath path name = T.unwords [unValue @T.Text path, "/", unValue @T.Text name] +-- toBal = maybe "???" (fmtRational 2) . unValue + +hashConfig :: Config -> [Int] +hashConfig + Config_ + { budget = bs + , statements = ss + } = (hash <$> bs) ++ (hash <$> ms) ++ (hash <$> ps) + where + (ms, ps) = partitionEithers $ fmap go ss + go (HistTransfer x) = Left x + go (HistStatement x) = Right x + +setDiff :: Eq a => [a] -> [a] -> ([a], [a]) +-- setDiff = setDiff' (==) +setDiff as bs = (as \\ bs, bs \\ as) + +-- setDiff' :: Eq a => (a -> b -> Bool) -> [a] -> [b] -> ([a], [b]) +-- setDiff' f = go [] +-- where +-- go inA [] bs = (inA, bs) +-- go inA as [] = (as ++ inA, []) +-- go inA (a:as) bs = case inB a bs of +-- Just bs' -> go inA as bs' +-- Nothing -> go (a:inA) as bs +-- inB _ [] = Nothing +-- inB a (b:bs) +-- | f a b = Just bs +-- | otherwise = inB a bs + +getDBHashes :: MonadSqlQuery m => m [Int] +getDBHashes = fmap (commitRHash . entityVal) <$> dumpTbl + +nukeDBHash :: MonadSqlQuery m => Int -> m () +nukeDBHash h = deleteE $ do + c <- E.from E.table + E.where_ (c ^. CommitRHash ==. E.val h) + +nukeDBHashes :: MonadSqlQuery m => [Int] -> m () +nukeDBHashes = mapM_ nukeDBHash + +getConfigHashes :: MonadSqlQuery m => Config -> m ([Int], [Int]) +getConfigHashes c = do + let ch = hashConfig c + dh <- getDBHashes + return $ setDiff dh ch + +dumpTbl :: (MonadSqlQuery m, PersistEntity r) => m [Entity r] +dumpTbl = selectE $ E.from E.table + +deleteAccount :: MonadSqlQuery m => Entity AccountR -> m () +deleteAccount e = deleteE $ do + c <- E.from $ E.table @AccountR + E.where_ (c ^. AccountRId ==. E.val k) + where + k = entityKey e + +deleteCurrency :: MonadSqlQuery m => Entity CurrencyR -> m () +deleteCurrency e = deleteE $ do + c <- E.from $ E.table @CurrencyR + E.where_ (c ^. CurrencyRId ==. E.val k) + where + k = entityKey e + +deleteTag :: MonadSqlQuery m => Entity TagR -> m () +deleteTag e = deleteE $ do + c <- E.from $ E.table @TagR + E.where_ (c ^. TagRId ==. E.val k) + where + k = entityKey e + +-- TODO slip-n-slide code... +insertFull + :: (PersistRecordBackend r SqlBackend, Typeable r, MonadSqlQuery m) + => Entity r + -> m () +insertFull (Entity k v) = insertKey k v + +currency2Record :: Currency -> Entity CurrencyR +currency2Record c@Currency {curSymbol, curFullname, curPrecision} = + Entity (toKey c) $ CurrencyR curSymbol curFullname (fromIntegral curPrecision) + +currencyMap :: [Entity CurrencyR] -> CurrencyMap +currencyMap = + M.fromList + . fmap + ( \e -> + ( currencyRSymbol $ entityVal e + , (entityKey e, fromIntegral $ currencyRPrecision $ entityVal e) + ) + ) + +toKey :: (ToBackendKey SqlBackend b, Hashable a) => a -> Key b +toKey = toSqlKey . fromIntegral . hash + +tree2Entity :: AcntType -> [T.Text] -> T.Text -> T.Text -> Entity AccountR +tree2Entity t parents name des = + Entity (toSqlKey $ fromIntegral h) $ + AccountR name (toPath parents) des + where + p = AcntPath t (reverse (name : parents)) + h = hash p + toPath = T.intercalate "/" . (atName t :) . reverse + +tree2Records + :: AcntType + -> AccountTree + -> ([Entity AccountR], [AccountPathR], [(AcntPath, (AccountRId, AcntSign, AcntType))]) +tree2Records t = go [] + where + go ps (Placeholder d n cs) = + let e = tree2Entity t (fmap snd ps) n d + k = entityKey e + (as, aps, ms) = L.unzip3 $ fmap (go ((k, n) : ps)) cs + a0 = acnt k n (fmap snd ps) d + paths = expand k $ fmap fst ps + in (a0 : concat as, paths ++ concat aps, concat ms) + go ps (Account d n) = + let e = tree2Entity t (fmap snd ps) n d + k = entityKey e + in ( [acnt k n (fmap snd ps) d] + , expand k $ fmap fst ps + , [(AcntPath t $ reverse $ n : fmap snd ps, (k, sign, t))] + ) + toPath = T.intercalate "/" . (atName t :) . reverse + acnt k n ps = Entity k . AccountR n (toPath ps) + expand h0 hs = (\(h, d) -> AccountPathR h h0 d) <$> zip (h0 : hs) [0 ..] + sign = accountSign t + +paths2IDs :: [(AcntPath, a)] -> [(AcntID, a)] +paths2IDs = + uncurry zip + . first trimNames + . L.unzip + . L.sortOn fst + . fmap (first pathList) + where + pathList (AcntPath t []) = atName t :| [] + pathList (AcntPath t ns) = N.reverse $ atName t :| ns + +-- none of these errors should fire assuming that input is sorted and unique +trimNames :: [N.NonEmpty T.Text] -> [AcntID] +trimNames = fmap (T.intercalate "_" . reverse) . trimAll 0 + where + trimAll _ [] = [] + trimAll i (y : ys) = case L.foldl' (matchPre i) (y, [], []) ys of + (a, [], bs) -> reverse $ trim i a : bs + (a, as, bs) -> reverse bs ++ trimAll (i + 1) (reverse $ a : as) + matchPre i (y, ys, old) new = case (y !? i, new !? i) of + (Nothing, Just _) -> + case ys of + [] -> (new, [], trim i y : old) + _ -> err "unsorted input" + (Just _, Nothing) -> err "unsorted input" + (Nothing, Nothing) -> err "duplicated inputs" + (Just a, Just b) + | a == b -> (new, y : ys, old) + | otherwise -> + let next = case ys of + [] -> [trim i y] + _ -> trimAll (i + 1) (reverse $ y : ys) + in (new, [], reverse next ++ old) + trim i = N.take (i + 1) + err msg = errorWithoutStackTrace $ "Import.Database.Ops.hs: " ++ msg + +(!?) :: N.NonEmpty a -> Int -> Maybe a +xs !? n + | n < 0 = Nothing + -- Definition adapted from GHC.List + | otherwise = + foldr + ( \x r k -> case k of + 0 -> Just x + _ -> r (k - 1) + ) + (const Nothing) + xs + n + +flattenAcntRoot :: AccountRoot -> [(AcntType, AccountTree)] +flattenAcntRoot AccountRoot_ {arIncome, arExpenses, arLiabilities, arAssets, arEquity} = + ((IncomeT,) <$> arIncome) + ++ ((ExpenseT,) <$> arExpenses) + ++ ((LiabilityT,) <$> arLiabilities) + ++ ((AssetT,) <$> arAssets) + ++ ((EquityT,) <$> arEquity) + +indexAcntRoot :: AccountRoot -> ([Entity AccountR], [AccountPathR], AccountMap) +indexAcntRoot r = + ( concat ars + , concat aprs + , M.fromList $ paths2IDs $ concat ms + ) + where + (ars, aprs, ms) = L.unzip3 $ uncurry tree2Records <$> flattenAcntRoot r + +getDBState + :: (MonadInsertError m, MonadSqlQuery m) + => Config + -> m (DBState, DBUpdates) +getDBState c = do + (del, new) <- getConfigHashes c + combineError bi si $ \b s -> + ( DBState + { kmCurrency = currencyMap cs + , kmAccount = am + , kmBudgetInterval = b + , kmStatementInterval = s + , kmTag = tagMap ts + , kmNewCommits = new + } + , DBUpdates + { duOldCommits = del + , duNewTagIds = ts + , duNewAcntPaths = paths + , duNewAcntIds = acnts + , duNewCurrencyIds = cs + } + ) + where + bi = liftExcept $ resolveDaySpan $ budgetInterval $ global c + si = liftExcept $ resolveDaySpan $ statementInterval $ global c + (acnts, paths, am) = indexAcntRoot $ accounts c + cs = currency2Record <$> currencies c + ts = toRecord <$> tags c + toRecord t@Tag {tagID, tagDesc} = Entity (toKey t) $ TagR tagID tagDesc + tagMap = M.fromList . fmap (\e -> (tagRSymbol $ entityVal e, entityKey e)) + +updateHashes :: (MonadSqlQuery m) => DBUpdates -> m () +updateHashes DBUpdates {duOldCommits} = nukeDBHashes duOldCommits + +updateTags :: (MonadFinance m, MonadSqlQuery m) => DBUpdates -> m () +updateTags DBUpdates {duNewTagIds} = do + tags' <- selectE $ E.from $ E.table @TagR + let (toIns, toDel) = setDiff duNewTagIds tags' + mapM_ deleteTag toDel + mapM_ insertFull toIns + +updateAccounts :: (MonadFinance m, MonadSqlQuery m) => DBUpdates -> m () +updateAccounts DBUpdates {duNewAcntIds, duNewAcntPaths} = do + acnts' <- dumpTbl + let (toIns, toDel) = setDiff duNewAcntIds acnts' + deleteWhere ([] :: [Filter AccountPathR]) + mapM_ deleteAccount toDel + mapM_ insertFull toIns + mapM_ insert duNewAcntPaths + +updateCurrencies :: (MonadFinance m, MonadSqlQuery m) => DBUpdates -> m () +updateCurrencies DBUpdates {duNewCurrencyIds} = do + curs' <- selectE $ E.from $ E.table @CurrencyR + let (toIns, toDel) = setDiff duNewCurrencyIds curs' + mapM_ deleteCurrency toDel + mapM_ insertFull toIns + +updateDBState :: (MonadFinance m, MonadSqlQuery m) => DBUpdates -> m () +updateDBState u = do + updateHashes u + updateTags u + updateAccounts u + updateCurrencies u + +deleteE :: (MonadSqlQuery m) => E.SqlQuery () -> m () +deleteE q = unsafeLiftSql "esqueleto-delete" (E.delete q) + +selectE :: (MonadSqlQuery m, SqlSelect a r) => E.SqlQuery a -> m [r] +selectE q = unsafeLiftSql "esqueleto-select" (E.select q) + +whenHash + :: (Hashable a, MonadFinance m, MonadSqlQuery m) + => ConfigType + -> a + -> b + -> (CommitRId -> m b) + -> m b +whenHash t o def f = do + let h = hash o + hs <- askDBState kmNewCommits + if h `elem` hs then f =<< insert (CommitR h t) else return def + +whenHash_ + :: (Hashable a, MonadFinance m) + => ConfigType + -> a + -> m b + -> m (Maybe (CommitR, b)) +whenHash_ t o f = do + let h = hash o + let c = CommitR h t + hs <- askDBState kmNewCommits + if h `elem` hs then Just . (c,) <$> f else return Nothing + +insertEntry :: MonadSqlQuery m => TransactionRId -> KeyEntry -> m EntryRId +insertEntry t Entry {eAcnt, eCurrency, eValue, eComment, eTags} = do + k <- insert $ EntryR t eCurrency eAcnt eComment eValue + mapM_ (insert_ . TagRelationR k) eTags + return k + +resolveEntry :: (MonadInsertError m, MonadFinance m) => BalEntry -> m KeyEntry +resolveEntry s@Entry {eAcnt, eCurrency, eValue, eTags} = do + let aRes = lookupAccountKey eAcnt + let cRes = lookupCurrencyKey eCurrency + let sRes = lookupAccountSign eAcnt + let tagRes = combineErrors $ fmap lookupTag eTags + -- TODO correct sign here? + -- TODO lenses would be nice here + combineError (combineError3 aRes cRes sRes (,,)) tagRes $ + \(aid, cid, sign) tags -> + s + { eAcnt = aid + , eCurrency = cid + , eValue = eValue * fromIntegral (sign2Int sign) + , eTags = tags + } diff --git a/lib/Internal/History.hs b/lib/Internal/History.hs index a537288..2b34f0f 100644 --- a/lib/Internal/History.hs +++ b/lib/Internal/History.hs @@ -49,9 +49,13 @@ insertHistTransfer mapM_ (insertTx c) keys void $ combineErrors $ fmap go amts -readHistStmt :: (MonadUnliftIO m, MonadFinance m) => Statement -> m (Maybe (CommitR, [KeyTx])) -readHistStmt i = whenHash_ CTImport i $ do - bs <- readImport i +readHistStmt + :: (MonadUnliftIO m, MonadFinance m) + => FilePath + -> Statement + -> m (Maybe (CommitR, [KeyTx])) +readHistStmt root i = whenHash_ CTImport i $ do + bs <- readImport root i bounds <- askDBState kmStatementInterval liftIOExceptT $ mapErrors resolveTx $ filter (inDaySpan bounds . txDate) bs @@ -105,29 +109,30 @@ insertTx c Tx {txDate = d, txDescr = e, txEntries = ss} = do -- 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 +readImport :: (MonadUnliftIO m, MonadFinance m) => FilePath -> Statement -> m [BalTx] +readImport root 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 + records <- L.sort . concat <$> mapErrorsIO readStmt paths m <- askDBState kmCurrency fromEither $ flip runReader m $ runExceptT $ matchRecords compiledMatches records + where + paths = (root ) <$> stmtPaths readImport_ - :: (MonadUnliftIO m, MonadFinance m) + :: MonadUnliftIO m => Natural -> Word -> TxOptsRe -> FilePath -> m [TxRecord] readImport_ n delim tns p = do - dir <- askDBState kmConfigDir - res <- tryIO $ BL.readFile $ dir p + res <- tryIO $ BL.readFile 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] diff --git a/lib/Internal/Types/Main.hs b/lib/Internal/Types/Main.hs index 9605d41..3be6ee7 100644 --- a/lib/Internal/Types/Main.hs +++ b/lib/Internal/Types/Main.hs @@ -47,12 +47,14 @@ data DBState = DBState , kmBudgetInterval :: !DaySpan , kmStatementInterval :: !DaySpan , kmNewCommits :: ![Int] - , kmOldCommits :: ![Int] - , kmConfigDir :: !FilePath - , kmTagAll :: ![Entity TagR] - , kmAcntPaths :: ![AccountPathR] - , kmAcntsOld :: ![Entity AccountR] - , kmCurrenciesOld :: ![Entity CurrencyR] + } + +data DBUpdates = DBUpdates + { duOldCommits :: ![Int] + , duNewTagIds :: ![Entity TagR] + , duNewAcntPaths :: ![AccountPathR] + , duNewAcntIds :: ![Entity AccountR] + , duNewCurrencyIds :: ![Entity CurrencyR] } type CurrencyM = Reader CurrencyMap From 90ff12e7e4cf8bf6e115f49d792518d08b7eb7c9 Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Mon, 29 May 2023 18:15:01 -0400 Subject: [PATCH 15/15] ENH update dhall type --- dhall/Types.dhall | 1 + 1 file changed, 1 insertion(+) diff --git a/dhall/Types.dhall b/dhall/Types.dhall index b710ab4..2e584b2 100644 --- a/dhall/Types.dhall +++ b/dhall/Types.dhall @@ -1018,6 +1018,7 @@ let Budget = , bgtPosttax : List (MultiAllocation PosttaxValue) , bgtTransfers : List BudgetTransfer , bgtShadowTransfers : List ShadowTransfer + , bgtInterval : Optional Interval } in { CurID