diff --git a/app/Main.hs b/app/Main.hs index 336fdda..7a98ed8 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -163,25 +163,26 @@ runDumpAccountKeys c = do runSync :: FilePath -> IO () runSync c = do config <- readConfig c - let (hTs, hSs) = splitHistory $ statements config pool <- runNoLoggingT $ mkPool $ sqlConfig config handle err $ do -- _ <- askLoggerIO - -- get the current DB state + -- Get the current DB state. (state, updates) <- runSqlQueryT pool $ do runMigration migrateAll liftIOExceptT $ getDBState config - -- read desired statements from disk + -- Read raw transactions according to state. If a transaction is already in + -- the database, don't read it but record the commit so we can update it. (rus, is) <- flip runReaderT state $ do + let (hTs, hSs) = splitHistory $ statements config hSs' <- mapErrorsIO (readHistStmt root) hSs hTs' <- liftIOExceptT $ mapErrors readHistTransfer hTs bTs <- liftIOExceptT $ mapErrors readBudget $ budget config return $ second concat $ partitionEithers $ hSs' ++ hTs' ++ bTs - -- update the DB + -- Update the DB. runSqlQueryT pool $ withTransaction $ flip runReaderT state $ do res <- runExceptT $ do -- TODO taking out the hash is dumb diff --git a/lib/Internal/Budget.hs b/lib/Internal/Budget.hs index 22d5179..78a10a4 100644 --- a/lib/Internal/Budget.hs +++ b/lib/Internal/Budget.hs @@ -3,7 +3,6 @@ module Internal.Budget (readBudget) where import Control.Monad.Except import Data.Foldable import Internal.Database -import Internal.History import Internal.Types.Main import Internal.Utils import RIO hiding (to) @@ -13,17 +12,6 @@ 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 --- 5. insert all transactions - readBudget :: (MonadInsertError m, MonadFinance m) => Budget @@ -47,7 +35,7 @@ readBudget (intAllos, _) <- combineError intAlloRes acntRes (,) let tc = BudgetCommit key bgtLabel let res1 = mapErrors (readIncome tc intAllos budgetSpan) bgtIncomes - let res2 = expandTransfers tc (Just budgetSpan) bgtTransfers + let res2 = expandTransfers tc budgetSpan bgtTransfers txs <- combineError (concat <$> res1) res2 (++) shadow <- addShadowTransfers bgtShadowTransfers txs return $ txs ++ shadow @@ -354,9 +342,6 @@ allocatePost precision aftertax = fmap (fmap go) then aftertax * roundPrecision 3 v / 100 else roundPrecision precision v --------------------------------------------------------------------------------- --- Standalone Transfer - -------------------------------------------------------------------------------- -- shadow transfers @@ -403,12 +388,6 @@ shadowMatches TransferMatcher {tmFrom, tmTo, tmDate} Tx {txPrimary, txDate} = do alloAcnt :: Allocation w v -> AcntID alloAcnt = taAcnt . alloTo -data UnbalancedValue = UnbalancedValue - { cvType :: !TransferType - , cvValue :: !Rational - } - deriving (Show) - type IntAllocations = ( [DaySpanAllocation PretaxValue] , [DaySpanAllocation TaxValue] diff --git a/lib/Internal/Database.hs b/lib/Internal/Database.hs index 12fd398..7617512 100644 --- a/lib/Internal/Database.hs +++ b/lib/Internal/Database.hs @@ -15,6 +15,8 @@ module Internal.Database , insertEntry , resolveEntry , readUpdates + , insertAll + , updateTx ) where @@ -33,6 +35,7 @@ import Database.Persist.Sqlite hiding , insertKey , insert_ , runMigration + , update , (==.) , (||.) ) @@ -598,3 +601,33 @@ makeRoUE e = makeUE () e $ StaticValue (entryRValue e) makeUnkUE :: EntryRId -> EntryR -> UpdateEntry EntryRId () makeUnkUE k e = makeUE k e () + +insertAll + :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m) + => [EntryBin] + -> m () +insertAll ebs = do + (toUpdate, toInsert) <- balanceTxs ebs + mapM_ updateTx toUpdate + forM_ (groupWith itxCommit toInsert) $ + \(c, ts) -> do + ck <- insert $ getCommit c + mapM_ (insertTx ck) ts + where + getCommit (HistoryCommit c) = c + getCommit (BudgetCommit c _) = c + +insertTx :: MonadSqlQuery m => CommitRId -> InsertTx -> m () +insertTx c InsertTx {itxDate, itxDescr, itxEntries, itxCommit} = do + let anyDeferred = any (isJust . feDeferred) itxEntries + k <- insert $ TransactionR c itxDate itxDescr anyDeferred + mapM_ (go k) itxEntries + where + go k tx = do + ek <- insertEntry k tx + case itxCommit of + BudgetCommit _ name -> insert_ $ BudgetLabelR ek name + _ -> return () + +updateTx :: MonadSqlQuery m => UEBalanced -> m () +updateTx UpdateEntry {ueID, ueValue} = update ueID [EntryRValue =. unStaticValue ueValue] diff --git a/lib/Internal/History.hs b/lib/Internal/History.hs index a586ec5..3b7176f 100644 --- a/lib/Internal/History.hs +++ b/lib/Internal/History.hs @@ -1,21 +1,13 @@ module Internal.History ( readHistStmt , readHistTransfer - , insertAll , splitHistory - , balanceTxs - , updateTx - , entryPair_ - , expandTransfers - , entryPair ) where import Control.Monad.Except import Data.Csv import Data.Foldable -import Database.Persist ((=.)) -import Database.Persist.Monad hiding (get) import Internal.Database import Internal.Types.Main import Internal.Utils @@ -24,20 +16,32 @@ 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.NonEmpty as NE -import RIO.State import qualified RIO.Text as T import RIO.Time import qualified RIO.Vector as V --- TODO unify this with the transfer system I use in the budget now +-- NOTE keep statement and transfer readers separate because the former needs +-- the IO monad, and thus will throw IO errors rather than using the ExceptT +-- thingy +splitHistory :: [History] -> ([PairedTransfer], [Statement]) +splitHistory = partitionEithers . fmap go + where + go (HistTransfer x) = Left x + go (HistStatement x) = Right x + +-------------------------------------------------------------------------------- +-- Transfers + readHistTransfer :: (MonadInsertError m, MonadFinance m) => PairedTransfer -> m (Either CommitR [Tx TxCommit]) readHistTransfer ht = eitherHash CTManual ht return $ \c -> do bounds <- askDBState kmStatementInterval - expandTransfer (HistoryCommit c) (Just bounds) ht + expandTransfer (HistoryCommit c) bounds ht + +-------------------------------------------------------------------------------- +-- Statements readHistStmt :: (MonadUnliftIO m, MonadFinance m) @@ -49,172 +53,6 @@ readHistStmt root i = eitherHash CTImport i return $ \c -> do bounds <- askDBState kmStatementInterval return $ filter (inDaySpan bounds . txDate) $ fmap (\t -> t {txCommit = HistoryCommit c}) bs -splitHistory :: [History] -> ([PairedTransfer], [Statement]) -splitHistory = partitionEithers . fmap go - where - go (HistTransfer x) = Left x - go (HistStatement x) = Right x - -insertAll - :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m) - => [EntryBin] - -> m () -insertAll ebs = do - (toUpdate, toInsert) <- balanceTxs ebs - mapM_ updateTx toUpdate - forM_ (groupWith itxCommit toInsert) $ - \(c, ts) -> do - ck <- insert $ getCommit c - mapM_ (insertTx ck) ts - where - getCommit (HistoryCommit c) = c - getCommit (BudgetCommit c _) = c - -insertTx :: MonadSqlQuery m => CommitRId -> InsertTx -> m () -insertTx c InsertTx {itxDate, itxDescr, itxEntries, itxCommit} = do - let anyDeferred = any (isJust . feDeferred) itxEntries - k <- insert $ TransactionR c itxDate itxDescr anyDeferred - mapM_ (go k) itxEntries - where - go k tx = do - ek <- insertEntry k tx - case itxCommit of - BudgetCommit _ name -> insert_ $ BudgetLabelR ek name - _ -> return () - -updateTx :: MonadSqlQuery m => UEBalanced -> m () -updateTx UpdateEntry {ueID, ueValue} = update ueID [EntryRValue =. unStaticValue ueValue] - --------------------------------------------------------------------------------- --- low-level transaction stuff - -expandTransfers - :: (MonadInsertError m, MonadFinance m) - => TxCommit - -> Maybe DaySpan - -> [PairedTransfer] - -> m [Tx TxCommit] -expandTransfers tc localInterval ts = - fmap (L.sortOn txDate . concat) $ - combineErrors $ - fmap (expandTransfer tc localInterval) ts - -expandTransfer - :: (MonadInsertError m, MonadFinance m) - => TxCommit - -> Maybe DaySpan - -> PairedTransfer - -> m [Tx TxCommit] -expandTransfer tc ds Transfer {transAmounts, transTo, transCurrency, transFrom} = do - txs <- concat <$> mapErrors go transAmounts - return $ case ds of - Nothing -> txs - Just bounds -> filter (inDaySpan bounds . txDate) txs - where - go - Amount - { amtWhen = pat - , amtValue = TransferValue {tvVal = v, tvType = t} - , amtDesc = desc - } = - withDates pat $ \day -> do - p <- entryPair_ (\_ x -> EntryValue t $ toRational x) transFrom transTo transCurrency desc v - return - Tx - { txCommit = tc - , txDate = day - , txPrimary = p - , txOther = [] - , txDescr = desc - } - -entryPair - :: (MonadInsertError m, MonadFinance m) - => TaggedAcnt - -> TaggedAcnt - -> CurID - -> T.Text - -> Double - -> m (EntrySet AcntID CurrencyPrec TagID Rational (EntryValue Rational)) -entryPair = entryPair_ (fmap (EntryValue TFixed) . roundPrecisionCur) - -entryPair_ - :: (MonadInsertError m, MonadFinance m) - => (CurrencyPrec -> v -> v') - -> TaggedAcnt - -> TaggedAcnt - -> CurID - -> T.Text - -> v - -> m (EntrySet AcntID CurrencyPrec TagID Rational v') -entryPair_ f from to curid com val = do - cp <- lookupCurrency curid - return $ pair cp from to (f cp val) - where - halfEntry :: a -> [t] -> HalfEntrySet a c t v - halfEntry a ts = - HalfEntrySet - { hesPrimary = Entry {eAcnt = a, eValue = (), eComment = com, eTags = ts} - , hesOther = [] - } - pair cp (TaggedAcnt fa fts) (TaggedAcnt ta tts) v = - EntrySet - { esCurrency = cp - , esTotalValue = v - , esFrom = halfEntry fa fts - , esTo = halfEntry ta tts - } - -withDates - :: (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 - --- -- TODO tags here? --- txPair --- :: CommitR --- -> Day --- -> AcntID --- -> AcntID --- -> CurrencyPrec --- -> TransferValue --- -> T.Text --- -> Tx TxCommit --- txPair commit day from to cur (TransferValue t v) desc = --- Tx --- { txDescr = desc --- , txDate = day --- , txCommit = HistoryCommit commit --- , txPrimary = --- EntrySet --- { esTotalValue = EntryValue t $ toRational v --- , esCurrency = cur --- , esFrom = HalfEntrySet {hesPrimary = entry from, hesOther = []} --- , esTo = HalfEntrySet {hesPrimary = entry to, hesOther = []} --- } --- , txOther = [] --- } --- where --- entry a = --- Entry --- { eAcnt = a --- , eValue = () --- , eComment = "" --- , eTags = [] --- } - --- resolveTx :: (MonadInsertError m, MonadFinance m) => BalTx CommitR -> m (KeyTx CommitR) --- resolveTx t@Tx {txEntries = ss} = --- (\kss -> t {txEntries = kss}) <$> mapErrors resolveEntry ss - --------------------------------------------------------------------------------- --- Statements - -- TODO this probably won't scale well (pipes?) readImport :: (MonadUnliftIO m, MonadFinance m) => FilePath -> Statement -> m [Tx ()] readImport root Statement {stmtTxOpts, stmtParsers, stmtSkipLines, stmtDelim, stmtPaths} = do @@ -423,279 +261,3 @@ matchNonDates ms = go ([], [], initZipper ms) MatchSkip -> (Nothing : matched, unmatched) MatchFail -> (matched, r : unmatched) in go (m, u, resetZipper z') rs - -balanceTxs - :: (MonadInsertError m, MonadFinance m) - => [EntryBin] - -> m ([UEBalanced], [InsertTx]) -balanceTxs ebs = - first concat . partitionEithers . catMaybes - <$> evalStateT (mapErrors go $ L.sortOn binDate ebs) M.empty - where - go (ToUpdate utx) = fmap (Just . Left) $ liftInnerS $ rebalanceEntrySet utx - go (ToRead ReadEntry {reCurrency, reAcnt, reValue}) = do - modify $ mapAdd_ (reAcnt, reCurrency) reValue - return Nothing - go (ToInsert Tx {txPrimary, txOther, txDescr, txCommit, txDate}) = do - e <- balanceEntrySet primaryBalance txPrimary - -- TODO this logic is really stupid, I'm balancing the total twice; fix - -- will likely entail making a separate data structure for txs derived - -- from transfers vs statements - let etot = sum $ eValue . feEntry <$> filter ((< 0) . feIndex) e - es <- mapErrors (balanceEntrySet (secondaryBalance etot)) txOther - let tx = - InsertTx - { itxDescr = txDescr - , itxDate = txDate - , itxEntries = concat $ e : es - , itxCommit = txCommit - } - return $ Just $ Right tx - primaryBalance Entry {eAcnt} c (EntryValue t v) = findBalance eAcnt c t v - secondaryBalance tot Entry {eAcnt} c val = case val of - Right (EntryValue t v) -> findBalance eAcnt c t v - Left v -> return $ toRational v * tot - -binDate :: EntryBin -> Day -binDate (ToUpdate UpdateEntrySet {utDate}) = utDate -binDate (ToRead ReadEntry {reDate}) = reDate -binDate (ToInsert Tx {txDate}) = txDate - -type EntryBals = M.Map (AccountRId, CurrencyRId) Rational - -data UpdateEntryType a - = UET_ReadOnly UE_RO - | UET_Unk UEUnk - | UET_Linked a - --- TODO make sure new values are rounded properly here -rebalanceEntrySet :: UpdateEntrySet -> State EntryBals [UEBalanced] -rebalanceEntrySet - UpdateEntrySet - { utFrom0 - , utTo0 - , utPairs - , utFromUnk - , utToUnk - , utFromRO - , utToRO - , utCurrency - , utToUnkLink0 - , utTotalValue - } = - do - (f0val, (tpairs, fs)) <- - fmap (second partitionEithers) $ - foldM goFrom (utTotalValue, []) $ - L.sortOn idx $ - (UET_ReadOnly <$> utFromRO) - ++ (UET_Unk <$> utFromUnk) - ++ (UET_Linked <$> utPairs) - let f0 = utFrom0 {ueValue = StaticValue f0val} - let tsLink0 = fmap (unlink (-f0val)) utToUnkLink0 - (t0val, tsUnk) <- - fmap (second catMaybes) $ - foldM goTo (-utTotalValue, []) $ - L.sortOn idx2 $ - (UET_Linked <$> (tpairs ++ tsLink0)) - ++ (UET_Unk <$> utToUnk) - ++ (UET_ReadOnly <$> utToRO) - let t0 = utTo0 {ueValue = StaticValue t0val} - return (f0 : fs ++ (t0 : tsUnk)) - where - project f _ _ (UET_ReadOnly e) = f e - project _ f _ (UET_Unk e) = f e - project _ _ f (UET_Linked p) = f p - idx = project ueIndex ueIndex (ueIndex . fst) - idx2 = project ueIndex ueIndex ueIndex - -- TODO the sum accumulator thing is kinda awkward - goFrom (tot, es) (UET_ReadOnly e) = do - v <- updateFixed e - return (tot - v, es) - goFrom (tot, esPrev) (UET_Unk e) = do - v <- updateUnknown e - return (tot - v, Right e {ueValue = StaticValue v} : esPrev) - goFrom (tot, esPrev) (UET_Linked (e0, es)) = do - v <- updateUnknown e0 - let e0' = Right $ e0 {ueValue = StaticValue v} - let es' = fmap (Left . unlink (-v)) es - return (tot - v, (e0' : es') ++ esPrev) - goTo (tot, esPrev) (UET_ReadOnly e) = do - v <- updateFixed e - return (tot - v, esPrev) - goTo (tot, esPrev) (UET_Linked e) = do - v <- updateFixed e - return (tot - v, Just e : esPrev) - goTo (tot, esPrev) (UET_Unk e) = do - v <- updateUnknown e - return (tot - v, Just e {ueValue = StaticValue v} : esPrev) - updateFixed :: UpdateEntry i StaticValue -> State EntryBals Rational - updateFixed e = do - let v = unStaticValue $ ueValue e - modify $ mapAdd_ (ueAcnt e, utCurrency) v - return v - updateUnknown e = do - let key = (ueAcnt e, utCurrency) - curBal <- gets (M.findWithDefault 0 key) - let v = case ueValue e of - EVPercent p -> p * curBal - EVBalance p -> p - curBal - modify $ mapAdd_ key v - return v - unlink v e = e {ueValue = StaticValue $ v * unLinkScale (ueValue e)} - -balanceEntrySet - :: (MonadInsertError m, MonadFinance m) - => (Entry AccountRId AcntSign TagRId -> CurrencyRId -> v -> State EntryBals Rational) - -> DeferredEntrySet v - -> StateT EntryBals m [KeyEntry] -balanceEntrySet - findTot - EntrySet - { esFrom = HalfEntrySet {hesPrimary = f0, hesOther = fs} - , esTo = HalfEntrySet {hesPrimary = t0, hesOther = ts} - , esCurrency = CurrencyPrec {cpID = curID, cpPrec = precision} - , esTotalValue - } = - do - -- 1. Resolve tag and accout ids in primary entries since we (might) need - -- them later to calculate the total value of the transaction. - let f0res = resolveAcntAndTags f0 - let t0res = resolveAcntAndTags t0 - combineErrorM f0res t0res $ \f0' t0' -> do - -- 2. Compute total value of transaction using the primary debit entry - tot <- liftInnerS $ findTot f0' curID esTotalValue - - -- 3. Balance all debit entries (including primary). Note the negative - -- indices, which will signify them to be debit entries when updated - -- later. - let balFromEntry = balanceEntry (\a -> liftInnerS . balanceDeferred curID a) curID - fs' <- doEntries balFromEntry curID tot f0' fs (NE.iterate (+ (-1)) (-1)) - - -- 4. Build an array of debit values be linked as desired in credit entries - let fv = V.fromList $ fmap (eValue . feEntry) fs' - - -- 4. Balance credit entries (including primary) analogously. - let balToEntry = balanceEntry (balanceLinked fv curID precision) curID - ts' <- doEntries balToEntry curID (-tot) t0' ts (NE.iterate (+ 1) 0) - return $ fs' ++ ts' - -doEntries - :: (MonadInsertError m) - => (Int -> Entry AcntID v TagID -> StateT EntryBals m (InsertEntry AccountRId CurrencyRId TagRId)) - -> CurrencyRId - -> Rational - -> Entry AccountRId AcntSign TagRId - -> [Entry AcntID v TagID] - -> NonEmpty Int - -> StateT EntryBals m [InsertEntry AccountRId CurrencyRId TagRId] -doEntries f curID tot e es (i0 :| iN) = do - es' <- mapErrors (uncurry f) $ zip iN es - let e0val = tot - entrySum es' - -- TODO not dry - let s = fromIntegral $ sign2Int (eValue e) -- NOTE hack - modify (mapAdd_ (eAcnt e, curID) tot) - let e' = - InsertEntry - { feEntry = e {eValue = s * e0val} - , feCurrency = curID - , feDeferred = Nothing - , feIndex = i0 - } - return $ e' : es' - where - entrySum = sum . fmap (eValue . feEntry) - -liftInnerS :: Monad m => StateT e Identity a -> StateT e m a -liftInnerS = mapStateT (return . runIdentity) - -balanceLinked - :: MonadInsertError m - => Vector Rational - -> CurrencyRId - -> Natural - -> AccountRId - -> LinkDeferred Rational - -> StateT EntryBals m (Rational, Maybe DBDeferred) -balanceLinked from curID precision acntID lg = case lg of - (LinkIndex LinkedNumGetter {lngIndex, lngScale}) -> do - let res = fmap (go lngScale) $ from V.!? fromIntegral lngIndex - case res of - Just v -> return (v, Just $ EntryLinked lngIndex $ toRational lngScale) - -- TODO this error would be much more informative if I had access to the - -- file from which it came - Nothing -> throwError undefined - (LinkDeferred d) -> liftInnerS $ balanceDeferred curID acntID d - where - go s = roundPrecision precision . (* s) . fromRational - -balanceDeferred - :: CurrencyRId - -> AccountRId - -> EntryValue Rational - -> State EntryBals (Rational, Maybe DBDeferred) -balanceDeferred curID acntID (EntryValue t v) = do - newval <- findBalance acntID curID t v - let d = case t of - TFixed -> Nothing - TBalance -> Just $ EntryBalance v - TPercent -> Just $ EntryPercent v - return (newval, d) - -balanceEntry - :: (MonadInsertError m, MonadFinance m) - => (AccountRId -> v -> StateT EntryBals m (Rational, Maybe DBDeferred)) - -> CurrencyRId - -> Int - -> Entry AcntID v TagID - -> StateT EntryBals m (InsertEntry AccountRId CurrencyRId TagRId) -balanceEntry f curID idx e@Entry {eValue, eAcnt, eTags} = do - let acntRes = lookupAccount eAcnt - let tagRes = mapErrors lookupTag eTags - combineErrorM acntRes tagRes $ \(acntID, sign, _) tags -> do - let s = fromIntegral $ sign2Int sign - (newVal, deferred) <- f acntID eValue - modify (mapAdd_ (acntID, curID) newVal) - return $ - InsertEntry - { feEntry = e {eValue = s * newVal, eAcnt = acntID, eTags = tags} - , feCurrency = curID - , feDeferred = deferred - , feIndex = idx - } - -resolveAcntAndTags - :: (MonadInsertError m, MonadFinance m) - => Entry AcntID v TagID - -> m (Entry AccountRId AcntSign TagRId) -resolveAcntAndTags e@Entry {eAcnt, eTags} = do - let acntRes = lookupAccount eAcnt - let tagRes = mapErrors lookupTag eTags - -- TODO total hack, store account sign in the value field so I don't need to - -- make seperate tuple pair thing to haul it around. Weird, but it works. - combineError acntRes tagRes $ - \(acntID, sign, _) tags -> e {eAcnt = acntID, eTags = tags, eValue = sign} - -findBalance - :: AccountRId - -> CurrencyRId - -> TransferType - -> Rational - -> State EntryBals Rational -findBalance acnt cur t v = do - curBal <- gets (M.findWithDefault 0 (acnt, cur)) - return $ case t of - TBalance -> v - curBal - TPercent -> v * curBal - TFixed -> v - --- -- reimplementation from future version :/ --- mapAccumM --- :: Monad m --- => (s -> a -> m (s, b)) --- -> s --- -> [a] --- -> m (s, [b]) --- mapAccumM f s xs = foldrM go (s, []) xs --- where --- go x (s', acc) = second (: acc) <$> f s' x diff --git a/lib/Internal/Utils.hs b/lib/Internal/Utils.hs index bab86fd..059cd10 100644 --- a/lib/Internal/Utils.hs +++ b/lib/Internal/Utils.hs @@ -60,6 +60,11 @@ module Internal.Utils , mapAdd_ , groupKey , groupWith + , balanceTxs + , expandTransfers + , expandTransfer + , entryPair + , entryPair_ ) where @@ -72,8 +77,10 @@ import RIO import qualified RIO.List as L import qualified RIO.Map as M import qualified RIO.NonEmpty as NE +import RIO.State import qualified RIO.Text as T import RIO.Time +import qualified RIO.Vector as V import Text.Regex.TDFA import Text.Regex.TDFA.Text @@ -1021,3 +1028,350 @@ lookupFinance -> T.Text -> m a lookupFinance t f c = (liftExcept . lookupErr (DBKey t) c) =<< askDBState f + +balanceTxs + :: (MonadInsertError m, MonadFinance m) + => [EntryBin] + -> m ([UEBalanced], [InsertTx]) +balanceTxs ebs = + first concat . partitionEithers . catMaybes + <$> evalStateT (mapErrors go $ L.sortOn binDate ebs) M.empty + where + go (ToUpdate utx) = fmap (Just . Left) $ liftInnerS $ rebalanceEntrySet utx + go (ToRead ReadEntry {reCurrency, reAcnt, reValue}) = do + modify $ mapAdd_ (reAcnt, reCurrency) reValue + return Nothing + go (ToInsert Tx {txPrimary, txOther, txDescr, txCommit, txDate}) = do + e <- balanceEntrySet primaryBalance txPrimary + -- TODO this logic is really stupid, I'm balancing the total twice; fix + -- will likely entail making a separate data structure for txs derived + -- from transfers vs statements + let etot = sum $ eValue . feEntry <$> filter ((< 0) . feIndex) e + es <- mapErrors (balanceEntrySet (secondaryBalance etot)) txOther + let tx = + InsertTx + { itxDescr = txDescr + , itxDate = txDate + , itxEntries = concat $ e : es + , itxCommit = txCommit + } + return $ Just $ Right tx + primaryBalance Entry {eAcnt} c (EntryValue t v) = findBalance eAcnt c t v + secondaryBalance tot Entry {eAcnt} c val = case val of + Right (EntryValue t v) -> findBalance eAcnt c t v + Left v -> return $ toRational v * tot + +binDate :: EntryBin -> Day +binDate (ToUpdate UpdateEntrySet {utDate}) = utDate +binDate (ToRead ReadEntry {reDate}) = reDate +binDate (ToInsert Tx {txDate}) = txDate + +type EntryBals = M.Map (AccountRId, CurrencyRId) Rational + +data UpdateEntryType a + = UET_ReadOnly UE_RO + | UET_Unk UEUnk + | UET_Linked a + +-- TODO make sure new values are rounded properly here +rebalanceEntrySet :: UpdateEntrySet -> State EntryBals [UEBalanced] +rebalanceEntrySet + UpdateEntrySet + { utFrom0 + , utTo0 + , utPairs + , utFromUnk + , utToUnk + , utFromRO + , utToRO + , utCurrency + , utToUnkLink0 + , utTotalValue + } = + do + (f0val, (tpairs, fs)) <- + fmap (second partitionEithers) $ + foldM goFrom (utTotalValue, []) $ + L.sortOn idx $ + (UET_ReadOnly <$> utFromRO) + ++ (UET_Unk <$> utFromUnk) + ++ (UET_Linked <$> utPairs) + let f0 = utFrom0 {ueValue = StaticValue f0val} + let tsLink0 = fmap (unlink (-f0val)) utToUnkLink0 + (t0val, tsUnk) <- + fmap (second catMaybes) $ + foldM goTo (-utTotalValue, []) $ + L.sortOn idx2 $ + (UET_Linked <$> (tpairs ++ tsLink0)) + ++ (UET_Unk <$> utToUnk) + ++ (UET_ReadOnly <$> utToRO) + let t0 = utTo0 {ueValue = StaticValue t0val} + return (f0 : fs ++ (t0 : tsUnk)) + where + project f _ _ (UET_ReadOnly e) = f e + project _ f _ (UET_Unk e) = f e + project _ _ f (UET_Linked p) = f p + idx = project ueIndex ueIndex (ueIndex . fst) + idx2 = project ueIndex ueIndex ueIndex + -- TODO the sum accumulator thing is kinda awkward + goFrom (tot, es) (UET_ReadOnly e) = do + v <- updateFixed e + return (tot - v, es) + goFrom (tot, esPrev) (UET_Unk e) = do + v <- updateUnknown e + return (tot - v, Right e {ueValue = StaticValue v} : esPrev) + goFrom (tot, esPrev) (UET_Linked (e0, es)) = do + v <- updateUnknown e0 + let e0' = Right $ e0 {ueValue = StaticValue v} + let es' = fmap (Left . unlink (-v)) es + return (tot - v, (e0' : es') ++ esPrev) + goTo (tot, esPrev) (UET_ReadOnly e) = do + v <- updateFixed e + return (tot - v, esPrev) + goTo (tot, esPrev) (UET_Linked e) = do + v <- updateFixed e + return (tot - v, Just e : esPrev) + goTo (tot, esPrev) (UET_Unk e) = do + v <- updateUnknown e + return (tot - v, Just e {ueValue = StaticValue v} : esPrev) + updateFixed :: UpdateEntry i StaticValue -> State EntryBals Rational + updateFixed e = do + let v = unStaticValue $ ueValue e + modify $ mapAdd_ (ueAcnt e, utCurrency) v + return v + updateUnknown e = do + let key = (ueAcnt e, utCurrency) + curBal <- gets (M.findWithDefault 0 key) + let v = case ueValue e of + EVPercent p -> p * curBal + EVBalance p -> p - curBal + modify $ mapAdd_ key v + return v + unlink v e = e {ueValue = StaticValue $ v * unLinkScale (ueValue e)} + +balanceEntrySet + :: (MonadInsertError m, MonadFinance m) + => (Entry AccountRId AcntSign TagRId -> CurrencyRId -> v -> State EntryBals Rational) + -> DeferredEntrySet v + -> StateT EntryBals m [KeyEntry] +balanceEntrySet + findTot + EntrySet + { esFrom = HalfEntrySet {hesPrimary = f0, hesOther = fs} + , esTo = HalfEntrySet {hesPrimary = t0, hesOther = ts} + , esCurrency = CurrencyPrec {cpID = curID, cpPrec = precision} + , esTotalValue + } = + do + -- 1. Resolve tag and accout ids in primary entries since we (might) need + -- them later to calculate the total value of the transaction. + let f0res = resolveAcntAndTags f0 + let t0res = resolveAcntAndTags t0 + combineErrorM f0res t0res $ \f0' t0' -> do + -- 2. Compute total value of transaction using the primary debit entry + tot <- liftInnerS $ findTot f0' curID esTotalValue + + -- 3. Balance all debit entries (including primary). Note the negative + -- indices, which will signify them to be debit entries when updated + -- later. + let balFromEntry = balanceEntry (\a -> liftInnerS . balanceDeferred curID a) curID + fs' <- doEntries balFromEntry curID tot f0' fs (NE.iterate (+ (-1)) (-1)) + + -- 4. Build an array of debit values be linked as desired in credit entries + let fv = V.fromList $ fmap (eValue . feEntry) fs' + + -- 4. Balance credit entries (including primary) analogously. + let balToEntry = balanceEntry (balanceLinked fv curID precision) curID + ts' <- doEntries balToEntry curID (-tot) t0' ts (NE.iterate (+ 1) 0) + return $ fs' ++ ts' + +doEntries + :: (MonadInsertError m) + => (Int -> Entry AcntID v TagID -> StateT EntryBals m (InsertEntry AccountRId CurrencyRId TagRId)) + -> CurrencyRId + -> Rational + -> Entry AccountRId AcntSign TagRId + -> [Entry AcntID v TagID] + -> NonEmpty Int + -> StateT EntryBals m [InsertEntry AccountRId CurrencyRId TagRId] +doEntries f curID tot e es (i0 :| iN) = do + es' <- mapErrors (uncurry f) $ zip iN es + let e0val = tot - entrySum es' + -- TODO not dry + let s = fromIntegral $ sign2Int (eValue e) -- NOTE hack + modify (mapAdd_ (eAcnt e, curID) tot) + let e' = + InsertEntry + { feEntry = e {eValue = s * e0val} + , feCurrency = curID + , feDeferred = Nothing + , feIndex = i0 + } + return $ e' : es' + where + entrySum = sum . fmap (eValue . feEntry) + +liftInnerS :: Monad m => StateT e Identity a -> StateT e m a +liftInnerS = mapStateT (return . runIdentity) + +balanceLinked + :: MonadInsertError m + => Vector Rational + -> CurrencyRId + -> Natural + -> AccountRId + -> LinkDeferred Rational + -> StateT EntryBals m (Rational, Maybe DBDeferred) +balanceLinked from curID precision acntID lg = case lg of + (LinkIndex LinkedNumGetter {lngIndex, lngScale}) -> do + let res = fmap (go lngScale) $ from V.!? fromIntegral lngIndex + case res of + Just v -> return (v, Just $ EntryLinked lngIndex $ toRational lngScale) + -- TODO this error would be much more informative if I had access to the + -- file from which it came + Nothing -> throwError undefined + (LinkDeferred d) -> liftInnerS $ balanceDeferred curID acntID d + where + go s = roundPrecision precision . (* s) . fromRational + +balanceDeferred + :: CurrencyRId + -> AccountRId + -> EntryValue Rational + -> State EntryBals (Rational, Maybe DBDeferred) +balanceDeferred curID acntID (EntryValue t v) = do + newval <- findBalance acntID curID t v + let d = case t of + TFixed -> Nothing + TBalance -> Just $ EntryBalance v + TPercent -> Just $ EntryPercent v + return (newval, d) + +balanceEntry + :: (MonadInsertError m, MonadFinance m) + => (AccountRId -> v -> StateT EntryBals m (Rational, Maybe DBDeferred)) + -> CurrencyRId + -> Int + -> Entry AcntID v TagID + -> StateT EntryBals m (InsertEntry AccountRId CurrencyRId TagRId) +balanceEntry f curID idx e@Entry {eValue, eAcnt, eTags} = do + let acntRes = lookupAccount eAcnt + let tagRes = mapErrors lookupTag eTags + combineErrorM acntRes tagRes $ \(acntID, sign, _) tags -> do + let s = fromIntegral $ sign2Int sign + (newVal, deferred) <- f acntID eValue + modify (mapAdd_ (acntID, curID) newVal) + return $ + InsertEntry + { feEntry = e {eValue = s * newVal, eAcnt = acntID, eTags = tags} + , feCurrency = curID + , feDeferred = deferred + , feIndex = idx + } + +resolveAcntAndTags + :: (MonadInsertError m, MonadFinance m) + => Entry AcntID v TagID + -> m (Entry AccountRId AcntSign TagRId) +resolveAcntAndTags e@Entry {eAcnt, eTags} = do + let acntRes = lookupAccount eAcnt + let tagRes = mapErrors lookupTag eTags + -- TODO total hack, store account sign in the value field so I don't need to + -- make seperate tuple pair thing to haul it around. Weird, but it works. + combineError acntRes tagRes $ + \(acntID, sign, _) tags -> e {eAcnt = acntID, eTags = tags, eValue = sign} + +findBalance + :: AccountRId + -> CurrencyRId + -> TransferType + -> Rational + -> State EntryBals Rational +findBalance acnt cur t v = do + curBal <- gets (M.findWithDefault 0 (acnt, cur)) + return $ case t of + TBalance -> v - curBal + TPercent -> v * curBal + TFixed -> v + +expandTransfers + :: (MonadInsertError m, MonadFinance m) + => TxCommit + -> DaySpan + -> [PairedTransfer] + -> m [Tx TxCommit] +expandTransfers tc bounds = fmap concat . mapErrors (expandTransfer tc bounds) + +expandTransfer + :: (MonadInsertError m, MonadFinance m) + => TxCommit + -> DaySpan + -> PairedTransfer + -> m [Tx TxCommit] +expandTransfer tc bounds Transfer {transAmounts, transTo, transCurrency, transFrom} = do + txs <- mapErrors go transAmounts + return $ filter (inDaySpan bounds . txDate) $ concat txs + where + go + Amount + { amtWhen = pat + , amtValue = TransferValue {tvVal = v, tvType = t} + , amtDesc = desc + } = + withDates pat $ \day -> do + p <- entryPair_ (\_ x -> EntryValue t $ toRational x) transFrom transTo transCurrency desc v + return + Tx + { txCommit = tc + , txDate = day + , txPrimary = p + , txOther = [] + , txDescr = desc + } + +entryPair + :: (MonadInsertError m, MonadFinance m) + => TaggedAcnt + -> TaggedAcnt + -> CurID + -> T.Text + -> Double + -> m (EntrySet AcntID CurrencyPrec TagID Rational (EntryValue Rational)) +entryPair = entryPair_ (fmap (EntryValue TFixed) . roundPrecisionCur) + +entryPair_ + :: (MonadInsertError m, MonadFinance m) + => (CurrencyPrec -> v -> v') + -> TaggedAcnt + -> TaggedAcnt + -> CurID + -> T.Text + -> v + -> m (EntrySet AcntID CurrencyPrec TagID Rational v') +entryPair_ f from to_ curid com val = do + cp <- lookupCurrency curid + return $ pair cp from to_ (f cp val) + where + halfEntry :: a -> [t] -> HalfEntrySet a c t v + halfEntry a ts = + HalfEntrySet + { hesPrimary = Entry {eAcnt = a, eValue = (), eComment = com, eTags = ts} + , hesOther = [] + } + pair cp (TaggedAcnt fa fts) (TaggedAcnt ta tts) v = + EntrySet + { esCurrency = cp + , esTotalValue = v + , esFrom = halfEntry fa fts + , esTo = halfEntry ta tts + } + +withDates + :: (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