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