WIP make budget and statement paths use same machinery
This commit is contained in:
parent
d617fa52cc
commit
cc0699eb4e
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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 $
|
||||||
|
\(ro, toBal) paired0' (pairedUnk, pairedRO) ->
|
||||||
(primary, ro ++ concat pairedRO, toBal, paired0', pairedUnk)
|
(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 ()
|
||||||
|
|
|
@ -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
|
||||||
|
-- later.
|
||||||
let balFromEntry = balanceEntry (\a -> liftInnerS . balanceDeferred curID a) curID
|
let balFromEntry = balanceEntry (\a -> liftInnerS . balanceDeferred curID a) curID
|
||||||
fs' <- doEntries balFromEntry curID esTotalValue f0 fs (NE.iterate (+ (-1)) (-1))
|
fs' <- doEntries balFromEntry curID tot f0' fs (NE.iterate (+ (-1)) (-1))
|
||||||
|
|
||||||
|
-- 4. Build an array of debit values be linked as desired in credit entries
|
||||||
let fv = V.fromList $ fmap (eValue . feEntry) fs'
|
let fv = V.fromList $ fmap (eValue . feEntry) fs'
|
||||||
|
|
||||||
-- finally resolve credit entries
|
-- 4. Balance credit entries (including primary) analogously.
|
||||||
let balToEntry = balanceEntry (balanceLinked fv curID precision) curID
|
let balToEntry = balanceEntry (balanceLinked fv curID precision) curID
|
||||||
ts' <- doEntries balToEntry curID (-esTotalValue) t0 ts (NE.iterate (+ 1) 0)
|
ts' <- doEntries balToEntry curID (-tot) t0' ts (NE.iterate (+ 1) 0)
|
||||||
return $ fs' ++ ts'
|
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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
||||||
|
|
|
@ -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
|
||||||
|
|
Loading…
Reference in New Issue