WIP make budget and statement paths use same machinery

This commit is contained in:
Nathan Dwarshuis 2023-06-29 21:32:14 -04:00
parent d617fa52cc
commit cc0699eb4e
8 changed files with 461 additions and 405 deletions

View File

@ -402,13 +402,15 @@ let EntryNumGetter =
LookupN: lookup the value from a field LookupN: lookup the value from a field
ConstN: a constant value 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 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 < LookupN : Text
| ConstN : Double | ConstN : Double
| AmountN : Double | AmountN : Double
| BalanceN : Double | BalanceN : Double
| PercentN : Double
> >
let LinkedNumGetter = let LinkedNumGetter =
@ -679,6 +681,58 @@ let Amount =
\(v : Type) -> \(v : Type) ->
{ amtWhen : w, amtValue : v, amtDesc : Text } { 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 = let Transfer =
{- {-
1-1 transaction(s) between two accounts. 1-1 transaction(s) between two accounts.
@ -697,7 +751,7 @@ let HistTransfer =
{- {-
A manually specified historical transfer A manually specified historical transfer
-} -}
Transfer AcntID CurID DatePat Double Transfer AcntID CurID DatePat TransferValue.Type
let Statement = let Statement =
{- {-
@ -734,38 +788,6 @@ let History =
-} -}
< HistTransfer : HistTransfer | HistStatement : Statement > < 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 = let TaggedAcnt =
{- {-
An account with a tag 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 = let ShadowTransfer =
{- {-
A transaction analogous to another transfer with given properties. A transaction analogous to another transfer with given properties.
@ -1066,7 +1077,7 @@ let ShadowTransfer =
{- {-
Currency of this transfer. Currency of this transfer.
-} -}
BudgetCurrency TransferCurrency
, stDesc : , stDesc :
{- {-
Description of this transfer. Description of this transfer.
@ -1080,7 +1091,7 @@ let ShadowTransfer =
specified in other fields of this type. specified in other fields of this type.
-} -}
TransferMatcher.Type TransferMatcher.Type
, stType : BudgetTransferType , stType : TransferType
, stRatio : , stRatio :
{- {-
Fixed multipler to translate value of matched transfer to this one. Fixed multipler to translate value of matched transfer to this one.
@ -1088,17 +1099,11 @@ let ShadowTransfer =
Double Double
} }
let BudgetTransferValue =
{-
Means to determine the value of a budget transfer.
-}
{ btVal : Double, btType : BudgetTransferType }
let BudgetTransfer = let BudgetTransfer =
{- {-
A manually specified transaction for a budget A manually specified transaction for a budget
-} -}
Transfer TaggedAcnt BudgetCurrency DatePat BudgetTransferValue Transfer TaggedAcnt TransferCurrency DatePat TransferValue.Type
let Budget = let Budget =
{- {-
@ -1168,7 +1173,7 @@ in { CurID
, TransferMatcher , TransferMatcher
, ShadowTransfer , ShadowTransfer
, AcntSet , AcntSet
, BudgetCurrency , TransferCurrency
, Exchange , Exchange
, TaggedAcnt , TaggedAcnt
, AccountTree , AccountTree
@ -1180,8 +1185,8 @@ in { CurID
, TaxProgression , TaxProgression
, TaxMethod , TaxMethod
, TaxValue , TaxValue
, BudgetTransferValue , TransferValue
, BudgetTransferType , TransferType
, TxGetter , TxGetter
, TxSubGetter , TxSubGetter
, TxHalfGetter , TxHalfGetter

View File

@ -59,6 +59,8 @@ insertBudget
++ (alloAcnt <$> bgtTax) ++ (alloAcnt <$> bgtTax)
++ (alloAcnt <$> bgtPosttax) ++ (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 :: [UnbalancedTransfer] -> [BalancedTransfer]
balanceTransfers = snd . L.mapAccumR go M.empty . reverse . L.sortOn ftWhen balanceTransfers = snd . L.mapAccumR go M.empty . reverse . L.sortOn ftWhen
where where
@ -527,8 +529,64 @@ data UnbalancedValue = UnbalancedValue
} }
deriving (Show) 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 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 type BalancedTransfer = FlatTransfer Rational
data FlatTransfer v = FlatTransfer data FlatTransfer v = FlatTransfer

View File

@ -193,7 +193,7 @@ currencyMap =
. fmap . fmap
( \e -> ( \e ->
( currencyRSymbol $ entityVal 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 :: MonadSqlQuery m => TransactionRId -> KeyEntry -> m EntryRId
insertEntry insertEntry
t t
FullEntry InsertEntry
{ feEntry = Entry {eValue, eTags, eAcnt, eComment} { feEntry = Entry {eValue, eTags, eAcnt, eComment}
, feCurrency , feCurrency
, feIndex , feIndex
, feDeferred , feDeferred
} = } =
do 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 mapM_ (insert_ . TagRelationR k) eTags
return k return k
where where
(defval, deflink) = case feDeferred of (cval, ctype, deflink) = case feDeferred of
(Just (EntryLinked index scale)) -> (Just scale, Just $ fromIntegral index) (Just (EntryLinked index scale)) -> (Just scale, Nothing, Just $ fromIntegral index)
(Just (EntryBalance target)) -> (Just target, Nothing) (Just (EntryBalance target)) -> (Just target, Just TBalance, Nothing)
Nothing -> (Nothing, Nothing) (Just (EntryPercent target)) -> (Just target, Just TPercent, Nothing)
Nothing -> (Nothing, Just TFixed, Nothing)
resolveEntry :: (MonadInsertError m, MonadFinance m) => BalEntry -> m KeyEntry 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 aRes = lookupAccountKey eAcnt
let cRes = lookupCurrencyKey feCurrency let cRes = lookupCurrencyKey feCurrency
let sRes = lookupAccountSign eAcnt let sRes = lookupAccountSign eAcnt
@ -516,26 +517,26 @@ readUpdates hashes = do
splitFrom splitFrom
:: [(EntryRId, EntryR)] :: [(EntryRId, EntryR)]
-> InsertExcept (UEBlank, [UE_RO], [UEBalance], Vector (Maybe UEBalance)) -> InsertExcept (UEBlank, [UE_RO], [UEUnk], Vector (Maybe UEUnk))
splitFrom from = do splitFrom from = do
-- ASSUME entries are sorted by index -- ASSUME entries are sorted by index
(primary, rest) <- case from of (primary, rest) <- case from of
((i, e) : xs) -> return (makeUnkUE i e, xs) ((i, e) : xs) -> return (makeUnkUE i e, xs)
_ -> throwError $ InsertException undefined _ -> throwError $ InsertException undefined
let rest' = fmap splitDeferredValue rest rest' <- mapErrors splitDeferredValue rest
let idxVec = V.fromList $ fmap (either (const Nothing) Just) rest' let idxVec = V.fromList $ fmap (either (const Nothing) Just) rest'
let (ro, toBal) = partitionEithers rest' let (ro, toBal) = partitionEithers rest'
return (primary, ro, toBal, idxVec) return (primary, ro, toBal, idxVec)
splitTo splitTo
:: Vector (Maybe UEBalance) :: Vector (Maybe UEUnk)
-> [(EntryRId, EntryR)] -> [(EntryRId, EntryR)]
-> InsertExcept -> InsertExcept
( UEBlank ( UEBlank
, [UE_RO] , [UE_RO]
, [UEBalance] , [UEUnk]
, [UELink] , [UELink]
, [(UEBalance, [UELink])] , [(UEUnk, [UELink])]
) )
splitTo froms tos = do splitTo froms tos = do
-- How to split the credit side of the database transaction in 1024 easy -- 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 let (unlinked, linked) = partitionEithers $ fmap splitLinked rest
-- 2. Split unlinked based on if they have a balance target -- 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 -- 3. Split paired entries by link == 0 (which are special) or link > 0
let (paired0, pairedN) = second (groupKey id) $ L.partition ((== 0) . fst) linked 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 -- then consider the linked entry as another credit read-only entry
let pairedRes = partitionEithers <$> mapErrors splitPaired pairedN let pairedRes = partitionEithers <$> mapErrors splitPaired pairedN
combineError paired0Res pairedRes $ \paired0' (pairedUnk, pairedRO) -> combineError3 unlinkedRes paired0Res pairedRes $
(primary, ro ++ concat pairedRO, toBal, paired0', pairedUnk) \(ro, toBal) paired0' (pairedUnk, pairedRO) ->
(primary, ro ++ concat pairedRO, toBal, paired0', pairedUnk)
where 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 splitPaired (lnk, ts) = case froms V.!? (lnk - 1) of
Just (Just f) -> Left . (f,) <$> mapErrors makeLinkUnk ts Just (Just f) -> Left . (f,) <$> mapErrors makeLinkUnk ts
Just Nothing -> return $ Right $ makeRoUE . snd <$> ts Just Nothing -> return $ Right $ makeRoUE . snd <$> ts
@ -577,18 +579,22 @@ splitTo froms tos = do
maybe maybe
(throwError $ InsertException undefined) (throwError $ InsertException undefined)
(return . makeUE k e . LinkScale) (return . makeUE k e . LinkScale)
$ entryRDeferred_value e $ entryRCachedValue e
splitDeferredValue :: (EntryRId, EntryR) -> Either UE_RO UEBalance splitDeferredValue :: (EntryRId, EntryR) -> InsertExcept (Either UE_RO UEUnk)
splitDeferredValue (k, e) = splitDeferredValue (k, e) = case (entryRCachedValue e, entryRCachedType e) of
maybe (Left $ makeRoUE e) (Right . fmap BalanceTarget . makeUE k e) $ (Nothing, Just TFixed) -> return $ Left $ makeRoUE e
entryRDeferred_value 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 :: i -> EntryR -> v -> UpdateEntry i v
makeUE k e v = UpdateEntry k (entryRAccount e) v (entryRIndex e) makeUE k e v = UpdateEntry k (entryRAccount e) v (entryRIndex e)
makeRoUE :: EntryR -> UpdateEntry () EntryValue makeRoUE :: EntryR -> UpdateEntry () StaticValue
makeRoUE e = makeUE () e $ EntryValue (entryRValue e) makeRoUE e = makeUE () e $ StaticValue (entryRValue e)
makeUnkUE :: EntryRId -> EntryR -> UpdateEntry EntryRId () makeUnkUE :: EntryRId -> EntryR -> UpdateEntry EntryRId ()
makeUnkUE k e = makeUE k e () makeUnkUE k e = makeUE k e ()

View File

@ -39,7 +39,7 @@ import qualified RIO.Vector as V
readHistTransfer readHistTransfer
:: (MonadInsertError m, MonadFinance m) :: (MonadInsertError m, MonadFinance m)
=> HistTransfer => HistTransfer
-> m [DeferredTx CommitR] -> m [Tx CommitR]
readHistTransfer readHistTransfer
m@Transfer m@Transfer
{ transFrom = from { transFrom = from
@ -49,11 +49,11 @@ readHistTransfer
} = } =
whenHash0 CTManual m [] $ \c -> do whenHash0 CTManual m [] $ \c -> do
bounds <- askDBState kmStatementInterval bounds <- askDBState kmStatementInterval
let precRes = lookupCurrencyPrec u let curRes = lookupCurrency u
let go Amount {amtWhen, amtValue, amtDesc} = do let go Amount {amtWhen, amtValue, amtDesc} = do
let dayRes = liftExcept $ expandDatePat bounds amtWhen let dayRes = liftExcept $ expandDatePat bounds amtWhen
(days, precision) <- combineError dayRes precRes (,) (days, cur) <- combineError dayRes curRes (,)
let tx day = txPair c day from to u (roundPrecision precision amtValue) amtDesc let tx day = txPair c day from to cur amtValue amtDesc
return $ fmap tx days return $ fmap tx days
concat <$> mapErrors go amts concat <$> mapErrors go amts
@ -61,7 +61,7 @@ readHistStmt
:: (MonadUnliftIO m, MonadFinance m) :: (MonadUnliftIO m, MonadFinance m)
=> FilePath => FilePath
-> Statement -> Statement
-> m (Either CommitR [DeferredTx CommitR]) -> m (Either CommitR [Tx CommitR])
readHistStmt root i = eitherHash CTImport i return $ \c -> do readHistStmt root i = eitherHash CTImport i return $ \c -> do
bs <- readImport root i bs <- readImport root i
bounds <- askDBState kmStatementInterval bounds <- askDBState kmStatementInterval
@ -80,9 +80,9 @@ insertHistory
insertHistory hs = do insertHistory hs = do
(toUpdate, toInsert) <- balanceTxs hs (toUpdate, toInsert) <- balanceTxs hs
mapM_ updateTx toUpdate mapM_ updateTx toUpdate
forM_ (groupKey commitRHash $ (\x -> (txCommit x, x)) <$> toInsert) $ forM_ (groupKey commitRHash $ (\x -> (itxCommit x, x)) <$> toInsert) $
\(c, ts) -> do \(c, ts) -> do
ck <- insert $ c ck <- insert c
mapM_ (insertTx ck) ts mapM_ (insertTx ck) ts
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
@ -94,23 +94,23 @@ txPair
-> Day -> Day
-> AcntID -> AcntID
-> AcntID -> AcntID
-> CurID -> CurrencyPrec
-> Rational -> Double
-> T.Text -> T.Text
-> DeferredTx CommitR -> Tx CommitR
txPair commit day from to cur val desc = txPair commit day from to cur val desc =
Tx Tx
{ txDescr = desc { txDescr = desc
, txDate = day , txDate = day
, txCommit = commit , txCommit = commit
, txEntries = , txPrimary =
[ EntrySet EntrySet
{ esTotalValue = -val { esTotalValue = -(roundPrecisionCur cur val)
, esCurrency = cur , esCurrency = cur
, esFrom = HalfEntrySet {hesPrimary = entry from, hesOther = []} , esFrom = HalfEntrySet {hesPrimary = entry from, hesOther = []}
, esTo = HalfEntrySet {hesPrimary = entry to, hesOther = []} , esTo = HalfEntrySet {hesPrimary = entry to, hesOther = []}
} }
] , txOther = []
} }
where where
entry a = entry a =
@ -125,31 +125,27 @@ txPair commit day from to cur val desc =
-- resolveTx t@Tx {txEntries = ss} = -- resolveTx t@Tx {txEntries = ss} =
-- (\kss -> t {txEntries = kss}) <$> mapErrors resolveEntry ss -- (\kss -> t {txEntries = kss}) <$> mapErrors resolveEntry ss
insertTx :: MonadSqlQuery m => CommitRId -> (KeyTx CommitR) -> m () insertTx :: MonadSqlQuery m => CommitRId -> InsertTx -> m ()
insertTx c Tx {txDate = d, txDescr = e, txEntries = ss} = do insertTx c InsertTx {itxDate = d, itxDescr = e, itxEntries = ss} = do
let anyDeferred = any (isJust . feDeferred) ss let anyDeferred = any (isJust . feDeferred) ss
k <- insert $ TransactionR c d e anyDeferred k <- insert $ TransactionR c d e anyDeferred
mapM_ (insertEntry k) ss mapM_ (insertEntry k) ss
updateTx :: MonadSqlQuery m => UEBalanced -> m () updateTx :: MonadSqlQuery m => UEBalanced -> m ()
updateTx UpdateEntry {ueID, ueValue} = update ueID [EntryRValue =. (unEntryValue ueValue)] updateTx UpdateEntry {ueID, ueValue} = update ueID [EntryRValue =. unStaticValue ueValue]
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Statements -- Statements
-- TODO this probably won't scale well (pipes?) -- 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 readImport root Statement {stmtTxOpts, stmtParsers, stmtSkipLines, stmtDelim, stmtPaths} = do
let ores = compileOptions stmtTxOpts let ores = compileOptions stmtTxOpts
let cres = combineErrors $ compileMatch <$> stmtParsers let cres = combineErrors $ compileMatch <$> stmtParsers
(compiledOptions, compiledMatches) <- liftIOExcept $ combineError ores cres (,) (compiledOptions, compiledMatches) <- liftIOExcept $ combineError ores cres (,)
let readStmt = readImport_ stmtSkipLines stmtDelim compiledOptions let readStmt = readImport_ stmtSkipLines stmtDelim compiledOptions
records <- L.sort . concat <$> mapErrorsIO readStmt paths records <- L.sort . concat <$> mapErrorsIO readStmt paths
m <- askDBState kmCurrency fromEither =<< runExceptT (matchRecords compiledMatches records)
fromEither $
flip runReader m $
runExceptT $
matchRecords compiledMatches records
where where
paths = (root </>) <$> stmtPaths paths = (root </>) <$> stmtPaths
@ -184,13 +180,11 @@ parseTxRecord p TxOpts {toDate, toAmountFmt, toDesc, toAmount, toOther, toDateFm
d' <- parseTimeM True defaultTimeLocale (T.unpack toDateFmt) d d' <- parseTimeM True defaultTimeLocale (T.unpack toDateFmt) d
return $ Just $ TxRecord d' a e os p return $ Just $ TxRecord d' a e os p
-- TODO need to somehow balance temporally here (like I do in the budget for matchRecords :: MonadFinance m => [MatchRe] -> [TxRecord] -> InsertExceptT m [Tx ()]
-- directives that "pay off" a balance)
matchRecords :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM [DeferredTx ()]
matchRecords ms rs = do matchRecords ms rs = do
(matched, unmatched, notfound) <- matchAll (matchPriorities ms) rs (matched, unmatched, notfound) <- matchAll (matchPriorities ms) rs
case (matched, unmatched, notfound) of case (matched, unmatched, notfound) of
(ms_, [], []) -> return ms_ -- liftInner $ combineErrors $ fmap balanceTx ms_ (ms_, [], []) -> return ms_
(_, us, ns) -> throwError $ InsertException [StatementError us ns] (_, us, ns) -> throwError $ InsertException [StatementError us ns]
matchPriorities :: [MatchRe] -> [MatchGroup] matchPriorities :: [MatchRe] -> [MatchGroup]
@ -245,9 +239,10 @@ zipperSlice f x = go
LT -> z LT -> z
zipperMatch zipperMatch
:: Unzipped MatchRe :: MonadFinance m
=> Unzipped MatchRe
-> TxRecord -> TxRecord
-> InsertExceptT CurrencyM (Zipped MatchRe, MatchRes (DeferredTx ())) -> InsertExceptT m (Zipped MatchRe, MatchRes (Tx ()))
zipperMatch (Unzipped bs cs as) x = go [] cs zipperMatch (Unzipped bs cs as) x = go [] cs
where where
go _ [] = return (Zipped bs $ cs ++ as, MatchFail) 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) in return (Zipped bs $ ps ++ ms' ++ as, skipOrPass)
zipperMatch' zipperMatch'
:: Zipped MatchRe :: MonadFinance m
=> Zipped MatchRe
-> TxRecord -> TxRecord
-> InsertExceptT CurrencyM (Zipped MatchRe, MatchRes (DeferredTx ())) -> InsertExceptT m (Zipped MatchRe, MatchRes (Tx ()))
zipperMatch' z x = go z zipperMatch' z x = go z
where where
go (Zipped bs (a : as)) = do go (Zipped bs (a : as)) = do
@ -280,7 +276,11 @@ matchDec m = case spTimes m of
Just n -> Just $ m {spTimes = Just $ n - 1} Just n -> Just $ m {spTimes = Just $ n - 1}
Nothing -> Just m Nothing -> Just m
matchAll :: [MatchGroup] -> [TxRecord] -> InsertExceptT CurrencyM ([DeferredTx ()], [TxRecord], [MatchRe]) matchAll
:: MonadFinance m
=> [MatchGroup]
-> [TxRecord]
-> InsertExceptT m ([Tx ()], [TxRecord], [MatchRe])
matchAll = go ([], []) matchAll = go ([], [])
where where
go (matched, unused) gs rs = case (gs, rs) of go (matched, unused) gs rs = case (gs, rs) of
@ -290,13 +290,21 @@ matchAll = go ([], [])
(ts, unmatched, us) <- matchGroup g rs (ts, unmatched, us) <- matchGroup g rs
go (ts ++ matched, us ++ unused) gs' unmatched 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 matchGroup MatchGroup {mgDate = ds, mgNoDate = ns} rs = do
(md, rest, ud) <- matchDates ds rs (md, rest, ud) <- matchDates ds rs
(mn, unmatched, un) <- matchNonDates ns rest (mn, unmatched, un) <- matchNonDates ns rest
return (md ++ mn, unmatched, filter ((/= Nothing) . spTimes) $ ud ++ un) 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) matchDates ms = go ([], [], initZipper ms)
where where
go (matched, unmatched, z) [] = go (matched, unmatched, z) [] =
@ -317,7 +325,11 @@ matchDates ms = go ([], [], initZipper ms)
go (m, u, z') rs go (m, u, z') rs
findDate m r = maybe EQ (`compareDate` trDate r) $ spDate m 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) matchNonDates ms = go ([], [], initZipper ms)
where where
go (matched, unmatched, z) [] = go (matched, unmatched, z) [] =
@ -337,18 +349,29 @@ matchNonDates ms = go ([], [], initZipper ms)
balanceTxs balanceTxs
:: (MonadInsertError m, MonadFinance m) :: (MonadInsertError m, MonadFinance m)
=> [EntryBin] => [EntryBin]
-> m ([UEBalanced], [KeyTx CommitR]) -> m ([UEBalanced], [InsertTx])
balanceTxs es = balanceTxs ebs =
first concat . partitionEithers . catMaybes first concat . partitionEithers . catMaybes
<$> evalStateT (mapErrors go $ L.sortOn binDate es) M.empty <$> evalStateT (mapErrors go $ L.sortOn binDate ebs) M.empty
where where
go (ToUpdate utx) = fmap (Just . Left) $ liftInnerS $ rebalanceEntrySet utx go (ToUpdate utx) = fmap (Just . Left) $ liftInnerS $ rebalanceEntrySet utx
go (ToRead ReadEntry {reCurrency, reAcnt, reValue}) = do go (ToRead ReadEntry {reCurrency, reAcnt, reValue}) = do
modify $ mapAdd_ (reAcnt, reCurrency) reValue modify $ mapAdd_ (reAcnt, reCurrency) reValue
return Nothing return Nothing
go (ToInsert t@Tx {txEntries}) = go (ToInsert Tx {txPrimary, txOther, txDescr, txCommit, txDate}) =
(\es' -> Just $ Right $ t {txEntries = concat es'}) let res0 = balanceEntrySet (\_ _ v -> return v) txPrimary
<$> mapErrors balanceEntrySet txEntries 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 :: EntryBin -> Day
binDate (ToUpdate UpdateEntrySet {utDate}) = utDate binDate (ToUpdate UpdateEntrySet {utDate}) = utDate
@ -359,9 +382,10 @@ type EntryBals = M.Map (AccountRId, CurrencyRId) Rational
data UpdateEntryType a data UpdateEntryType a
= UET_ReadOnly UE_RO = UET_ReadOnly UE_RO
| UET_Balance UEBalance | UET_Unk UEUnk
| UET_Linked a | UET_Linked a
-- TODO make sure new values are rounded properly here
rebalanceEntrySet :: UpdateEntrySet -> State EntryBals [UEBalanced] rebalanceEntrySet :: UpdateEntrySet -> State EntryBals [UEBalanced]
rebalanceEntrySet rebalanceEntrySet
UpdateEntrySet UpdateEntrySet
@ -377,112 +401,124 @@ rebalanceEntrySet
, utTotalValue , utTotalValue
} = } =
do do
let fs = (f0val, (tpairs, fs)) <-
fmap (second partitionEithers) $
foldM goFrom (utTotalValue, []) $
L.sortOn idx $ L.sortOn idx $
(UET_ReadOnly <$> utFromRO) (UET_ReadOnly <$> utFromRO)
++ (UET_Balance <$> utFromUnk) ++ (UET_Unk <$> utFromUnk)
++ (UET_Linked <$> utPairs) ++ (UET_Linked <$> utPairs)
fs' <- mapM goFrom fs let f0 = utFrom0 {ueValue = StaticValue f0val}
let f0val = utTotalValue - sum (fmap value fs') let tsLink0 = fmap (unlink (-f0val)) utToUnkLink0
let f0 = utFrom0 {ueValue = EntryValue f0val} (t0val, tsUnk) <-
let (tpairs, fs'') = partitionEithers $ concatMap flatten fs' fmap (second catMaybes) $
let tsLink0 = fmap (\e -> e {ueValue = EntryValue $ -f0val * unLinkScale (ueValue e)}) utToUnkLink0 foldM goTo (-utTotalValue, []) $
let ts =
L.sortOn idx2 $ L.sortOn idx2 $
(UET_Linked <$> (tpairs ++ tsLink0)) (UET_Linked <$> (tpairs ++ tsLink0))
++ (UET_Balance <$> utToUnk) ++ (UET_Unk <$> utToUnk)
++ (UET_ReadOnly <$> utToRO) ++ (UET_ReadOnly <$> utToRO)
(tsRO, tsUnk) <- partitionEithers <$> mapM goTo ts let t0 = utTo0 {ueValue = StaticValue t0val}
let t0val = return (f0 : fs ++ (t0 : tsUnk))
EntryValue utTotalValue
- sum (fmap ueValue tsRO ++ fmap ueValue tsUnk)
let t0 = utTo0 {ueValue = t0val}
return $ (f0 : fmap (fmap (EntryValue . unBalanceTarget)) fs'') ++ (t0 : tsUnk)
where where
project f _ _ (UET_ReadOnly e) = f e 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 project _ _ f (UET_Linked p) = f p
idx = project ueIndex ueIndex (ueIndex . fst) idx = project ueIndex ueIndex (ueIndex . fst)
idx2 = project ueIndex ueIndex ueIndex idx2 = project ueIndex ueIndex ueIndex
value = -- TODO the sum accumulator thing is kinda awkward
project goFrom (tot, es) (UET_ReadOnly e) = do
(unEntryValue . ueValue) v <- updateFixed e
(unBalanceTarget . ueValue) return (tot - v, es)
(unBalanceTarget . ueValue . fst) goFrom (tot, esPrev) (UET_Unk e) = do
flatten = project (const []) ((: []) . Right) (\(a, bs) -> Right a : (Left <$> bs)) v <- updateUnknown e
-- TODO the following is wetter than the average groupie return (tot - v, Right e {ueValue = StaticValue v} : esPrev)
goFrom (UET_ReadOnly e) = do goFrom (tot, esPrev) (UET_Linked (e0, es)) = do
modify $ mapAdd_ (ueAcnt e, utCurrency) (unEntryValue $ ueValue e) v <- updateUnknown e0
return $ UET_ReadOnly e let e0' = Right $ e0 {ueValue = StaticValue v}
goFrom (UET_Balance e) = do 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) let key = (ueAcnt e, utCurrency)
curBal <- gets (M.findWithDefault 0 key) curBal <- gets (M.findWithDefault 0 key)
let newVal = unBalanceTarget (ueValue e) - curBal let v = case ueValue e of
modify $ mapAdd_ key newVal EVPercent p -> p * curBal
return $ UET_Balance $ e {ueValue = BalanceTarget newVal} EVBalance p -> p - curBal
goFrom (UET_Linked (e0, es)) = do modify $ mapAdd_ key v
let key = (ueAcnt e0, utCurrency) return v
curBal <- gets (M.findWithDefault 0 key) unlink v e = e {ueValue = StaticValue $ v * unLinkScale (ueValue e)}
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}
balanceEntrySet balanceEntrySet
:: (MonadInsertError m, MonadFinance m) :: (MonadInsertError m, MonadFinance m)
=> DeferredEntrySet => (Entry AccountRId AcntSign TagRId -> CurrencyRId -> v -> State EntryBals Rational)
-> DeferredEntrySet v
-> StateT EntryBals m [KeyEntry] -> StateT EntryBals m [KeyEntry]
balanceEntrySet balanceEntrySet
findTot
EntrySet EntrySet
{ esFrom = HalfEntrySet {hesPrimary = f0, hesOther = fs} { esFrom = HalfEntrySet {hesPrimary = f0, hesOther = fs}
, esTo = HalfEntrySet {hesPrimary = t0, hesOther = ts} , esTo = HalfEntrySet {hesPrimary = t0, hesOther = ts}
, esCurrency , esCurrency = CurrencyPrec {cpID = curID, cpPrec = precision}
, esTotalValue , esTotalValue
} = } =
do do
-- get currency first and quit immediately on exception since everything -- 1. Resolve tag and accout ids in primary entries since we (might) need
-- downstream depends on this -- them later to calculate the total value of the transaction.
(curID, precision) <- lookupCurrency esCurrency 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 -- 3. Balance all debit entries (including primary). Note the negative
-- of debit entries for linked credit entries later -- indices, which will signify them to be debit entries when updated
let balFromEntry = balanceEntry (\a -> liftInnerS . balanceDeferred curID a) curID -- later.
fs' <- doEntries balFromEntry curID esTotalValue f0 fs (NE.iterate (+ (-1)) (-1)) let balFromEntry = balanceEntry (\a -> liftInnerS . balanceDeferred curID a) curID
let fv = V.fromList $ fmap (eValue . feEntry) fs' fs' <- doEntries balFromEntry curID tot f0' fs (NE.iterate (+ (-1)) (-1))
-- finally resolve credit entries -- 4. Build an array of debit values be linked as desired in credit entries
let balToEntry = balanceEntry (balanceLinked fv curID precision) curID let fv = V.fromList $ fmap (eValue . feEntry) fs'
ts' <- doEntries balToEntry curID (-esTotalValue) t0 ts (NE.iterate (+ 1) 0)
return $ fs' ++ ts' -- 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 doEntries
:: (MonadInsertError m, MonadFinance m) :: (MonadInsertError m)
=> (Int -> Entry AcntID v TagID -> StateT EntryBals m (FullEntry AccountRId CurrencyRId TagRId)) => (Int -> Entry AcntID v TagID -> StateT EntryBals m (InsertEntry AccountRId CurrencyRId TagRId))
-> CurrencyRId -> CurrencyRId
-> Rational -> Rational
-> Entry AcntID () TagID -> Entry AccountRId AcntSign TagRId
-> [Entry AcntID v TagID] -> [Entry AcntID v TagID]
-> NonEmpty Int -> 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 doEntries f curID tot e es (i0 :| iN) = do
es' <- mapErrors (uncurry f) $ zip iN es es' <- mapErrors (uncurry f) $ zip iN es
let val0 = tot - entrySum es' let e0val = tot - entrySum es'
e' <- balanceEntry (\_ _ -> return (val0, Nothing)) curID i0 e -- 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' return $ e' : es'
where where
entrySum = sum . fmap (eValue . feEntry) entrySum = sum . fmap (eValue . feEntry)
@ -502,7 +538,7 @@ balanceLinked from curID precision acntID lg = case lg of
(LinkIndex LinkedNumGetter {lngIndex, lngScale}) -> do (LinkIndex LinkedNumGetter {lngIndex, lngScale}) -> do
let res = fmap (go lngScale) $ from V.!? fromIntegral lngIndex let res = fmap (go lngScale) $ from V.!? fromIntegral lngIndex
case res of 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 -- TODO this error would be much more informative if I had access to the
-- file from which it came -- file from which it came
Nothing -> throwError undefined Nothing -> throwError undefined
@ -513,11 +549,15 @@ balanceLinked from curID precision acntID lg = case lg of
balanceDeferred balanceDeferred
:: CurrencyRId :: CurrencyRId
-> AccountRId -> AccountRId
-> Deferred Rational -> EntryValue Rational
-> State EntryBals (Rational, Maybe DBDeferred) -> State EntryBals (Rational, Maybe DBDeferred)
balanceDeferred curID acntID (Deferred toBal v) = do balanceDeferred curID acntID (EntryValue t v) = do
newval <- findBalance acntID curID toBal v newval <- findBalance acntID curID t v
return $ (newval, if toBal then Just (EntryBalance v) else Nothing) let d = case t of
TFixed -> Nothing
TBalance -> Just $ EntryBalance v
TPercent -> Just $ EntryPercent v
return (newval, d)
balanceEntry balanceEntry
:: (MonadInsertError m, MonadFinance m) :: (MonadInsertError m, MonadFinance m)
@ -525,7 +565,7 @@ balanceEntry
-> CurrencyRId -> CurrencyRId
-> Int -> Int
-> Entry AcntID v TagID -> 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 balanceEntry f curID idx e@Entry {eValue, eAcnt, eTags} = do
let acntRes = lookupAccount eAcnt let acntRes = lookupAccount eAcnt
let tagRes = mapErrors lookupTag eTags let tagRes = mapErrors lookupTag eTags
@ -534,17 +574,37 @@ balanceEntry f curID idx e@Entry {eValue, eAcnt, eTags} = do
(newVal, deferred) <- f acntID eValue (newVal, deferred) <- f acntID eValue
modify (mapAdd_ (acntID, curID) newVal) modify (mapAdd_ (acntID, curID) newVal)
return $ return $
FullEntry InsertEntry
{ feEntry = e {eValue = s * newVal, eAcnt = acntID, eTags = tags} { feEntry = e {eValue = s * newVal, eAcnt = acntID, eTags = tags}
, feCurrency = curID , feCurrency = curID
, feDeferred = deferred , feDeferred = deferred
, feIndex = idx , feIndex = idx
} }
findBalance :: AccountRId -> CurrencyRId -> Bool -> Rational -> State EntryBals Rational resolveAcntAndTags
findBalance acnt cur toBal v = do :: (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)) 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 :/ -- -- reimplementation from future version :/
-- mapAccumM -- mapAccumM

View File

@ -9,6 +9,7 @@ module Internal.Types.Database where
import Database.Persist.Sql hiding (Desc, In, Statement) import Database.Persist.Sql hiding (Desc, In, Statement)
import Database.Persist.TH import Database.Persist.TH
import Internal.Types.Dhall
import RIO import RIO
import qualified RIO.Text as T import qualified RIO.Text as T
import RIO.Time import RIO.Time
@ -52,8 +53,9 @@ EntryR sql=entries
memo T.Text memo T.Text
value Rational value Rational
index Int index Int
deferred_value (Maybe Rational) cachedValue (Maybe Rational)
deferred_link (Maybe Int) cachedType (Maybe TransferType)
cachedLink (Maybe Int)
deriving Show Eq deriving Show Eq
TagRelationR sql=tag_relations TagRelationR sql=tag_relations
entry EntryRId OnDeleteCascade entry EntryRId OnDeleteCascade

View File

@ -34,8 +34,8 @@ makeHaskellTypesWith
, MultipleConstructors "DateMatcher" "(./dhall/Types.dhall).DateMatcher" , MultipleConstructors "DateMatcher" "(./dhall/Types.dhall).DateMatcher"
, MultipleConstructors "EntryNumGetter" "(./dhall/Types.dhall).EntryNumGetter" , MultipleConstructors "EntryNumGetter" "(./dhall/Types.dhall).EntryNumGetter"
, MultipleConstructors "LinkedEntryNumGetter" "(./dhall/Types.dhall).LinkedEntryNumGetter" , MultipleConstructors "LinkedEntryNumGetter" "(./dhall/Types.dhall).LinkedEntryNumGetter"
, MultipleConstructors "BudgetCurrency" "(./dhall/Types.dhall).BudgetCurrency" , MultipleConstructors "TransferCurrency" "(./dhall/Types.dhall).TransferCurrency"
, MultipleConstructors "BudgetTransferType" "(./dhall/Types.dhall).BudgetTransferType" , MultipleConstructors "TransferType" "(./dhall/Types.dhall).TransferType"
, MultipleConstructors "TaxMethod" "(./dhall/Types.dhall).TaxMethod" , MultipleConstructors "TaxMethod" "(./dhall/Types.dhall).TaxMethod"
, MultipleConstructors "PeriodType" "(./dhall/Types.dhall).PeriodType" , MultipleConstructors "PeriodType" "(./dhall/Types.dhall).PeriodType"
, SingleConstructor "LinkedNumGetter" "LinkedNumGetter" "(./dhall/Types.dhall).LinkedNumGetter.Type" , SingleConstructor "LinkedNumGetter" "LinkedNumGetter" "(./dhall/Types.dhall).LinkedNumGetter.Type"
@ -63,7 +63,7 @@ makeHaskellTypesWith
, SingleConstructor "TaxProgression" "TaxProgression" "(./dhall/Types.dhall).TaxProgression" , SingleConstructor "TaxProgression" "TaxProgression" "(./dhall/Types.dhall).TaxProgression"
, SingleConstructor "TaxValue" "TaxValue" "(./dhall/Types.dhall).TaxValue" , SingleConstructor "TaxValue" "TaxValue" "(./dhall/Types.dhall).TaxValue"
, SingleConstructor "PosttaxValue" "PosttaxValue" "(./dhall/Types.dhall).PosttaxValue" , 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 "Period" "Period" "(./dhall/Types.dhall).Period"
, SingleConstructor "HourlyPeriod" "HourlyPeriod" "(./dhall/Types.dhall).HourlyPeriod" , SingleConstructor "HourlyPeriod" "HourlyPeriod" "(./dhall/Types.dhall).HourlyPeriod"
-- , SingleConstructor "ToTx" "ToTx" "(./dhall/Types.dhall).ToTx" -- , SingleConstructor "ToTx" "ToTx" "(./dhall/Types.dhall).ToTx"
@ -97,7 +97,7 @@ deriveProduct
, "DateMatcher" , "DateMatcher"
, "ValMatcher" , "ValMatcher"
, "YMDMatcher" , "YMDMatcher"
, "BudgetCurrency" , "TransferCurrency"
, "Exchange" , "Exchange"
, "EntryNumGetter" , "EntryNumGetter"
, "LinkedNumGetter" , "LinkedNumGetter"
@ -110,8 +110,8 @@ deriveProduct
, "TaxProgression" , "TaxProgression"
, "TaxMethod" , "TaxMethod"
, "PosttaxValue" , "PosttaxValue"
, "BudgetTransferValue" , "TransferValue"
, "BudgetTransferType" , "TransferType"
, "Period" , "Period"
, "PeriodType" , "PeriodType"
, "HourlyPeriod" , "HourlyPeriod"
@ -183,7 +183,7 @@ deriving instance Ord DatePat
deriving instance Hashable DatePat deriving instance Hashable DatePat
type BudgetTransfer = type BudgetTransfer =
Transfer TaggedAcnt BudgetCurrency DatePat BudgetTransferValue Transfer TaggedAcnt TransferCurrency DatePat TransferValue
deriving instance Hashable BudgetTransfer deriving instance Hashable BudgetTransfer
@ -216,9 +216,21 @@ deriving instance Hashable PosttaxValue
deriving instance Hashable Budget 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 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 Exchange
deriving instance Hashable BudgetCurrency deriving instance Hashable TransferCurrency
data Allocation w v = Allocation data Allocation w v = Allocation
{ alloTo :: TaggedAcnt { alloTo :: TaggedAcnt

View File

@ -36,7 +36,9 @@ data ConfigHashes = ConfigHashes
type AccountMap = M.Map AcntID (AccountRId, AcntSign, AcntType) 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 type TagMap = M.Map TagID TagRId
@ -61,7 +63,10 @@ type CurrencyM = Reader CurrencyMap
-- type DeferredKeyEntry = Entry AccountRId (Deferred Rational) CurrencyRId TagRId -- 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 data ReadEntry = ReadEntry
{ reCurrency :: !CurrencyRId { reCurrency :: !CurrencyRId
@ -77,33 +82,37 @@ data UpdateEntry i v = UpdateEntry
, ueIndex :: !Int -- TODO this isn't needed for primary entries , ueIndex :: !Int -- TODO this isn't needed for primary entries
} }
data CurrencyRound = CurrencyRound CurID Natural
deriving instance Functor (UpdateEntry i) deriving instance Functor (UpdateEntry i)
newtype LinkScale = LinkScale {unLinkScale :: Rational} newtype LinkScale = LinkScale {unLinkScale :: Rational}
deriving newtype (Num) deriving newtype (Num)
newtype BalanceTarget = BalanceTarget {unBalanceTarget :: Rational} -- newtype BalanceTarget = BalanceTarget {unBalanceTarget :: Rational}
-- deriving newtype (Num)
newtype StaticValue = StaticValue {unStaticValue :: Rational}
deriving newtype (Num) deriving newtype (Num)
newtype EntryValue = EntryValue {unEntryValue :: Rational} data EntryValueUnk = EVBalance Rational | EVPercent Rational
deriving newtype (Num)
type UEBalance = UpdateEntry EntryRId BalanceTarget type UEUnk = UpdateEntry EntryRId EntryValueUnk
type UELink = UpdateEntry EntryRId LinkScale type UELink = UpdateEntry EntryRId LinkScale
type UEBlank = UpdateEntry EntryRId () 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 data UpdateEntrySet = UpdateEntrySet
{ utFrom0 :: !UEBlank { utFrom0 :: !UEBlank
, utTo0 :: !UEBlank , utTo0 :: !UEBlank
, utPairs :: ![(UEBalance, [UELink])] , utPairs :: ![(UEUnk, [UELink])]
, utFromUnk :: ![UEBalance] , utFromUnk :: ![UEUnk]
, utToUnk :: ![UEBalance] , utToUnk :: ![UEUnk]
, utToUnkLink0 :: ![UELink] , utToUnkLink0 :: ![UELink]
, utFromRO :: ![UE_RO] , utFromRO :: ![UE_RO]
, utToRO :: ![UE_RO] , utToRO :: ![UE_RO]
@ -115,18 +124,18 @@ data UpdateEntrySet = UpdateEntrySet
data EntryBin data EntryBin
= ToUpdate UpdateEntrySet = ToUpdate UpdateEntrySet
| ToRead ReadEntry | ToRead ReadEntry
| ToInsert (DeferredTx CommitR) | ToInsert (Tx CommitR)
data FullEntry a c t = FullEntry data InsertEntry a c t = InsertEntry
{ feCurrency :: !c { feCurrency :: !c
, feIndex :: !Int , feIndex :: !Int
, feDeferred :: !(Maybe DBDeferred) , feDeferred :: !(Maybe DBDeferred)
, feEntry :: !(Entry a Rational t) , 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 -- type DeferredKeyTx = Tx DeferredKeyEntry
@ -202,50 +211,58 @@ data HalfEntrySet a c t v = HalfEntrySet
, hesOther :: ![Entry a v t] , hesOther :: ![Entry a v t]
} }
data EntrySet a c t v = EntrySet data EntrySet a c t v v' = EntrySet
{ esTotalValue :: !Rational { esTotalValue :: !v'
, esCurrency :: !c , esCurrency :: !c
, esFrom :: !(HalfEntrySet a c t (Deferred v)) , esFrom :: !(HalfEntrySet a c t (EntryValue v))
, esTo :: !(HalfEntrySet a c t (LinkDeferred v)) , esTo :: !(HalfEntrySet a c t (LinkDeferred v))
} }
data Tx e c = Tx data Tx k = Tx
{ txDescr :: !T.Text { txDescr :: !T.Text
, txDate :: !Day , txDate :: !Day
, txEntries :: !e , txPrimary :: !(EntrySet AcntID CurrencyPrec TagID Rational Rational)
, txCommit :: !c , txOther :: ![EntrySet AcntID CurrencyPrec TagID Rational (EntryValue Rational)]
, txCommit :: !k
} }
deriving (Generic) 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 BalEntrySet = EntrySet AcntID CurID TagID Rational
type KeyEntrySet = EntrySet AccountRId CurrencyRId TagRId 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 data Deferred a = Deferred Bool a
deriving (Show, Functor, Foldable, Traversable) deriving (Show, Functor, Foldable, Traversable)
data LinkDeferred a data EntryValue a = EntryValue TransferType a
= LinkDeferred (Deferred a)
| LinkIndex LinkedNumGetter
deriving (Show, Functor, Foldable, Traversable) 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 RawEntry = Entry AcntID (Deferred Rational) CurID TagID
-- type RawFromEntry = Entry AcntID (Deferred Rational) CurID TagID -- type RawFromEntry = Entry AcntID (Deferred Rational) CurID TagID
-- type BalEntry = Entry AcntID Rational CurID TagID -- type BalEntry = InsertEntry AcntID CurID TagID
-- type RawTx = Tx RawEntry
-- type BalTx = Tx BalEntry
data MatchRes a = MatchPass !a | MatchFail | MatchSkip data MatchRes a = MatchPass !a | MatchFail | MatchSkip

View File

@ -65,7 +65,6 @@ where
import Control.Monad.Error.Class import Control.Monad.Error.Class
import Control.Monad.Except import Control.Monad.Except
import Control.Monad.Reader
import Data.Time.Format.ISO8601 import Data.Time.Format.ISO8601
import GHC.Real import GHC.Real
import Internal.Types.Main import Internal.Types.Main
@ -294,7 +293,7 @@ toDaySpan (a, b) = (a, fromIntegral $ diffDays b a - 1)
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- matching -- matching
matches :: MatchRe -> TxRecord -> InsertExceptT CurrencyM (MatchRes (DeferredTx ())) matches :: MonadFinance m => MatchRe -> TxRecord -> InsertExceptT m (MatchRes (Tx ()))
matches matches
StatementParser {spTx, spOther, spVal, spDate, spDesc} StatementParser {spTx, spOther, spVal, spDate, spDesc}
r@TxRecord {trDate, trAmount, trDesc, trOther} = do r@TxRecord {trDate, trAmount, trDesc, trOther} = do
@ -311,7 +310,7 @@ matches
desc = maybe (return True) (matchMaybe trDesc . snd) spDesc desc = maybe (return True) (matchMaybe trDesc . snd) spDesc
convert tg = MatchPass <$> toTx tg r convert tg = MatchPass <$> toTx tg r
toTx :: TxGetter -> TxRecord -> InsertExceptT CurrencyM (DeferredTx ()) toTx :: MonadFinance m => TxGetter -> TxRecord -> InsertExceptT m (Tx ())
toTx toTx
TxGetter TxGetter
{ tgFrom { tgFrom
@ -321,59 +320,43 @@ toTx
, tgScale , tgScale
} }
r@TxRecord {trAmount, trDate, trDesc} = do r@TxRecord {trAmount, trDate, trDesc} = do
combineError curRes subRes $ \(cur, f, t, v) ss -> combineError curRes subRes $ \(cur, f, t) ss ->
-- TODO might be more efficient to set rebalance flag when balancing
Tx Tx
{ txDate = trDate { txDate = trDate
, txDescr = trDesc , txDescr = trDesc
, txCommit = () , txCommit = ()
, txEntries = , txPrimary =
EntrySet EntrySet
{ esTotalValue = v { esTotalValue = roundPrecisionCur cur $ tgScale * fromRational trAmount
, esCurrency = cur , esCurrency = cur
, esFrom = f , esFrom = f
, esTo = t , esTo = t
} }
: ss , txOther = ss
} }
where where
curRes = do curRes = do
m <- ask m <- askDBState kmCurrency
cur <- liftInner $ resolveCurrency r tgCurrency cur <- liftInner $ resolveCurrency m r tgCurrency
let fromRes = resolveHalfEntry resolveFromValue cur r tgFrom let fromRes = liftInner $ resolveHalfEntry resolveFromValue cur r tgFrom
let toRes = resolveHalfEntry resolveToValue cur r tgTo let toRes = liftInner $ resolveHalfEntry resolveToValue cur r tgTo
let totRes = combineError fromRes toRes (cur,,)
liftExcept $
roundPrecisionCur cur m $
tgScale * fromRational trAmount
combineError3 fromRes toRes totRes (cur,,,)
subRes = mapErrors (resolveSubGetter r) tgOtherEntries 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 resolveSubGetter
:: TxRecord :: MonadFinance m
=> TxRecord
-> TxSubGetter -> 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 resolveSubGetter r TxSubGetter {tsgFrom, tsgTo, tsgValue, tsgCurrency} = do
m <- ask m <- askDBState kmCurrency
cur <- liftInner $ resolveCurrency r tsgCurrency cur <- liftInner $ resolveCurrency m r tsgCurrency
(_, val) <- liftInner $ mapM (roundPrecisionCur cur m) =<< resolveValue r tsgValue
let fromRes = resolveHalfEntry resolveFromValue cur r tsgFrom let fromRes = resolveHalfEntry resolveFromValue cur r tsgFrom
let toRes = resolveHalfEntry resolveToValue cur r tsgTo 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 EntrySet
{ esTotalValue = val { esTotalValue = v
, esCurrency = cur , esCurrency = cur
, esFrom = f , esFrom = f
, esTo = t , esTo = t
@ -382,10 +365,10 @@ resolveSubGetter r TxSubGetter {tsgFrom, tsgTo, tsgValue, tsgCurrency} = do
resolveHalfEntry resolveHalfEntry
:: Traversable f :: Traversable f
=> (TxRecord -> n -> InsertExcept (f Double)) => (TxRecord -> n -> InsertExcept (f Double))
-> CurID -> CurrencyPrec
-> TxRecord -> TxRecord
-> TxHalfGetter (EntryGetter n) -> 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} = resolveHalfEntry f cur r TxHalfGetter {thgAcnt, thgComment, thgTags, thgEntries} =
combineError acntRes esRes $ \a es -> combineError acntRes esRes $ \a es ->
HalfEntrySet HalfEntrySet
@ -399,67 +382,9 @@ resolveHalfEntry f cur r TxHalfGetter {thgAcnt, thgComment, thgTags, thgEntries}
, hesOther = es , hesOther = es
} }
where where
acntRes = liftInner $ resolveAcnt r thgAcnt acntRes = resolveAcnt r thgAcnt
esRes = mapErrors (resolveEntry f cur r) thgEntries 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 -> Rational -> InsertExcept Bool
valMatches ValMatcher {vmDen, vmSign, vmNum, vmPrec} x valMatches ValMatcher {vmDen, vmSign, vmNum, vmPrec} x
| Just d_ <- vmDen, d_ >= p = throwError $ InsertException [MatchValPrecisionError d_ p] | Just d_ <- vmDen, d_ >= p = throwError $ InsertException [MatchValPrecisionError d_ p]
@ -487,47 +412,17 @@ otherMatches dict m = case m of
resolveEntry resolveEntry
:: Traversable f :: Traversable f
=> (TxRecord -> n -> InsertExcept (f Double)) => (TxRecord -> n -> InsertExcept (f Double))
-> CurID -> CurrencyPrec
-> TxRecord -> TxRecord
-> EntryGetter n -> EntryGetter n
-> InsertExceptT CurrencyM (Entry AcntID (f Rational) TagID) -> InsertExcept (Entry AcntID (f Rational) TagID)
resolveEntry f cur r s@Entry {eAcnt, eValue} = do resolveEntry f cur r s@Entry {eAcnt, eValue} = do
m <- ask combineError acntRes valRes $ \a v ->
liftInner $ combineErrorM acntRes valRes $ \a v -> do s {eAcnt = a, eValue = roundPrecisionCur cur <$> v}
v' <- mapM (roundPrecisionCur cur m) v
return $ s {eAcnt = a, eValue = v'}
where where
acntRes = resolveAcnt r eAcnt acntRes = resolveAcnt r eAcnt
valRes = f r eValue 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 :: Monad m => ExceptT e Identity a -> ExceptT e m a
liftInner = mapExceptT (return . runIdentity) 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 :: (Traversable t, MonadUnliftIO m) => t (m a) -> m (t a)
collectErrorsIO = mapErrorsIO id collectErrorsIO = mapErrorsIO id
resolveFromValue :: TxRecord -> EntryNumGetter -> InsertExcept (Deferred Double) resolveFromValue :: TxRecord -> EntryNumGetter -> InsertExcept (EntryValue Double)
resolveFromValue r = fmap (uncurry Deferred) . resolveValue r resolveFromValue = resolveValue
resolveToValue :: TxRecord -> LinkedEntryNumGetter -> InsertExcept (LinkDeferred Double) resolveToValue :: TxRecord -> LinkedEntryNumGetter -> InsertExcept (LinkDeferred Double)
resolveToValue _ (Linked l) = return $ LinkIndex l resolveToValue _ (Linked l) = return $ LinkIndex l
resolveToValue r (Getter g) = do resolveToValue r (Getter g) = LinkDeferred <$> resolveValue r g
(l, v) <- resolveValue r g
return $ LinkDeferred (Deferred l v)
resolveValue :: TxRecord -> EntryNumGetter -> InsertExcept (Bool, Double) resolveValue :: TxRecord -> EntryNumGetter -> InsertExcept (EntryValue Double)
resolveValue TxRecord {trOther, trAmount} s = case s of resolveValue TxRecord {trOther, trAmount} s = case s of
(LookupN t) -> (False,) <$> (readDouble =<< lookupErr EntryValField t trOther) (LookupN t) -> EntryValue TFixed <$> (readDouble =<< lookupErr EntryValField t trOther)
(ConstN c) -> return (False, c) (ConstN c) -> return $ EntryValue TFixed c
AmountN m -> return $ (False,) <$> (* m) $ fromRational trAmount AmountN m -> return $ EntryValue TFixed $ m * fromRational trAmount
BalanceN x -> return (True, x) BalanceN x -> return $ EntryValue TBalance x
PercentN x -> return $ EntryValue TPercent x
resolveAcnt :: TxRecord -> EntryAcnt -> InsertExcept T.Text resolveAcnt :: TxRecord -> EntryAcnt -> InsertExcept T.Text
resolveAcnt = resolveEntryField AcntField resolveAcnt = resolveEntryField AcntField
resolveCurrency :: TxRecord -> EntryCur -> InsertExcept T.Text resolveCurrency :: CurrencyMap -> TxRecord -> EntryCur -> InsertExcept CurrencyPrec
resolveCurrency = resolveEntryField CurField 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 :: EntryIDType -> TxRecord -> EntryAcnt -> InsertExcept T.Text
resolveEntryField t TxRecord {trOther = o} s = case s of resolveEntryField t TxRecord {trOther = o} s = case s of
@ -728,11 +627,8 @@ roundPrecision n = (% p) . round . (* fromIntegral p) . toRational
where where
p = 10 ^ n p = 10 ^ n
roundPrecisionCur :: CurID -> CurrencyMap -> Double -> InsertExcept Rational roundPrecisionCur :: CurrencyPrec -> Double -> Rational
roundPrecisionCur c m x = roundPrecisionCur (CurrencyPrec _ n) = roundPrecision n
case M.lookup c m of
Just (_, n) -> return $ roundPrecision n x
Nothing -> throwError $ InsertException [RoundError c]
acntPath2Text :: AcntPath -> T.Text acntPath2Text :: AcntPath -> T.Text
acntPath2Text (AcntPath t cs) = T.intercalate "/" (atName t : cs) 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 :: (MonadInsertError m, MonadFinance m) => AcntID -> m AcntType
lookupAccountType = fmap thdOf3 . lookupAccount 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 lookupCurrency = lookupFinance CurField kmCurrency
lookupCurrencyKey :: (MonadInsertError m, MonadFinance m) => AcntID -> m CurrencyRId 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 :: (MonadInsertError m, MonadFinance m) => AcntID -> m Natural
lookupCurrencyPrec = fmap snd . lookupCurrency lookupCurrencyPrec = fmap cpPrec . lookupCurrency
lookupTag :: (MonadInsertError m, MonadFinance m) => TagID -> m TagRId lookupTag :: (MonadInsertError m, MonadFinance m) => TagID -> m TagRId
lookupTag = lookupFinance TagField kmTag lookupTag = lookupFinance TagField kmTag