From cc0699eb4efdc1bfb82f9d8262632bec5cfdd8ff Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Thu, 29 Jun 2023 21:32:14 -0400 Subject: [PATCH] WIP make budget and statement paths use same machinery --- dhall/Types.dhall | 119 +++++++------ lib/Internal/Budget.hs | 58 ++++++ lib/Internal/Database.hs | 54 +++--- lib/Internal/History.hs | 316 ++++++++++++++++++++------------- lib/Internal/Types/Database.hs | 6 +- lib/Internal/Types/Dhall.hs | 32 ++-- lib/Internal/Types/Main.hs | 83 +++++---- lib/Internal/Utils.hs | 198 +++++---------------- 8 files changed, 461 insertions(+), 405 deletions(-) diff --git a/dhall/Types.dhall b/dhall/Types.dhall index c0856d4..d181022 100644 --- a/dhall/Types.dhall +++ b/dhall/Types.dhall @@ -402,13 +402,15 @@ let EntryNumGetter = LookupN: lookup the value from a field ConstN: a constant value - AmountN: the value of the 'Amount' column + AmountN: the value of the 'Amount' column times a scaling factor BalanceN: the amount required to make the target account reach a balance + PercentN: the amount required to make an account reach a given percentage -} < LookupN : Text | ConstN : Double | AmountN : Double | BalanceN : Double + | PercentN : Double > let LinkedNumGetter = @@ -679,6 +681,58 @@ let Amount = \(v : Type) -> { amtWhen : w, amtValue : v, amtDesc : Text } +let Exchange = + {- + A currency exchange. + -} + { xFromCur : + {- + Starting currency of the exchange. + -} + CurID + , xToCur : + {- + Ending currency of the exchange. + -} + CurID + , xAcnt : + {- + account in which the exchange will be documented. + -} + AcntID + , xRate : + {- + The exchange rate between the currencies. + -} + Double + } + +let TransferCurrency = + {- + Means to represent currency in a transcaction; either single fixed currency + or two currencies with an exchange rate. + -} + < NoX : CurID | X : Exchange > + +let TransferType = + {- + The type of a budget transfer. + + BTFixed: Tranfer a fixed amount + BTPercent: Transfer a percent of the source account to destination + BTTarget: Transfer an amount such that the destination has a given target + value + -} + < TPercent | TBalance | TFixed > + +let TransferValue = + {- + Means to determine the value of a budget transfer. + -} + { Type = { tvVal : Double, tvType : TransferType } + , default.tvType = TransferType.TFixed + } + let Transfer = {- 1-1 transaction(s) between two accounts. @@ -697,7 +751,7 @@ let HistTransfer = {- A manually specified historical transfer -} - Transfer AcntID CurID DatePat Double + Transfer AcntID CurID DatePat TransferValue.Type let Statement = {- @@ -734,38 +788,6 @@ let History = -} < HistTransfer : HistTransfer | HistStatement : Statement > -let Exchange = - {- - A currency exchange. - -} - { xFromCur : - {- - Starting currency of the exchange. - -} - CurID - , xToCur : - {- - Ending currency of the exchange. - -} - CurID - , xAcnt : - {- - account in which the exchange will be documented. - -} - AcntID - , xRate : - {- - The exchange rate between the currencies. - -} - Double - } - -let BudgetCurrency = - {- - A 'currency' in the budget; either a fixed currency or an exchange - -} - < NoX : CurID | X : Exchange > - let TaggedAcnt = {- An account with a tag @@ -1037,17 +1059,6 @@ let TransferMatcher = } } -let BudgetTransferType = - {- - The type of a budget transfer. - - BTFixed: Tranfer a fixed amount - BTPercent: Transfer a percent of the source account to destination - BTTarget: Transfer an amount such that the destination has a given target - value - -} - < BTPercent | BTTarget | BTFixed > - let ShadowTransfer = {- A transaction analogous to another transfer with given properties. @@ -1066,7 +1077,7 @@ let ShadowTransfer = {- Currency of this transfer. -} - BudgetCurrency + TransferCurrency , stDesc : {- Description of this transfer. @@ -1080,7 +1091,7 @@ let ShadowTransfer = specified in other fields of this type. -} TransferMatcher.Type - , stType : BudgetTransferType + , stType : TransferType , stRatio : {- Fixed multipler to translate value of matched transfer to this one. @@ -1088,17 +1099,11 @@ let ShadowTransfer = Double } -let BudgetTransferValue = - {- - Means to determine the value of a budget transfer. - -} - { btVal : Double, btType : BudgetTransferType } - let BudgetTransfer = {- A manually specified transaction for a budget -} - Transfer TaggedAcnt BudgetCurrency DatePat BudgetTransferValue + Transfer TaggedAcnt TransferCurrency DatePat TransferValue.Type let Budget = {- @@ -1168,7 +1173,7 @@ in { CurID , TransferMatcher , ShadowTransfer , AcntSet - , BudgetCurrency + , TransferCurrency , Exchange , TaggedAcnt , AccountTree @@ -1180,8 +1185,8 @@ in { CurID , TaxProgression , TaxMethod , TaxValue - , BudgetTransferValue - , BudgetTransferType + , TransferValue + , TransferType , TxGetter , TxSubGetter , TxHalfGetter diff --git a/lib/Internal/Budget.hs b/lib/Internal/Budget.hs index ad46f74..672655d 100644 --- a/lib/Internal/Budget.hs +++ b/lib/Internal/Budget.hs @@ -59,6 +59,8 @@ insertBudget ++ (alloAcnt <$> bgtTax) ++ (alloAcnt <$> bgtPosttax) +-- TODO need to systematically make this function match the history version, +-- which will allow me to use the same balancing algorithm for both balanceTransfers :: [UnbalancedTransfer] -> [BalancedTransfer] balanceTransfers = snd . L.mapAccumR go M.empty . reverse . L.sortOn ftWhen where @@ -527,8 +529,64 @@ data UnbalancedValue = UnbalancedValue } deriving (Show) +-- TODO need to make this into the same ish thing as the Tx/EntrySet structs +-- in the history algorithm, which will entail resolving the budget currency +-- stuff earlier in the chain, and preloading multiple entries into this thing +-- before balancing. type UnbalancedTransfer = FlatTransfer UnbalancedValue +ubt2tx :: UnbalancedTransfer -> Tx [EntrySet AcntID CurID TagID Rational] BudgetMeta +ubt2tx + FlatTransfer + { ftFrom + , ftTo + , ftValue + , ftWhen + , ftDesc + , ftMeta + , ftCur + } = + Tx + { txDescr = ftDesc + , txDate = ftWhen + , txEntries = entries ftCur + , txCommit = ftMeta + } + where + entries (NoX curid) = [pair curid ftFrom ftTo ftValue] + entries (X Exchange {xFromCur, xToCur, xAcnt, xRate}) = + let middle = TaggedAcnt xAcnt [] + p1 = pair xFromCur ftFrom middle ftValue + p2 = pair xToCur middle ftTo (ftValue * roundPrecision 3 xRate) + in [p1, p2] + pair c (TaggedAcnt fa fts) (TaggedAcnt ta tts) v = + EntrySet + { esTotalValue = v + , esCurrency = c + , esFrom = + HalfEntrySet + { hesPrimary = + Entry + { eValue = () + , eComment = "" + , eAcnt = fa + , eTags = fts + } + , hesOther = [] + } + , esTo = + HalfEntrySet + { hesPrimary = + Entry + { eValue = () + , eComment = "" + , eAcnt = ta + , eTags = tts + } + , hesOther = [] + } + } + type BalancedTransfer = FlatTransfer Rational data FlatTransfer v = FlatTransfer diff --git a/lib/Internal/Database.hs b/lib/Internal/Database.hs index 889c081..2598c59 100644 --- a/lib/Internal/Database.hs +++ b/lib/Internal/Database.hs @@ -193,7 +193,7 @@ currencyMap = . fmap ( \e -> ( currencyRSymbol $ entityVal e - , (entityKey e, fromIntegral $ currencyRPrecision $ entityVal e) + , CurrencyPrec (entityKey e) $ fromIntegral $ currencyRPrecision $ entityVal e ) ) @@ -424,24 +424,25 @@ whenHash_ t o f = do insertEntry :: MonadSqlQuery m => TransactionRId -> KeyEntry -> m EntryRId insertEntry t - FullEntry + InsertEntry { feEntry = Entry {eValue, eTags, eAcnt, eComment} , feCurrency , feIndex , feDeferred } = do - k <- insert $ EntryR t feCurrency eAcnt eComment eValue feIndex defval deflink + k <- insert $ EntryR t feCurrency eAcnt eComment eValue feIndex cval ctype deflink mapM_ (insert_ . TagRelationR k) eTags return k where - (defval, deflink) = case feDeferred of - (Just (EntryLinked index scale)) -> (Just scale, Just $ fromIntegral index) - (Just (EntryBalance target)) -> (Just target, Nothing) - Nothing -> (Nothing, Nothing) + (cval, ctype, deflink) = case feDeferred of + (Just (EntryLinked index scale)) -> (Just scale, Nothing, Just $ fromIntegral index) + (Just (EntryBalance target)) -> (Just target, Just TBalance, Nothing) + (Just (EntryPercent target)) -> (Just target, Just TPercent, Nothing) + Nothing -> (Nothing, Just TFixed, Nothing) resolveEntry :: (MonadInsertError m, MonadFinance m) => BalEntry -> m KeyEntry -resolveEntry s@FullEntry {feEntry = e@Entry {eValue, eTags, eAcnt}, feCurrency} = do +resolveEntry s@InsertEntry {feEntry = e@Entry {eValue, eTags, eAcnt}, feCurrency} = do let aRes = lookupAccountKey eAcnt let cRes = lookupCurrencyKey feCurrency let sRes = lookupAccountSign eAcnt @@ -516,26 +517,26 @@ readUpdates hashes = do splitFrom :: [(EntryRId, EntryR)] - -> InsertExcept (UEBlank, [UE_RO], [UEBalance], Vector (Maybe UEBalance)) + -> InsertExcept (UEBlank, [UE_RO], [UEUnk], Vector (Maybe UEUnk)) splitFrom from = do -- ASSUME entries are sorted by index (primary, rest) <- case from of ((i, e) : xs) -> return (makeUnkUE i e, xs) _ -> throwError $ InsertException undefined - let rest' = fmap splitDeferredValue rest + rest' <- mapErrors splitDeferredValue rest let idxVec = V.fromList $ fmap (either (const Nothing) Just) rest' let (ro, toBal) = partitionEithers rest' return (primary, ro, toBal, idxVec) splitTo - :: Vector (Maybe UEBalance) + :: Vector (Maybe UEUnk) -> [(EntryRId, EntryR)] -> InsertExcept ( UEBlank , [UE_RO] - , [UEBalance] + , [UEUnk] , [UELink] - , [(UEBalance, [UELink])] + , [(UEUnk, [UELink])] ) splitTo froms tos = do -- How to split the credit side of the database transaction in 1024 easy @@ -552,7 +553,7 @@ splitTo froms tos = do let (unlinked, linked) = partitionEithers $ fmap splitLinked rest -- 2. Split unlinked based on if they have a balance target - let (ro, toBal) = partitionEithers $ fmap splitDeferredValue unlinked + let unlinkedRes = partitionEithers <$> mapErrors splitDeferredValue unlinked -- 3. Split paired entries by link == 0 (which are special) or link > 0 let (paired0, pairedN) = second (groupKey id) $ L.partition ((== 0) . fst) linked @@ -565,10 +566,11 @@ splitTo froms tos = do -- then consider the linked entry as another credit read-only entry let pairedRes = partitionEithers <$> mapErrors splitPaired pairedN - combineError paired0Res pairedRes $ \paired0' (pairedUnk, pairedRO) -> - (primary, ro ++ concat pairedRO, toBal, paired0', pairedUnk) + combineError3 unlinkedRes paired0Res pairedRes $ + \(ro, toBal) paired0' (pairedUnk, pairedRO) -> + (primary, ro ++ concat pairedRO, toBal, paired0', pairedUnk) where - splitLinked t@(_, e) = maybe (Left t) (Right . (,t)) $ entryRDeferred_link e + splitLinked t@(_, e) = maybe (Left t) (Right . (,t)) $ entryRCachedLink e splitPaired (lnk, ts) = case froms V.!? (lnk - 1) of Just (Just f) -> Left . (f,) <$> mapErrors makeLinkUnk ts Just Nothing -> return $ Right $ makeRoUE . snd <$> ts @@ -577,18 +579,22 @@ splitTo froms tos = do maybe (throwError $ InsertException undefined) (return . makeUE k e . LinkScale) - $ entryRDeferred_value e + $ entryRCachedValue e -splitDeferredValue :: (EntryRId, EntryR) -> Either UE_RO UEBalance -splitDeferredValue (k, e) = - maybe (Left $ makeRoUE e) (Right . fmap BalanceTarget . makeUE k e) $ - entryRDeferred_value e +splitDeferredValue :: (EntryRId, EntryR) -> InsertExcept (Either UE_RO UEUnk) +splitDeferredValue (k, e) = case (entryRCachedValue e, entryRCachedType e) of + (Nothing, Just TFixed) -> return $ Left $ makeRoUE e + (Just v, Just TBalance) -> go EVBalance v + (Just v, Just TPercent) -> go EVPercent v + _ -> throwError $ InsertException undefined + where + go c = return . Right . fmap c . makeUE k e makeUE :: i -> EntryR -> v -> UpdateEntry i v makeUE k e v = UpdateEntry k (entryRAccount e) v (entryRIndex e) -makeRoUE :: EntryR -> UpdateEntry () EntryValue -makeRoUE e = makeUE () e $ EntryValue (entryRValue e) +makeRoUE :: EntryR -> UpdateEntry () StaticValue +makeRoUE e = makeUE () e $ StaticValue (entryRValue e) makeUnkUE :: EntryRId -> EntryR -> UpdateEntry EntryRId () makeUnkUE k e = makeUE k e () diff --git a/lib/Internal/History.hs b/lib/Internal/History.hs index fcce8ee..9ccba68 100644 --- a/lib/Internal/History.hs +++ b/lib/Internal/History.hs @@ -39,7 +39,7 @@ import qualified RIO.Vector as V readHistTransfer :: (MonadInsertError m, MonadFinance m) => HistTransfer - -> m [DeferredTx CommitR] + -> m [Tx CommitR] readHistTransfer m@Transfer { transFrom = from @@ -49,11 +49,11 @@ readHistTransfer } = whenHash0 CTManual m [] $ \c -> do bounds <- askDBState kmStatementInterval - let precRes = lookupCurrencyPrec u + let curRes = lookupCurrency u let go Amount {amtWhen, amtValue, amtDesc} = do let dayRes = liftExcept $ expandDatePat bounds amtWhen - (days, precision) <- combineError dayRes precRes (,) - let tx day = txPair c day from to u (roundPrecision precision amtValue) amtDesc + (days, cur) <- combineError dayRes curRes (,) + let tx day = txPair c day from to cur amtValue amtDesc return $ fmap tx days concat <$> mapErrors go amts @@ -61,7 +61,7 @@ readHistStmt :: (MonadUnliftIO m, MonadFinance m) => FilePath -> Statement - -> m (Either CommitR [DeferredTx CommitR]) + -> m (Either CommitR [Tx CommitR]) readHistStmt root i = eitherHash CTImport i return $ \c -> do bs <- readImport root i bounds <- askDBState kmStatementInterval @@ -80,9 +80,9 @@ insertHistory insertHistory hs = do (toUpdate, toInsert) <- balanceTxs hs mapM_ updateTx toUpdate - forM_ (groupKey commitRHash $ (\x -> (txCommit x, x)) <$> toInsert) $ + forM_ (groupKey commitRHash $ (\x -> (itxCommit x, x)) <$> toInsert) $ \(c, ts) -> do - ck <- insert $ c + ck <- insert c mapM_ (insertTx ck) ts -------------------------------------------------------------------------------- @@ -94,23 +94,23 @@ txPair -> Day -> AcntID -> AcntID - -> CurID - -> Rational + -> CurrencyPrec + -> Double -> T.Text - -> DeferredTx CommitR + -> Tx CommitR txPair commit day from to cur val desc = Tx { txDescr = desc , txDate = day , txCommit = commit - , txEntries = - [ EntrySet - { esTotalValue = -val - , esCurrency = cur - , esFrom = HalfEntrySet {hesPrimary = entry from, hesOther = []} - , esTo = HalfEntrySet {hesPrimary = entry to, hesOther = []} - } - ] + , txPrimary = + EntrySet + { esTotalValue = -(roundPrecisionCur cur val) + , esCurrency = cur + , esFrom = HalfEntrySet {hesPrimary = entry from, hesOther = []} + , esTo = HalfEntrySet {hesPrimary = entry to, hesOther = []} + } + , txOther = [] } where entry a = @@ -125,31 +125,27 @@ txPair commit day from to cur val desc = -- resolveTx t@Tx {txEntries = ss} = -- (\kss -> t {txEntries = kss}) <$> mapErrors resolveEntry ss -insertTx :: MonadSqlQuery m => CommitRId -> (KeyTx CommitR) -> m () -insertTx c Tx {txDate = d, txDescr = e, txEntries = ss} = do +insertTx :: MonadSqlQuery m => CommitRId -> InsertTx -> m () +insertTx c InsertTx {itxDate = d, itxDescr = e, itxEntries = ss} = do let anyDeferred = any (isJust . feDeferred) ss k <- insert $ TransactionR c d e anyDeferred mapM_ (insertEntry k) ss updateTx :: MonadSqlQuery m => UEBalanced -> m () -updateTx UpdateEntry {ueID, ueValue} = update ueID [EntryRValue =. (unEntryValue ueValue)] +updateTx UpdateEntry {ueID, ueValue} = update ueID [EntryRValue =. unStaticValue ueValue] -------------------------------------------------------------------------------- -- Statements -- TODO this probably won't scale well (pipes?) -readImport :: (MonadUnliftIO m, MonadFinance m) => FilePath -> Statement -> m [DeferredTx ()] +readImport :: (MonadUnliftIO m, MonadFinance m) => FilePath -> Statement -> m [Tx ()] 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 paths - m <- askDBState kmCurrency - fromEither $ - flip runReader m $ - runExceptT $ - matchRecords compiledMatches records + fromEither =<< runExceptT (matchRecords compiledMatches records) where paths = (root ) <$> stmtPaths @@ -184,13 +180,11 @@ parseTxRecord p TxOpts {toDate, toAmountFmt, toDesc, toAmount, toOther, toDateFm d' <- parseTimeM True defaultTimeLocale (T.unpack toDateFmt) d return $ Just $ TxRecord d' a e os p --- TODO need to somehow balance temporally here (like I do in the budget for --- directives that "pay off" a balance) -matchRecords :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM [DeferredTx ()] +matchRecords :: MonadFinance m => [MatchRe] -> [TxRecord] -> InsertExceptT m [Tx ()] matchRecords ms rs = do (matched, unmatched, notfound) <- matchAll (matchPriorities ms) rs case (matched, unmatched, notfound) of - (ms_, [], []) -> return ms_ -- liftInner $ combineErrors $ fmap balanceTx ms_ + (ms_, [], []) -> return ms_ (_, us, ns) -> throwError $ InsertException [StatementError us ns] matchPriorities :: [MatchRe] -> [MatchGroup] @@ -245,9 +239,10 @@ zipperSlice f x = go LT -> z zipperMatch - :: Unzipped MatchRe + :: MonadFinance m + => Unzipped MatchRe -> TxRecord - -> InsertExceptT CurrencyM (Zipped MatchRe, MatchRes (DeferredTx ())) + -> InsertExceptT m (Zipped MatchRe, MatchRes (Tx ())) zipperMatch (Unzipped bs cs as) x = go [] cs where go _ [] = return (Zipped bs $ cs ++ as, MatchFail) @@ -261,9 +256,10 @@ zipperMatch (Unzipped bs cs as) x = go [] cs in return (Zipped bs $ ps ++ ms' ++ as, skipOrPass) zipperMatch' - :: Zipped MatchRe + :: MonadFinance m + => Zipped MatchRe -> TxRecord - -> InsertExceptT CurrencyM (Zipped MatchRe, MatchRes (DeferredTx ())) + -> InsertExceptT m (Zipped MatchRe, MatchRes (Tx ())) zipperMatch' z x = go z where go (Zipped bs (a : as)) = do @@ -280,7 +276,11 @@ matchDec m = case spTimes m of Just n -> Just $ m {spTimes = Just $ n - 1} Nothing -> Just m -matchAll :: [MatchGroup] -> [TxRecord] -> InsertExceptT CurrencyM ([DeferredTx ()], [TxRecord], [MatchRe]) +matchAll + :: MonadFinance m + => [MatchGroup] + -> [TxRecord] + -> InsertExceptT m ([Tx ()], [TxRecord], [MatchRe]) matchAll = go ([], []) where go (matched, unused) gs rs = case (gs, rs) of @@ -290,13 +290,21 @@ matchAll = go ([], []) (ts, unmatched, us) <- matchGroup g rs go (ts ++ matched, us ++ unused) gs' unmatched -matchGroup :: MatchGroup -> [TxRecord] -> InsertExceptT CurrencyM ([DeferredTx ()], [TxRecord], [MatchRe]) +matchGroup + :: MonadFinance m + => MatchGroup + -> [TxRecord] + -> InsertExceptT m ([Tx ()], [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 ([DeferredTx ()], [TxRecord], [MatchRe]) +matchDates + :: MonadFinance m + => [MatchRe] + -> [TxRecord] + -> InsertExceptT m ([Tx ()], [TxRecord], [MatchRe]) matchDates ms = go ([], [], initZipper ms) where go (matched, unmatched, z) [] = @@ -317,7 +325,11 @@ matchDates ms = go ([], [], initZipper ms) go (m, u, z') rs findDate m r = maybe EQ (`compareDate` trDate r) $ spDate m -matchNonDates :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM ([DeferredTx ()], [TxRecord], [MatchRe]) +matchNonDates + :: MonadFinance m + => [MatchRe] + -> [TxRecord] + -> InsertExceptT m ([Tx ()], [TxRecord], [MatchRe]) matchNonDates ms = go ([], [], initZipper ms) where go (matched, unmatched, z) [] = @@ -337,18 +349,29 @@ matchNonDates ms = go ([], [], initZipper ms) balanceTxs :: (MonadInsertError m, MonadFinance m) => [EntryBin] - -> m ([UEBalanced], [KeyTx CommitR]) -balanceTxs es = + -> m ([UEBalanced], [InsertTx]) +balanceTxs ebs = first concat . partitionEithers . catMaybes - <$> evalStateT (mapErrors go $ L.sortOn binDate es) M.empty + <$> 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 t@Tx {txEntries}) = - (\es' -> Just $ Right $ t {txEntries = concat es'}) - <$> mapErrors balanceEntrySet txEntries + go (ToInsert Tx {txPrimary, txOther, txDescr, txCommit, txDate}) = + let res0 = balanceEntrySet (\_ _ v -> return v) txPrimary + resN = mapErrors (balanceEntrySet primaryBalance) txOther + in combineError res0 resN $ \e es -> + -- TODO repacking a Tx into almost the same record seems stupid + Just $ + Right $ + InsertTx + { itxDescr = txDescr + , itxDate = txDate + , itxEntries = concat $ e : es + , itxCommit = txCommit + } + primaryBalance Entry {eAcnt} c (EntryValue t v) = findBalance eAcnt c t v binDate :: EntryBin -> Day binDate (ToUpdate UpdateEntrySet {utDate}) = utDate @@ -359,9 +382,10 @@ type EntryBals = M.Map (AccountRId, CurrencyRId) Rational data UpdateEntryType a = UET_ReadOnly UE_RO - | UET_Balance UEBalance + | UET_Unk UEUnk | UET_Linked a +-- TODO make sure new values are rounded properly here rebalanceEntrySet :: UpdateEntrySet -> State EntryBals [UEBalanced] rebalanceEntrySet UpdateEntrySet @@ -377,112 +401,124 @@ rebalanceEntrySet , utTotalValue } = do - let fs = + (f0val, (tpairs, fs)) <- + fmap (second partitionEithers) $ + foldM goFrom (utTotalValue, []) $ L.sortOn idx $ (UET_ReadOnly <$> utFromRO) - ++ (UET_Balance <$> utFromUnk) + ++ (UET_Unk <$> utFromUnk) ++ (UET_Linked <$> utPairs) - fs' <- mapM goFrom fs - let f0val = utTotalValue - sum (fmap value fs') - let f0 = utFrom0 {ueValue = EntryValue f0val} - let (tpairs, fs'') = partitionEithers $ concatMap flatten fs' - let tsLink0 = fmap (\e -> e {ueValue = EntryValue $ -f0val * unLinkScale (ueValue e)}) utToUnkLink0 - let ts = + 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_Balance <$> utToUnk) + ++ (UET_Unk <$> utToUnk) ++ (UET_ReadOnly <$> utToRO) - (tsRO, tsUnk) <- partitionEithers <$> mapM goTo ts - let t0val = - EntryValue utTotalValue - - sum (fmap ueValue tsRO ++ fmap ueValue tsUnk) - let t0 = utTo0 {ueValue = t0val} - return $ (f0 : fmap (fmap (EntryValue . unBalanceTarget)) fs'') ++ (t0 : tsUnk) + let t0 = utTo0 {ueValue = StaticValue t0val} + return (f0 : fs ++ (t0 : tsUnk)) where project f _ _ (UET_ReadOnly e) = f e - project _ f _ (UET_Balance 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 - value = - project - (unEntryValue . ueValue) - (unBalanceTarget . ueValue) - (unBalanceTarget . ueValue . fst) - flatten = project (const []) ((: []) . Right) (\(a, bs) -> Right a : (Left <$> bs)) - -- TODO the following is wetter than the average groupie - goFrom (UET_ReadOnly e) = do - modify $ mapAdd_ (ueAcnt e, utCurrency) (unEntryValue $ ueValue e) - return $ UET_ReadOnly e - goFrom (UET_Balance e) = do + -- 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 newVal = unBalanceTarget (ueValue e) - curBal - modify $ mapAdd_ key newVal - return $ UET_Balance $ e {ueValue = BalanceTarget newVal} - goFrom (UET_Linked (e0, es)) = do - let key = (ueAcnt e0, utCurrency) - curBal <- gets (M.findWithDefault 0 key) - let newVal = unBalanceTarget (ueValue e0) - curBal - modify $ mapAdd_ key newVal - return $ - UET_Linked - ( e0 {ueValue = BalanceTarget newVal} - , fmap (\e -> e {ueValue = EntryValue $ (-newVal) * unLinkScale (ueValue e)}) es - ) - goTo (UET_ReadOnly e) = do - modify $ mapAdd_ (ueAcnt e, utCurrency) (unEntryValue $ ueValue e) - return $ Left e - goTo (UET_Linked e) = do - modify $ mapAdd_ (ueAcnt e, utCurrency) (unEntryValue $ ueValue e) - return $ Right e - goTo (UET_Balance e) = do - let key = (ueAcnt e, utCurrency) - curBal <- gets (M.findWithDefault 0 key) - let newVal = unBalanceTarget (ueValue e) - curBal - modify $ mapAdd_ key newVal - return $ Right $ e {ueValue = EntryValue newVal} + 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) - => DeferredEntrySet + => (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 + , esCurrency = CurrencyPrec {cpID = curID, cpPrec = precision} , esTotalValue } = do - -- get currency first and quit immediately on exception since everything - -- downstream depends on this - (curID, precision) <- lookupCurrency esCurrency + -- 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 - -- resolve accounts and balance debit entries since we need an array - -- of debit entries for linked credit entries later - let balFromEntry = balanceEntry (\a -> liftInnerS . balanceDeferred curID a) curID - fs' <- doEntries balFromEntry curID esTotalValue f0 fs (NE.iterate (+ (-1)) (-1)) - let fv = V.fromList $ fmap (eValue . feEntry) fs' + -- 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)) - -- finally resolve credit entries - let balToEntry = balanceEntry (balanceLinked fv curID precision) curID - ts' <- doEntries balToEntry curID (-esTotalValue) t0 ts (NE.iterate (+ 1) 0) - return $ fs' ++ ts' + -- 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, MonadFinance m) - => (Int -> Entry AcntID v TagID -> StateT EntryBals m (FullEntry AccountRId CurrencyRId TagRId)) + :: (MonadInsertError m) + => (Int -> Entry AcntID v TagID -> StateT EntryBals m (InsertEntry AccountRId CurrencyRId TagRId)) -> CurrencyRId -> Rational - -> Entry AcntID () TagID + -> Entry AccountRId AcntSign TagRId -> [Entry AcntID v TagID] -> NonEmpty Int - -> StateT EntryBals m [FullEntry AccountRId CurrencyRId TagRId] + -> StateT EntryBals m [InsertEntry AccountRId CurrencyRId TagRId] doEntries f curID tot e es (i0 :| iN) = do es' <- mapErrors (uncurry f) $ zip iN es - let val0 = tot - entrySum es' - e' <- balanceEntry (\_ _ -> return (val0, Nothing)) curID i0 e + 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) @@ -502,7 +538,7 @@ 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) + 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 @@ -513,11 +549,15 @@ balanceLinked from curID precision acntID lg = case lg of balanceDeferred :: CurrencyRId -> AccountRId - -> Deferred Rational + -> EntryValue Rational -> State EntryBals (Rational, Maybe DBDeferred) -balanceDeferred curID acntID (Deferred toBal v) = do - newval <- findBalance acntID curID toBal v - return $ (newval, if toBal then Just (EntryBalance v) else Nothing) +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) @@ -525,7 +565,7 @@ balanceEntry -> CurrencyRId -> Int -> Entry AcntID v TagID - -> StateT EntryBals m (FullEntry AccountRId CurrencyRId TagRId) + -> 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 @@ -534,17 +574,37 @@ balanceEntry f curID idx e@Entry {eValue, eAcnt, eTags} = do (newVal, deferred) <- f acntID eValue modify (mapAdd_ (acntID, curID) newVal) return $ - FullEntry + InsertEntry { feEntry = e {eValue = s * newVal, eAcnt = acntID, eTags = tags} , feCurrency = curID , feDeferred = deferred , feIndex = idx } -findBalance :: AccountRId -> CurrencyRId -> Bool -> Rational -> State EntryBals Rational -findBalance acnt cur toBal v = do +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 $ if toBal then v - curBal else v + return $ case t of + TBalance -> v - curBal + TPercent -> v * curBal + TFixed -> v -- -- reimplementation from future version :/ -- mapAccumM diff --git a/lib/Internal/Types/Database.hs b/lib/Internal/Types/Database.hs index 8a73112..27fc59f 100644 --- a/lib/Internal/Types/Database.hs +++ b/lib/Internal/Types/Database.hs @@ -9,6 +9,7 @@ module Internal.Types.Database where import Database.Persist.Sql hiding (Desc, In, Statement) import Database.Persist.TH +import Internal.Types.Dhall import RIO import qualified RIO.Text as T import RIO.Time @@ -52,8 +53,9 @@ EntryR sql=entries memo T.Text value Rational index Int - deferred_value (Maybe Rational) - deferred_link (Maybe Int) + cachedValue (Maybe Rational) + cachedType (Maybe TransferType) + cachedLink (Maybe Int) deriving Show Eq TagRelationR sql=tag_relations entry EntryRId OnDeleteCascade diff --git a/lib/Internal/Types/Dhall.hs b/lib/Internal/Types/Dhall.hs index c677299..de55bb3 100644 --- a/lib/Internal/Types/Dhall.hs +++ b/lib/Internal/Types/Dhall.hs @@ -34,8 +34,8 @@ makeHaskellTypesWith , MultipleConstructors "DateMatcher" "(./dhall/Types.dhall).DateMatcher" , MultipleConstructors "EntryNumGetter" "(./dhall/Types.dhall).EntryNumGetter" , MultipleConstructors "LinkedEntryNumGetter" "(./dhall/Types.dhall).LinkedEntryNumGetter" - , MultipleConstructors "BudgetCurrency" "(./dhall/Types.dhall).BudgetCurrency" - , MultipleConstructors "BudgetTransferType" "(./dhall/Types.dhall).BudgetTransferType" + , MultipleConstructors "TransferCurrency" "(./dhall/Types.dhall).TransferCurrency" + , MultipleConstructors "TransferType" "(./dhall/Types.dhall).TransferType" , MultipleConstructors "TaxMethod" "(./dhall/Types.dhall).TaxMethod" , MultipleConstructors "PeriodType" "(./dhall/Types.dhall).PeriodType" , SingleConstructor "LinkedNumGetter" "LinkedNumGetter" "(./dhall/Types.dhall).LinkedNumGetter.Type" @@ -63,7 +63,7 @@ makeHaskellTypesWith , SingleConstructor "TaxProgression" "TaxProgression" "(./dhall/Types.dhall).TaxProgression" , SingleConstructor "TaxValue" "TaxValue" "(./dhall/Types.dhall).TaxValue" , SingleConstructor "PosttaxValue" "PosttaxValue" "(./dhall/Types.dhall).PosttaxValue" - , SingleConstructor "BudgetTransferValue" "BudgetTransferValue" "(./dhall/Types.dhall).BudgetTransferValue" + , SingleConstructor "TransferValue" "TransferValue" "(./dhall/Types.dhall).TransferValue.Type" , SingleConstructor "Period" "Period" "(./dhall/Types.dhall).Period" , SingleConstructor "HourlyPeriod" "HourlyPeriod" "(./dhall/Types.dhall).HourlyPeriod" -- , SingleConstructor "ToTx" "ToTx" "(./dhall/Types.dhall).ToTx" @@ -97,7 +97,7 @@ deriveProduct , "DateMatcher" , "ValMatcher" , "YMDMatcher" - , "BudgetCurrency" + , "TransferCurrency" , "Exchange" , "EntryNumGetter" , "LinkedNumGetter" @@ -110,8 +110,8 @@ deriveProduct , "TaxProgression" , "TaxMethod" , "PosttaxValue" - , "BudgetTransferValue" - , "BudgetTransferType" + , "TransferValue" + , "TransferType" , "Period" , "PeriodType" , "HourlyPeriod" @@ -183,7 +183,7 @@ deriving instance Ord DatePat deriving instance Hashable DatePat type BudgetTransfer = - Transfer TaggedAcnt BudgetCurrency DatePat BudgetTransferValue + Transfer TaggedAcnt TransferCurrency DatePat TransferValue deriving instance Hashable BudgetTransfer @@ -216,9 +216,21 @@ deriving instance Hashable PosttaxValue deriving instance Hashable Budget -deriving instance Hashable BudgetTransferValue +deriving instance Hashable TransferValue -deriving instance Hashable BudgetTransferType +deriving instance Hashable TransferType + +deriving instance Read TransferType + +instance PersistFieldSql TransferType where + sqlType _ = SqlString + +instance PersistField TransferType where + toPersistValue = PersistText . T.pack . show + + fromPersistValue (PersistText v) = + maybe (Left $ "could not parse: " <> v) Right $ readMaybe $ T.unpack v + fromPersistValue _ = Left "wrong type" deriving instance Hashable TaggedAcnt @@ -262,7 +274,7 @@ deriving instance (Eq w, Eq v) => Eq (Amount w v) deriving instance Hashable Exchange -deriving instance Hashable BudgetCurrency +deriving instance Hashable TransferCurrency data Allocation w v = Allocation { alloTo :: TaggedAcnt diff --git a/lib/Internal/Types/Main.hs b/lib/Internal/Types/Main.hs index 3981583..a5209aa 100644 --- a/lib/Internal/Types/Main.hs +++ b/lib/Internal/Types/Main.hs @@ -36,7 +36,9 @@ data ConfigHashes = ConfigHashes type AccountMap = M.Map AcntID (AccountRId, AcntSign, AcntType) -type CurrencyMap = M.Map CurID (CurrencyRId, Natural) +data CurrencyPrec = CurrencyPrec {cpID :: !CurrencyRId, cpPrec :: !Natural} + +type CurrencyMap = M.Map CurID CurrencyPrec type TagMap = M.Map TagID TagRId @@ -61,7 +63,10 @@ type CurrencyM = Reader CurrencyMap -- type DeferredKeyEntry = Entry AccountRId (Deferred Rational) CurrencyRId TagRId -data DBDeferred = EntryLinked Natural Rational | EntryBalance Rational +data DBDeferred + = EntryLinked Natural Rational + | EntryBalance Rational + | EntryPercent Rational data ReadEntry = ReadEntry { reCurrency :: !CurrencyRId @@ -77,33 +82,37 @@ data UpdateEntry i v = UpdateEntry , ueIndex :: !Int -- TODO this isn't needed for primary entries } +data CurrencyRound = CurrencyRound CurID Natural + deriving instance Functor (UpdateEntry i) newtype LinkScale = LinkScale {unLinkScale :: Rational} deriving newtype (Num) -newtype BalanceTarget = BalanceTarget {unBalanceTarget :: Rational} +-- newtype BalanceTarget = BalanceTarget {unBalanceTarget :: Rational} +-- deriving newtype (Num) + +newtype StaticValue = StaticValue {unStaticValue :: Rational} deriving newtype (Num) -newtype EntryValue = EntryValue {unEntryValue :: Rational} - deriving newtype (Num) +data EntryValueUnk = EVBalance Rational | EVPercent Rational -type UEBalance = UpdateEntry EntryRId BalanceTarget +type UEUnk = UpdateEntry EntryRId EntryValueUnk type UELink = UpdateEntry EntryRId LinkScale type UEBlank = UpdateEntry EntryRId () -type UE_RO = UpdateEntry () EntryValue +type UE_RO = UpdateEntry () StaticValue -type UEBalanced = UpdateEntry EntryRId EntryValue +type UEBalanced = UpdateEntry EntryRId StaticValue data UpdateEntrySet = UpdateEntrySet { utFrom0 :: !UEBlank , utTo0 :: !UEBlank - , utPairs :: ![(UEBalance, [UELink])] - , utFromUnk :: ![UEBalance] - , utToUnk :: ![UEBalance] + , utPairs :: ![(UEUnk, [UELink])] + , utFromUnk :: ![UEUnk] + , utToUnk :: ![UEUnk] , utToUnkLink0 :: ![UELink] , utFromRO :: ![UE_RO] , utToRO :: ![UE_RO] @@ -115,18 +124,18 @@ data UpdateEntrySet = UpdateEntrySet data EntryBin = ToUpdate UpdateEntrySet | ToRead ReadEntry - | ToInsert (DeferredTx CommitR) + | ToInsert (Tx CommitR) -data FullEntry a c t = FullEntry +data InsertEntry a c t = InsertEntry { feCurrency :: !c , feIndex :: !Int , feDeferred :: !(Maybe DBDeferred) , feEntry :: !(Entry a Rational t) } -type KeyEntry = FullEntry AccountRId CurrencyRId TagRId +type KeyEntry = InsertEntry AccountRId CurrencyRId TagRId -type BalEntry = FullEntry AcntID CurID TagID +type BalEntry = InsertEntry AcntID CurID TagID -- type DeferredKeyTx = Tx DeferredKeyEntry @@ -202,50 +211,58 @@ data HalfEntrySet a c t v = HalfEntrySet , hesOther :: ![Entry a v t] } -data EntrySet a c t v = EntrySet - { esTotalValue :: !Rational +data EntrySet a c t v v' = EntrySet + { esTotalValue :: !v' , esCurrency :: !c - , esFrom :: !(HalfEntrySet a c t (Deferred v)) + , esFrom :: !(HalfEntrySet a c t (EntryValue v)) , esTo :: !(HalfEntrySet a c t (LinkDeferred v)) } -data Tx e c = Tx +data Tx k = Tx { txDescr :: !T.Text , txDate :: !Day - , txEntries :: !e - , txCommit :: !c + , txPrimary :: !(EntrySet AcntID CurrencyPrec TagID Rational Rational) + , txOther :: ![EntrySet AcntID CurrencyPrec TagID Rational (EntryValue Rational)] + , txCommit :: !k } deriving (Generic) -type DeferredEntrySet = EntrySet AcntID CurID TagID Rational +data InsertTx = InsertTx + { itxDescr :: !T.Text + , itxDate :: !Day + , itxEntries :: ![InsertEntry AccountRId CurrencyRId TagRId] + , itxCommit :: !CommitR + } + deriving (Generic) + +type DeferredEntrySet = EntrySet AcntID CurrencyPrec TagID Rational type BalEntrySet = EntrySet AcntID CurID TagID Rational type KeyEntrySet = EntrySet AccountRId CurrencyRId TagRId Rational -type DeferredTx = Tx [DeferredEntrySet] +-- type DeferredTx = Tx [DeferredEntrySet] -type BalTx = Tx [BalEntry] +-- type BalTx = InsertTx [BalEntry] -type KeyTx = Tx [KeyEntry] +-- type KeyTx = InsertTx [KeyEntry] data Deferred a = Deferred Bool a deriving (Show, Functor, Foldable, Traversable) -data LinkDeferred a - = LinkDeferred (Deferred a) - | LinkIndex LinkedNumGetter +data EntryValue a = EntryValue TransferType a deriving (Show, Functor, Foldable, Traversable) +data LinkDeferred a + = LinkDeferred (EntryValue a) + | LinkIndex LinkedNumGetter + deriving (Show, Functor, Traversable, Foldable) + -- type RawEntry = Entry AcntID (Deferred Rational) CurID TagID -- type RawFromEntry = Entry AcntID (Deferred Rational) CurID TagID --- type BalEntry = Entry AcntID Rational CurID TagID - --- type RawTx = Tx RawEntry - --- type BalTx = Tx BalEntry +-- type BalEntry = InsertEntry AcntID CurID TagID data MatchRes a = MatchPass !a | MatchFail | MatchSkip diff --git a/lib/Internal/Utils.hs b/lib/Internal/Utils.hs index 656436f..2ec919c 100644 --- a/lib/Internal/Utils.hs +++ b/lib/Internal/Utils.hs @@ -65,7 +65,6 @@ where import Control.Monad.Error.Class import Control.Monad.Except -import Control.Monad.Reader import Data.Time.Format.ISO8601 import GHC.Real import Internal.Types.Main @@ -294,7 +293,7 @@ toDaySpan (a, b) = (a, fromIntegral $ diffDays b a - 1) -------------------------------------------------------------------------------- -- matching -matches :: MatchRe -> TxRecord -> InsertExceptT CurrencyM (MatchRes (DeferredTx ())) +matches :: MonadFinance m => MatchRe -> TxRecord -> InsertExceptT m (MatchRes (Tx ())) matches StatementParser {spTx, spOther, spVal, spDate, spDesc} r@TxRecord {trDate, trAmount, trDesc, trOther} = do @@ -311,7 +310,7 @@ matches desc = maybe (return True) (matchMaybe trDesc . snd) spDesc convert tg = MatchPass <$> toTx tg r -toTx :: TxGetter -> TxRecord -> InsertExceptT CurrencyM (DeferredTx ()) +toTx :: MonadFinance m => TxGetter -> TxRecord -> InsertExceptT m (Tx ()) toTx TxGetter { tgFrom @@ -321,59 +320,43 @@ toTx , tgScale } r@TxRecord {trAmount, trDate, trDesc} = do - combineError curRes subRes $ \(cur, f, t, v) ss -> - -- TODO might be more efficient to set rebalance flag when balancing + combineError curRes subRes $ \(cur, f, t) ss -> Tx { txDate = trDate , txDescr = trDesc , txCommit = () - , txEntries = + , txPrimary = EntrySet - { esTotalValue = v + { esTotalValue = roundPrecisionCur cur $ tgScale * fromRational trAmount , esCurrency = cur , esFrom = f , esTo = t } - : ss + , txOther = ss } where curRes = do - m <- ask - cur <- liftInner $ resolveCurrency r tgCurrency - let fromRes = resolveHalfEntry resolveFromValue cur r tgFrom - let toRes = resolveHalfEntry resolveToValue cur r tgTo - let totRes = - liftExcept $ - roundPrecisionCur cur m $ - tgScale * fromRational trAmount - combineError3 fromRes toRes totRes (cur,,,) + m <- askDBState kmCurrency + cur <- liftInner $ resolveCurrency m r tgCurrency + let fromRes = liftInner $ resolveHalfEntry resolveFromValue cur r tgFrom + let toRes = liftInner $ resolveHalfEntry resolveToValue cur r tgTo + combineError fromRes toRes (cur,,) subRes = mapErrors (resolveSubGetter r) tgOtherEntries --- anyDeferred :: DeferredEntrySet -> Bool --- anyDeferred --- EntrySet --- { esFrom = HalfEntrySet {hesOther = fs} --- , esTo = HalfEntrySet {hesOther = ts} --- } = --- any checkFrom fs || any checkTo ts --- where --- checkFrom Entry {eValue = (Deferred True _)} = True --- checkFrom _ = False --- checkTo = undefined - resolveSubGetter - :: TxRecord + :: MonadFinance m + => TxRecord -> TxSubGetter - -> InsertExceptT CurrencyM (EntrySet AcntID CurID TagID Rational) + -> InsertExceptT m (EntrySet AcntID CurrencyPrec TagID Rational (EntryValue Rational)) resolveSubGetter r TxSubGetter {tsgFrom, tsgTo, tsgValue, tsgCurrency} = do - m <- ask - cur <- liftInner $ resolveCurrency r tsgCurrency - (_, val) <- liftInner $ mapM (roundPrecisionCur cur m) =<< resolveValue r tsgValue + m <- askDBState kmCurrency + cur <- liftInner $ resolveCurrency m r tsgCurrency let fromRes = resolveHalfEntry resolveFromValue cur r tsgFrom let toRes = resolveHalfEntry resolveToValue cur r tsgTo - combineError fromRes toRes $ \f t -> + let valRes = liftInner $ fmap (roundPrecisionCur cur) <$> resolveValue r tsgValue + liftInner $ combineError3 fromRes toRes valRes $ \f t v -> EntrySet - { esTotalValue = val + { esTotalValue = v , esCurrency = cur , esFrom = f , esTo = t @@ -382,10 +365,10 @@ resolveSubGetter r TxSubGetter {tsgFrom, tsgTo, tsgValue, tsgCurrency} = do resolveHalfEntry :: Traversable f => (TxRecord -> n -> InsertExcept (f Double)) - -> CurID + -> CurrencyPrec -> TxRecord -> TxHalfGetter (EntryGetter n) - -> InsertExceptT CurrencyM (HalfEntrySet AcntID CurID TagID (f Rational)) + -> InsertExcept (HalfEntrySet AcntID CurrencyPrec TagID (f Rational)) resolveHalfEntry f cur r TxHalfGetter {thgAcnt, thgComment, thgTags, thgEntries} = combineError acntRes esRes $ \a es -> HalfEntrySet @@ -399,67 +382,9 @@ resolveHalfEntry f cur r TxHalfGetter {thgAcnt, thgComment, thgTags, thgEntries} , hesOther = es } where - acntRes = liftInner $ resolveAcnt r thgAcnt + acntRes = resolveAcnt r thgAcnt esRes = mapErrors (resolveEntry f cur r) thgEntries --- resolveSubGetter --- :: TxRecord --- -> TxSubGetter --- -> InsertExceptT CurrencyM DeferredEntrySet --- resolveSubGetter --- r --- TxSubGetter --- { tsgFromAcnt --- , tsgToAcnt --- , tsgFromTags --- , tsgToTags --- , tsgFromComment --- , tsgToComment --- , tsgValue --- , tsgCurrency --- , tsgFromEntries --- , tsgToEntries --- } = combineErrorM acntRes curRes $ \(fa, ta) (cur, fe, te) -> --- do --- m <- ask --- -- TODO laaaaame... --- (Deferred _ val) <- liftInner $ mapM (roundPrecisionCur cur m) =<< resolveValue r tsgValue --- let fromEntry = --- Entry --- { eAcnt = fa --- , eValue = () --- , eComment = tsgFromComment --- , eTags = tsgFromTags --- } --- let toEntry = --- Entry --- { eAcnt = ta --- , eValue = () --- , eComment = tsgToComment --- , eTags = tsgToTags --- } --- return --- EntrySet --- { desTotalValue = val --- , desCurrency = cur --- , desFromEntry0 = fromEntry --- , desFromEntries = fe --- , desToEntries = te --- , desToEntryBal = toEntry --- } --- where --- resolveAcnt_ = liftInner . resolveAcnt r --- acntRes = --- combineError --- (resolveAcnt_ tsgFromAcnt) --- (resolveAcnt_ tsgToAcnt) --- (,) --- curRes = do --- cur <- liftInner $ resolveCurrency r tsgCurrency --- let feRes = mapErrors (resolveEntry cur r) tsgFromEntries --- let teRes = mapErrors (resolveEntry cur r) tsgToEntries --- combineError feRes teRes (cur,,) - valMatches :: ValMatcher -> Rational -> InsertExcept Bool valMatches ValMatcher {vmDen, vmSign, vmNum, vmPrec} x | Just d_ <- vmDen, d_ >= p = throwError $ InsertException [MatchValPrecisionError d_ p] @@ -487,47 +412,17 @@ otherMatches dict m = case m of resolveEntry :: Traversable f => (TxRecord -> n -> InsertExcept (f Double)) - -> CurID + -> CurrencyPrec -> TxRecord -> EntryGetter n - -> InsertExceptT CurrencyM (Entry AcntID (f Rational) TagID) + -> InsertExcept (Entry AcntID (f Rational) TagID) resolveEntry f cur r s@Entry {eAcnt, eValue} = do - m <- ask - liftInner $ combineErrorM acntRes valRes $ \a v -> do - v' <- mapM (roundPrecisionCur cur m) v - return $ s {eAcnt = a, eValue = v'} + combineError acntRes valRes $ \a v -> + s {eAcnt = a, eValue = roundPrecisionCur cur <$> v} where acntRes = resolveAcnt r eAcnt valRes = f r eValue --- resolveEntry --- :: CurID --- -> TxRecord --- -> EntryGetter n --- -> InsertExceptT CurrencyM (Entry AcntID (Deferred Rational) TagID) --- resolveEntry cur r s@Entry {eAcnt, eValue} = do --- m <- ask --- liftInner $ combineErrorM acntRes valRes $ \a v -> do --- v' <- mapM (roundPrecisionCur cur m) v --- return $ s {eAcnt = a, eValue = v'} --- where --- acntRes = resolveAcnt r eAcnt --- valRes = resolveValue r eValue - --- curRes = resolveCurrency r eCurrency - --- -- TODO wet code (kinda, not sure if it's worth combining with above) --- resolveToEntry :: TxRecord -> EntryGetter -> InsertExceptT CurrencyM RawEntry --- resolveToEntry r s@Entry {eAcnt, eValue, eCurrency} = do --- m <- ask --- liftInner $ combineErrorM3 acntRes curRes valRes $ \a c v -> do --- v' <- mapM (roundPrecisionCur c m) v --- return $ s {eAcnt = a, eValue = maybe Derive (ConstD False) v', eCurrency = c} --- where --- acntRes = resolveAcnt r eAcnt --- curRes = resolveCurrency r eCurrency --- valRes = mapM (resolveToValue r) eValue - liftInner :: Monad m => ExceptT e Identity a -> ExceptT e m a liftInner = mapExceptT (return . runIdentity) @@ -621,27 +516,31 @@ mapErrorsIO f xs = mapM go $ enumTraversable xs collectErrorsIO :: (Traversable t, MonadUnliftIO m) => t (m a) -> m (t a) collectErrorsIO = mapErrorsIO id -resolveFromValue :: TxRecord -> EntryNumGetter -> InsertExcept (Deferred Double) -resolveFromValue r = fmap (uncurry Deferred) . resolveValue r +resolveFromValue :: TxRecord -> EntryNumGetter -> InsertExcept (EntryValue Double) +resolveFromValue = resolveValue resolveToValue :: TxRecord -> LinkedEntryNumGetter -> InsertExcept (LinkDeferred Double) resolveToValue _ (Linked l) = return $ LinkIndex l -resolveToValue r (Getter g) = do - (l, v) <- resolveValue r g - return $ LinkDeferred (Deferred l v) +resolveToValue r (Getter g) = LinkDeferred <$> resolveValue r g -resolveValue :: TxRecord -> EntryNumGetter -> InsertExcept (Bool, Double) +resolveValue :: TxRecord -> EntryNumGetter -> InsertExcept (EntryValue Double) resolveValue TxRecord {trOther, trAmount} s = case s of - (LookupN t) -> (False,) <$> (readDouble =<< lookupErr EntryValField t trOther) - (ConstN c) -> return (False, c) - AmountN m -> return $ (False,) <$> (* m) $ fromRational trAmount - BalanceN x -> return (True, x) + (LookupN t) -> EntryValue TFixed <$> (readDouble =<< lookupErr EntryValField t trOther) + (ConstN c) -> return $ EntryValue TFixed c + AmountN m -> return $ EntryValue TFixed $ m * fromRational trAmount + BalanceN x -> return $ EntryValue TBalance x + PercentN x -> return $ EntryValue TPercent x resolveAcnt :: TxRecord -> EntryAcnt -> InsertExcept T.Text resolveAcnt = resolveEntryField AcntField -resolveCurrency :: TxRecord -> EntryCur -> InsertExcept T.Text -resolveCurrency = resolveEntryField CurField +resolveCurrency :: CurrencyMap -> TxRecord -> EntryCur -> InsertExcept CurrencyPrec +resolveCurrency m r c = do + i <- resolveEntryField CurField r c + case M.lookup i m of + Just k -> return k + -- TODO this should be its own error (I think) + Nothing -> throwError $ InsertException [LookupError (EntryIDField CurField) undefined] resolveEntryField :: EntryIDType -> TxRecord -> EntryAcnt -> InsertExcept T.Text resolveEntryField t TxRecord {trOther = o} s = case s of @@ -728,11 +627,8 @@ roundPrecision n = (% p) . round . (* fromIntegral p) . toRational where p = 10 ^ n -roundPrecisionCur :: CurID -> CurrencyMap -> Double -> InsertExcept Rational -roundPrecisionCur c m x = - case M.lookup c m of - Just (_, n) -> return $ roundPrecision n x - Nothing -> throwError $ InsertException [RoundError c] +roundPrecisionCur :: CurrencyPrec -> Double -> Rational +roundPrecisionCur (CurrencyPrec _ n) = roundPrecision n acntPath2Text :: AcntPath -> T.Text acntPath2Text (AcntPath t cs) = T.intercalate "/" (atName t : cs) @@ -1105,14 +1001,14 @@ lookupAccountSign = fmap sndOf3 . lookupAccount lookupAccountType :: (MonadInsertError m, MonadFinance m) => AcntID -> m AcntType lookupAccountType = fmap thdOf3 . lookupAccount -lookupCurrency :: (MonadInsertError m, MonadFinance m) => CurID -> m (CurrencyRId, Natural) +lookupCurrency :: (MonadInsertError m, MonadFinance m) => CurID -> m CurrencyPrec lookupCurrency = lookupFinance CurField kmCurrency lookupCurrencyKey :: (MonadInsertError m, MonadFinance m) => AcntID -> m CurrencyRId -lookupCurrencyKey = fmap fst . lookupCurrency +lookupCurrencyKey = fmap cpID . lookupCurrency lookupCurrencyPrec :: (MonadInsertError m, MonadFinance m) => AcntID -> m Natural -lookupCurrencyPrec = fmap snd . lookupCurrency +lookupCurrencyPrec = fmap cpPrec . lookupCurrency lookupTag :: (MonadInsertError m, MonadFinance m) => TagID -> m TagRId lookupTag = lookupFinance TagField kmTag