WIP mostly unify history and budget transfer pipelines
This commit is contained in:
parent
5c1d2bce9d
commit
ebef4e0f6b
|
|
@ -714,11 +714,19 @@ let Transfer =
|
|||
, transAmounts : List (Amount w v)
|
||||
}
|
||||
|
||||
let TaggedAcnt =
|
||||
{-
|
||||
An account with a tag
|
||||
-}
|
||||
{ Type = { taAcnt : AcntID, taTags : List TagID }
|
||||
, default.taTags = [] : List TagID
|
||||
}
|
||||
|
||||
let HistTransfer =
|
||||
{-
|
||||
A manually specified historical transfer
|
||||
-}
|
||||
Transfer AcntID CurID DatePat TransferValue.Type
|
||||
Transfer TaggedAcnt.Type CurID DatePat TransferValue.Type
|
||||
|
||||
let Statement =
|
||||
{-
|
||||
|
|
@ -755,12 +763,6 @@ let History =
|
|||
-}
|
||||
< HistTransfer : HistTransfer | HistStatement : Statement >
|
||||
|
||||
let TaggedAcnt =
|
||||
{-
|
||||
An account with a tag
|
||||
-}
|
||||
{ taAcnt : AcntID, taTags : List TagID }
|
||||
|
||||
let Allocation =
|
||||
{-
|
||||
How to allocate a given budget stream. This can be thought of as a Transfer
|
||||
|
|
@ -768,7 +770,7 @@ let Allocation =
|
|||
-}
|
||||
\(w : Type) ->
|
||||
\(v : Type) ->
|
||||
{ alloTo : TaggedAcnt
|
||||
{ alloTo : TaggedAcnt.Type
|
||||
, alloAmts : List (Amount w v)
|
||||
, alloCur :
|
||||
{-TODO allow exchanges here-}
|
||||
|
|
@ -958,13 +960,13 @@ let Income =
|
|||
This must be an income AcntID, and is the only place income
|
||||
accounts may be specified in the entire budget.
|
||||
-}
|
||||
TaggedAcnt
|
||||
TaggedAcnt.Type
|
||||
, incToBal :
|
||||
{-
|
||||
The account to which to send the remainder of the income stream
|
||||
(if any) after all allocations have been applied.
|
||||
-}
|
||||
TaggedAcnt
|
||||
TaggedAcnt.Type
|
||||
}
|
||||
, default =
|
||||
{ incPretax = [] : List (SingleAllocation PretaxValue)
|
||||
|
|
@ -1034,12 +1036,12 @@ let ShadowTransfer =
|
|||
{-
|
||||
Source of this transfer
|
||||
-}
|
||||
TaggedAcnt
|
||||
TaggedAcnt.Type
|
||||
, stTo :
|
||||
{-
|
||||
Destination of this transfer.
|
||||
-}
|
||||
TaggedAcnt
|
||||
TaggedAcnt.Type
|
||||
, stCurrency :
|
||||
{-
|
||||
Currency of this transfer.
|
||||
|
|
@ -1070,7 +1072,7 @@ let BudgetTransfer =
|
|||
{-
|
||||
A manually specified transaction for a budget
|
||||
-}
|
||||
Transfer TaggedAcnt CurID DatePat TransferValue.Type
|
||||
HistTransfer
|
||||
|
||||
let Budget =
|
||||
{-
|
||||
|
|
|
|||
|
|
@ -3,6 +3,7 @@ module Internal.Budget (readBudget) where
|
|||
import Control.Monad.Except
|
||||
import Data.Foldable
|
||||
import Internal.Database
|
||||
import Internal.History
|
||||
import Internal.Types.Main
|
||||
import Internal.Utils
|
||||
import RIO hiding (to)
|
||||
|
|
@ -39,9 +40,14 @@ readBudget
|
|||
, bgtInterval
|
||||
} =
|
||||
eitherHash CTBudget b return $ \key -> do
|
||||
spanRes <- getSpan
|
||||
case spanRes of
|
||||
Nothing -> return []
|
||||
Just budgetSpan -> do
|
||||
(intAllos, _) <- combineError intAlloRes acntRes (,)
|
||||
let res1 = mapErrors (readIncome key bgtLabel intAllos bgtInterval) bgtIncomes
|
||||
let res2 = expandTransfers key bgtLabel bgtInterval bgtTransfers
|
||||
let tc = BudgetCommit key bgtLabel
|
||||
let res1 = mapErrors (readIncome tc intAllos budgetSpan) bgtIncomes
|
||||
let res2 = expandTransfers tc (Just budgetSpan) bgtTransfers
|
||||
txs <- combineError (concat <$> res1) res2 (++)
|
||||
shadow <- addShadowTransfers bgtShadowTransfers txs
|
||||
return $ txs ++ shadow
|
||||
|
|
@ -56,43 +62,13 @@ readBudget
|
|||
(alloAcnt <$> bgtPretax)
|
||||
++ (alloAcnt <$> bgtTax)
|
||||
++ (alloAcnt <$> bgtPosttax)
|
||||
|
||||
entryPair
|
||||
:: (MonadInsertError m, MonadFinance m)
|
||||
=> TaggedAcnt
|
||||
-> TaggedAcnt
|
||||
-> CurID
|
||||
-> T.Text
|
||||
-> Double
|
||||
-> m (EntrySet AcntID CurrencyPrec TagID Rational (EntryValue Rational))
|
||||
entryPair = entryPair_ (fmap (EntryValue TFixed) . roundPrecisionCur)
|
||||
|
||||
entryPair_
|
||||
:: (MonadInsertError m, MonadFinance m)
|
||||
=> (CurrencyPrec -> v -> v')
|
||||
-> TaggedAcnt
|
||||
-> TaggedAcnt
|
||||
-> CurID
|
||||
-> T.Text
|
||||
-> v
|
||||
-> m (EntrySet AcntID CurrencyPrec TagID Rational v')
|
||||
entryPair_ f from to curid com val = do
|
||||
cp <- lookupCurrency curid
|
||||
return $ pair cp from to (f cp val)
|
||||
where
|
||||
halfEntry :: a -> [t] -> HalfEntrySet a c t v
|
||||
halfEntry a ts =
|
||||
HalfEntrySet
|
||||
{ hesPrimary = Entry {eAcnt = a, eValue = (), eComment = com, eTags = ts}
|
||||
, hesOther = []
|
||||
}
|
||||
pair cp (TaggedAcnt fa fts) (TaggedAcnt ta tts) v =
|
||||
EntrySet
|
||||
{ esCurrency = cp
|
||||
, esTotalValue = v
|
||||
, esFrom = halfEntry fa fts
|
||||
, esTo = halfEntry ta tts
|
||||
}
|
||||
getSpan = do
|
||||
globalSpan <- askDBState kmBudgetInterval
|
||||
case bgtInterval of
|
||||
Nothing -> return $ Just globalSpan
|
||||
Just bi -> do
|
||||
localSpan <- liftExcept $ resolveDaySpan bi
|
||||
return $ intersectDaySpan globalSpan localSpan
|
||||
|
||||
sortAllo :: MultiAllocation v -> InsertExcept (DaySpanAllocation v)
|
||||
sortAllo a@Allocation {alloAmts = as} = do
|
||||
|
|
@ -115,17 +91,15 @@ sortAllo a@Allocation {alloAmts = as} = do
|
|||
-- loop into a fold which I don't feel like doing now :(
|
||||
readIncome
|
||||
:: (MonadInsertError m, MonadFinance m)
|
||||
=> CommitR
|
||||
-> T.Text
|
||||
=> TxCommit
|
||||
-> IntAllocations
|
||||
-> Maybe Interval
|
||||
-> DaySpan
|
||||
-> Income
|
||||
-> m [Tx TxCommit]
|
||||
readIncome
|
||||
key
|
||||
name
|
||||
tc
|
||||
(intPre, intTax, intPost)
|
||||
localInterval
|
||||
ds
|
||||
Income
|
||||
{ incWhen
|
||||
, incCurrency
|
||||
|
|
@ -152,10 +126,9 @@ readIncome
|
|||
++ (alloAcnt <$> incTaxes)
|
||||
++ (alloAcnt <$> incPosttax)
|
||||
precRes = lookupCurrencyPrec incCurrency
|
||||
dayRes = askDays incWhen localInterval
|
||||
dayRes = liftExcept $ expandDatePat ds incWhen
|
||||
start = fromGregorian' $ pStart incPayPeriod
|
||||
pType' = pType incPayPeriod
|
||||
meta = BudgetCommit key name
|
||||
flatPre = concatMap flattenAllo incPretax
|
||||
flatTax = concatMap flattenAllo incTaxes
|
||||
flatPost = concatMap flattenAllo incPosttax
|
||||
|
|
@ -182,17 +155,18 @@ readIncome
|
|||
incCurrency
|
||||
"balance after deductions"
|
||||
(fromRational balance)
|
||||
allos <- mapErrors (allo2Trans meta day incFrom) (pre ++ tax ++ post)
|
||||
allos <- mapErrors (allo2Trans tc day incFrom) (pre ++ tax ++ post)
|
||||
let bal =
|
||||
Tx
|
||||
{ txCommit = meta
|
||||
{ txCommit = tc
|
||||
, txDate = day
|
||||
, txPrimary = primary
|
||||
, txOther = []
|
||||
, txDescr = "balance after deductions"
|
||||
}
|
||||
-- TODO use real name here
|
||||
if balance < 0
|
||||
then throwError $ InsertException [IncomeError day name balance]
|
||||
then throwError $ InsertException [IncomeError day "" balance]
|
||||
else return (bal : allos)
|
||||
|
||||
periodScaler
|
||||
|
|
@ -383,61 +357,6 @@ allocatePost precision aftertax = fmap (fmap go)
|
|||
--------------------------------------------------------------------------------
|
||||
-- Standalone Transfer
|
||||
|
||||
expandTransfers
|
||||
:: (MonadInsertError m, MonadFinance m)
|
||||
=> CommitR
|
||||
-> T.Text
|
||||
-> Maybe Interval
|
||||
-> [BudgetTransfer]
|
||||
-> m [Tx TxCommit]
|
||||
expandTransfers key name localInterval ts = do
|
||||
txs <-
|
||||
fmap (L.sortOn txDate . concat) $
|
||||
combineErrors $
|
||||
fmap (expandTransfer key name) ts
|
||||
case localInterval of
|
||||
Nothing -> return txs
|
||||
Just i -> do
|
||||
bounds <- liftExcept $ resolveDaySpan i
|
||||
return $ filter (inDaySpan bounds . txDate) txs
|
||||
|
||||
expandTransfer
|
||||
:: (MonadInsertError m, MonadFinance m)
|
||||
=> CommitR
|
||||
-> T.Text
|
||||
-> BudgetTransfer
|
||||
-> m [Tx TxCommit]
|
||||
expandTransfer key name Transfer {transAmounts, transTo, transCurrency, transFrom} =
|
||||
concat <$> mapErrors go transAmounts
|
||||
where
|
||||
go
|
||||
Amount
|
||||
{ amtWhen = pat
|
||||
, amtValue = TransferValue {tvVal = v, tvType = t}
|
||||
, amtDesc = desc
|
||||
} =
|
||||
withDates pat $ \day -> do
|
||||
let meta = BudgetCommit key name
|
||||
p <- entryPair_ (\_ x -> EntryValue t $ toRational x) transFrom transTo transCurrency desc v
|
||||
return
|
||||
Tx
|
||||
{ txCommit = meta
|
||||
, txDate = day
|
||||
, txPrimary = p
|
||||
, txOther = []
|
||||
, txDescr = desc
|
||||
}
|
||||
|
||||
withDates
|
||||
:: (MonadFinance m, MonadInsertError m)
|
||||
=> DatePat
|
||||
-> (Day -> m a)
|
||||
-> m [a]
|
||||
withDates dp f = do
|
||||
bounds <- askDBState kmBudgetInterval
|
||||
days <- liftExcept $ expandDatePat bounds dp
|
||||
combineErrors $ fmap f days
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- shadow transfers
|
||||
|
||||
|
|
|
|||
|
|
@ -5,6 +5,9 @@ module Internal.History
|
|||
, splitHistory
|
||||
, balanceTxs
|
||||
, updateTx
|
||||
, entryPair_
|
||||
, expandTransfers
|
||||
, entryPair
|
||||
)
|
||||
where
|
||||
|
||||
|
|
@ -30,24 +33,11 @@ import qualified RIO.Vector as V
|
|||
-- TODO unify this with the transfer system I use in the budget now
|
||||
readHistTransfer
|
||||
:: (MonadInsertError m, MonadFinance m)
|
||||
=> HistTransfer
|
||||
=> PairedTransfer
|
||||
-> m (Either CommitR [Tx TxCommit])
|
||||
readHistTransfer
|
||||
m@Transfer
|
||||
{ transFrom = from
|
||||
, transTo = to
|
||||
, transCurrency = u
|
||||
, transAmounts = amts
|
||||
} =
|
||||
eitherHash CTManual m return $ \c -> do
|
||||
readHistTransfer ht = eitherHash CTManual ht return $ \c -> do
|
||||
bounds <- askDBState kmStatementInterval
|
||||
let curRes = lookupCurrency u
|
||||
let go Amount {amtWhen, amtValue, amtDesc} = do
|
||||
let dayRes = liftExcept $ expandDatePat bounds amtWhen
|
||||
(days, cur) <- combineError dayRes curRes (,)
|
||||
let tx day = txPair c day from to cur amtValue amtDesc
|
||||
return $ fmap tx days
|
||||
concat <$> mapErrors go amts
|
||||
expandTransfer (HistoryCommit c) (Just bounds) ht
|
||||
|
||||
readHistStmt
|
||||
:: (MonadUnliftIO m, MonadFinance m)
|
||||
|
|
@ -59,7 +49,7 @@ readHistStmt root i = eitherHash CTImport i return $ \c -> do
|
|||
bounds <- askDBState kmStatementInterval
|
||||
return $ filter (inDaySpan bounds . txDate) $ fmap (\t -> t {txCommit = HistoryCommit c}) bs
|
||||
|
||||
splitHistory :: [History] -> ([HistTransfer], [Statement])
|
||||
splitHistory :: [History] -> ([PairedTransfer], [Statement])
|
||||
splitHistory = partitionEithers . fmap go
|
||||
where
|
||||
go (HistTransfer x) = Left x
|
||||
|
|
@ -98,39 +88,126 @@ updateTx UpdateEntry {ueID, ueValue} = update ueID [EntryRValue =. unStaticValue
|
|||
--------------------------------------------------------------------------------
|
||||
-- low-level transaction stuff
|
||||
|
||||
-- TODO tags here?
|
||||
txPair
|
||||
:: CommitR
|
||||
-> Day
|
||||
-> AcntID
|
||||
-> AcntID
|
||||
-> CurrencyPrec
|
||||
-> TransferValue
|
||||
-> T.Text
|
||||
-> Tx TxCommit
|
||||
txPair commit day from to cur (TransferValue t v) desc =
|
||||
Tx
|
||||
{ txDescr = desc
|
||||
, txDate = day
|
||||
, txCommit = HistoryCommit commit
|
||||
, txPrimary =
|
||||
EntrySet
|
||||
{ esTotalValue = EntryValue t $ toRational v
|
||||
, esCurrency = cur
|
||||
, esFrom = HalfEntrySet {hesPrimary = entry from, hesOther = []}
|
||||
, esTo = HalfEntrySet {hesPrimary = entry to, hesOther = []}
|
||||
}
|
||||
, txOther = []
|
||||
}
|
||||
expandTransfers
|
||||
:: (MonadInsertError m, MonadFinance m)
|
||||
=> TxCommit
|
||||
-> Maybe DaySpan
|
||||
-> [PairedTransfer]
|
||||
-> m [Tx TxCommit]
|
||||
expandTransfers tc localInterval ts =
|
||||
fmap (L.sortOn txDate . concat) $
|
||||
combineErrors $
|
||||
fmap (expandTransfer tc localInterval) ts
|
||||
|
||||
expandTransfer
|
||||
:: (MonadInsertError m, MonadFinance m)
|
||||
=> TxCommit
|
||||
-> Maybe DaySpan
|
||||
-> PairedTransfer
|
||||
-> m [Tx TxCommit]
|
||||
expandTransfer tc ds Transfer {transAmounts, transTo, transCurrency, transFrom} = do
|
||||
txs <- concat <$> mapErrors go transAmounts
|
||||
return $ case ds of
|
||||
Nothing -> txs
|
||||
Just bounds -> filter (inDaySpan bounds . txDate) txs
|
||||
where
|
||||
entry a =
|
||||
Entry
|
||||
{ eAcnt = a
|
||||
, eValue = ()
|
||||
, eComment = ""
|
||||
, eTags = []
|
||||
go
|
||||
Amount
|
||||
{ amtWhen = pat
|
||||
, amtValue = TransferValue {tvVal = v, tvType = t}
|
||||
, amtDesc = desc
|
||||
} =
|
||||
withDates pat $ \day -> do
|
||||
p <- entryPair_ (\_ x -> EntryValue t $ toRational x) transFrom transTo transCurrency desc v
|
||||
return
|
||||
Tx
|
||||
{ txCommit = tc
|
||||
, txDate = day
|
||||
, txPrimary = p
|
||||
, txOther = []
|
||||
, txDescr = desc
|
||||
}
|
||||
|
||||
entryPair
|
||||
:: (MonadInsertError m, MonadFinance m)
|
||||
=> TaggedAcnt
|
||||
-> TaggedAcnt
|
||||
-> CurID
|
||||
-> T.Text
|
||||
-> Double
|
||||
-> m (EntrySet AcntID CurrencyPrec TagID Rational (EntryValue Rational))
|
||||
entryPair = entryPair_ (fmap (EntryValue TFixed) . roundPrecisionCur)
|
||||
|
||||
entryPair_
|
||||
:: (MonadInsertError m, MonadFinance m)
|
||||
=> (CurrencyPrec -> v -> v')
|
||||
-> TaggedAcnt
|
||||
-> TaggedAcnt
|
||||
-> CurID
|
||||
-> T.Text
|
||||
-> v
|
||||
-> m (EntrySet AcntID CurrencyPrec TagID Rational v')
|
||||
entryPair_ f from to curid com val = do
|
||||
cp <- lookupCurrency curid
|
||||
return $ pair cp from to (f cp val)
|
||||
where
|
||||
halfEntry :: a -> [t] -> HalfEntrySet a c t v
|
||||
halfEntry a ts =
|
||||
HalfEntrySet
|
||||
{ hesPrimary = Entry {eAcnt = a, eValue = (), eComment = com, eTags = ts}
|
||||
, hesOther = []
|
||||
}
|
||||
pair cp (TaggedAcnt fa fts) (TaggedAcnt ta tts) v =
|
||||
EntrySet
|
||||
{ esCurrency = cp
|
||||
, esTotalValue = v
|
||||
, esFrom = halfEntry fa fts
|
||||
, esTo = halfEntry ta tts
|
||||
}
|
||||
|
||||
withDates
|
||||
:: (MonadFinance m, MonadInsertError m)
|
||||
=> DatePat
|
||||
-> (Day -> m a)
|
||||
-> m [a]
|
||||
withDates dp f = do
|
||||
bounds <- askDBState kmBudgetInterval
|
||||
days <- liftExcept $ expandDatePat bounds dp
|
||||
combineErrors $ fmap f days
|
||||
|
||||
-- -- TODO tags here?
|
||||
-- txPair
|
||||
-- :: CommitR
|
||||
-- -> Day
|
||||
-- -> AcntID
|
||||
-- -> AcntID
|
||||
-- -> CurrencyPrec
|
||||
-- -> TransferValue
|
||||
-- -> T.Text
|
||||
-- -> Tx TxCommit
|
||||
-- txPair commit day from to cur (TransferValue t v) desc =
|
||||
-- Tx
|
||||
-- { txDescr = desc
|
||||
-- , txDate = day
|
||||
-- , txCommit = HistoryCommit commit
|
||||
-- , txPrimary =
|
||||
-- EntrySet
|
||||
-- { esTotalValue = EntryValue t $ toRational v
|
||||
-- , esCurrency = cur
|
||||
-- , esFrom = HalfEntrySet {hesPrimary = entry from, hesOther = []}
|
||||
-- , esTo = HalfEntrySet {hesPrimary = entry to, hesOther = []}
|
||||
-- }
|
||||
-- , txOther = []
|
||||
-- }
|
||||
-- where
|
||||
-- entry a =
|
||||
-- Entry
|
||||
-- { eAcnt = a
|
||||
-- , eValue = ()
|
||||
-- , eComment = ""
|
||||
-- , eTags = []
|
||||
-- }
|
||||
|
||||
-- resolveTx :: (MonadInsertError m, MonadFinance m) => BalTx CommitR -> m (KeyTx CommitR)
|
||||
-- resolveTx t@Tx {txEntries = ss} =
|
||||
-- (\kss -> t {txEntries = kss}) <$> mapErrors resolveEntry ss
|
||||
|
|
|
|||
|
|
@ -40,7 +40,7 @@ makeHaskellTypesWith
|
|||
, SingleConstructor "LinkedNumGetter" "LinkedNumGetter" "(./dhall/Types.dhall).LinkedNumGetter.Type"
|
||||
, SingleConstructor "Currency" "Currency" "(./dhall/Types.dhall).Currency"
|
||||
, SingleConstructor "Tag" "Tag" "(./dhall/Types.dhall).Tag"
|
||||
, SingleConstructor "TaggedAcnt" "TaggedAcnt" "(./dhall/Types.dhall).TaggedAcnt"
|
||||
, SingleConstructor "TaggedAcnt" "TaggedAcnt" "(./dhall/Types.dhall).TaggedAcnt.Type"
|
||||
, SingleConstructor "Gregorian" "Gregorian" "(./dhall/Types.dhall).Gregorian"
|
||||
, SingleConstructor "GregorianM" "GregorianM" "(./dhall/Types.dhall).GregorianM"
|
||||
, SingleConstructor "Interval" "Interval" "(./dhall/Types.dhall).Interval"
|
||||
|
|
@ -178,14 +178,13 @@ deriving instance Ord DatePat
|
|||
|
||||
deriving instance Hashable DatePat
|
||||
|
||||
type BudgetTransfer =
|
||||
Transfer TaggedAcnt CurID DatePat TransferValue
|
||||
type PairedTransfer = Transfer TaggedAcnt CurID DatePat TransferValue
|
||||
|
||||
deriving instance Hashable BudgetTransfer
|
||||
deriving instance Hashable PairedTransfer
|
||||
|
||||
deriving instance Generic BudgetTransfer
|
||||
deriving instance Generic PairedTransfer
|
||||
|
||||
deriving instance FromDhall BudgetTransfer
|
||||
deriving instance FromDhall PairedTransfer
|
||||
|
||||
data Budget = Budget
|
||||
{ bgtLabel :: Text
|
||||
|
|
@ -193,7 +192,7 @@ data Budget = Budget
|
|||
, bgtPretax :: [MultiAllocation PretaxValue]
|
||||
, bgtTax :: [MultiAllocation TaxValue]
|
||||
, bgtPosttax :: [MultiAllocation PosttaxValue]
|
||||
, bgtTransfers :: [BudgetTransfer]
|
||||
, bgtTransfers :: [PairedTransfer]
|
||||
, bgtShadowTransfers :: [ShadowTransfer]
|
||||
, bgtInterval :: !(Maybe Interval)
|
||||
}
|
||||
|
|
@ -420,16 +419,8 @@ type AcntID = T.Text
|
|||
|
||||
type TagID = T.Text
|
||||
|
||||
type HistTransfer = Transfer AcntID CurID DatePat TransferValue
|
||||
|
||||
deriving instance Generic HistTransfer
|
||||
|
||||
deriving instance Hashable HistTransfer
|
||||
|
||||
deriving instance FromDhall HistTransfer
|
||||
|
||||
data History
|
||||
= HistTransfer !HistTransfer
|
||||
= HistTransfer !PairedTransfer
|
||||
| HistStatement !Statement
|
||||
deriving (Eq, Generic, Hashable, FromDhall)
|
||||
|
||||
|
|
|
|||
|
|
@ -274,6 +274,7 @@ intersectDaySpan a b =
|
|||
|
||||
resolveDaySpan_ :: Gregorian -> Interval -> InsertExcept DaySpan
|
||||
resolveDaySpan_ def Interval {intStart = s, intEnd = e} =
|
||||
-- TODO the default isn't checked here :/
|
||||
case fromGregorian' <$> e of
|
||||
Nothing -> return $ toDaySpan_ $ fromGregorian' def
|
||||
Just e_
|
||||
|
|
|
|||
Loading…
Reference in New Issue