ENH use intervals to define allocations

This commit is contained in:
Nathan Dwarshuis 2023-03-16 23:53:57 -04:00
parent d89b63e59a
commit ad4cb6a702
4 changed files with 237 additions and 73 deletions

View File

@ -195,9 +195,10 @@ let Amount = { amtValue : Decimal, amtDesc : Text }
let AmountType = < FixedAmt | Percent | Target >
let TimeAmount = { taWhen : DatePat, taAmt : Amount, taAmtType : AmountType }
let TimeAmount =
\(t : Type) -> { taWhen : t, taAmt : Amount, taAmtType : AmountType }
let Tax = { taxAcnt : AcntID, taxValue : Decimal }
let DateAmount = TimeAmount DatePat
let Exchange =
{ xFromCur : CurID, xToCur : CurID, xAcnt : AcntID, xRate : Decimal }
@ -206,27 +207,32 @@ let BudgetCurrency = < NoX : CurID | X : Exchange >
let TaggedAcnt = { taAcnt : AcntID, taTags : List TagID }
let Allocation =
{ alloTo : TaggedAcnt, alloAmts : List Amount, alloCur : BudgetCurrency }
let Allocation_ =
\(t : Type) ->
{ alloTo : TaggedAcnt, alloAmts : List t, alloCur : BudgetCurrency }
let Allocation = Allocation_ Amount
let IntervalAllocation = Allocation_ (TimeAmount Interval)
let Income =
{ incGross : Decimal
, incCurrency : CurID
, incWhen : DatePat
, incPretax : List Allocation
, incTaxes : List Allocation
, incPosttax : List Allocation
, incFrom :
{- this must be an income AcntID, and is the only place income
accounts may be specified in the entire budget -}
TaggedAcnt
, incPretax : List Allocation
, incTaxes : List Tax
, incPosttax : List Allocation
, incToBal : TaggedAcnt
}
let Transfer =
{ transFrom : TaggedAcnt
, transTo : TaggedAcnt
, transAmounts : List TimeAmount
, transAmounts : List DateAmount
, transCurrency : BudgetCurrency
}
@ -261,7 +267,10 @@ let ShadowTransfer =
let Budget =
{ budgetLabel : Text
, income : List Income
, incomes : List Income
, pretax : List IntervalAllocation
, tax : List IntervalAllocation
, posttax : List IntervalAllocation
, transfers : List Transfer
, shadowTransfers : List ShadowTransfer
}
@ -306,8 +315,8 @@ in { CurID
, Transfer
, Income
, Budget
, Tax
, Allocation
, IntervalAllocation
, Amount
, TimeAmount
, AmountType

View File

@ -119,15 +119,52 @@ withDates dp f = do
-- 5. insert all transactions
insertBudget :: MonadFinance m => Budget -> SqlPersistT m [InsertError]
insertBudget b@(Budget {budgetLabel = name, income = is, transfers = es, shadowTransfers = ss}) =
insertBudget
b@( Budget
{ budgetLabel
, incomes
, transfers
, shadowTransfers
, pretax
, tax
, posttax
}
) =
whenHash CTBudget b [] $ \key -> do
res1 <- mapM (insertIncome key name) is
res2 <- expandTransfers key name es
unlessLefts intAllos $ \intAllos_ -> do
res1 <- mapM (insertIncome key budgetLabel intAllos_) incomes
res2 <- expandTransfers key budgetLabel transfers
unlessLefts (concatEithers2 (fmap concat $ concatEithersL res1) res2 (++)) $
\txs -> do
unlessLefts (addShadowTransfers ss txs) $ \shadow -> do
unlessLefts (addShadowTransfers shadowTransfers txs) $ \shadow -> do
let bals = balanceTransfers $ txs ++ shadow
concat <$> mapM insertBudgetTx bals
where
intAllos =
let pre_ = sortAllos pretax
tax_ = sortAllos tax
post_ = sortAllos posttax
in concatEithers3 pre_ tax_ post_ (,,)
sortAllos = concatEithersL . fmap sortAllo
type BoundAllocation = Allocation_ (TimeAmount (Day, Day))
type IntAllocations = ([BoundAllocation], [BoundAllocation], [BoundAllocation])
-- TODO this should actually error if there is no ultimate end date
sortAllo :: IntervalAllocation -> EitherErrs BoundAllocation
sortAllo a@Allocation_ {alloAmts = as} = do
bs <- fmap reverse <$> foldBounds (Right []) $ L.sort as
return $ a {alloAmts = L.sort bs}
where
foldBounds acc [] = acc
foldBounds acc (x : xs) =
let res = fmap (fmap expandBounds) $ case xs of
[] -> mapM resolveBounds x
(y : _) ->
let end = intStart $ taWhen y
in mapM (resolveBounds_ end) x
in foldBounds (concatEithers2 (plural res) acc (:)) xs
-- TODO this is going to be O(n*m), which might be a problem?
addShadowTransfers :: [ShadowTransfer] -> [BudgetTxType] -> EitherErrs [BudgetTxType]
@ -219,12 +256,18 @@ data BudgetTxType = BudgetTxType
, bttTx :: !BudgetTx
}
insertIncome :: MonadFinance m => CommitRId -> T.Text -> Income -> SqlPersistT m (EitherErrs [BudgetTxType])
insertIncome
:: MonadFinance m
=> CommitRId
-> T.Text
-> IntAllocations
-> Income
-> SqlPersistT m (EitherErrs [BudgetTxType])
insertIncome
key
name
(intPre, intTax, intPost)
i@Income {incWhen, incCurrency, incFrom, incPretax, incPosttax, incTaxes, incToBal} = do
-- whenHash CTIncome i (Right []) $ \c -> do
let meta = BudgetMeta key (NoX incCurrency) name
let balRes = balanceIncome i
fromRes <- lift $ checkAcntType IncomeT $ taAcnt incFrom
@ -233,13 +276,15 @@ insertIncome
-- TODO this hole seems sloppy...
Right (balance, _) ->
fmap (fmap (concat . concat)) $
-- TODO this will scan the interval allocations fully each time
-- iteration which is a total waste, but the fix requires turning this
-- loop into a fold which I don't feel like doing now :(
withDates incWhen $ \day -> do
let fromAllos = fmap concat . mapM (lift . fromAllo day meta incFrom)
pre <- fromAllos incPretax
tax <-
concatEitherL
<$> mapM (lift . fromTax day meta (taAcnt incFrom)) incTaxes
post <- fromAllos incPosttax
pre <- fromAllos $ incPretax ++ mapMaybe (selectAllos day) intPre
-- TODO ensure these are all expense accounts
tax <- fromAllos $ incTaxes ++ mapMaybe (selectAllos day) intTax
post <- fromAllos $ incPosttax ++ mapMaybe (selectAllos day) intPost
let bal =
BudgetTxType
{ bttTx =
@ -253,7 +298,19 @@ insertIncome
}
, bttType = FixedAmt
}
return $ concatEithersL [Right [bal], tax, Right pre, Right post]
return $ concatEithersL [Right [bal], Right tax, Right pre, Right post]
-- ASSUME allocations are sorted
selectAllos :: Day -> BoundAllocation -> Maybe Allocation
selectAllos day a@Allocation_ {alloAmts = as} = case select [] as of
[] -> Nothing
xs -> Just $ a {alloAmts = xs}
where
select acc [] = acc
select acc (x : xs)
| (fst $ taWhen x) < day = select acc xs
| inBounds (taWhen x) day = select (taAmt x : acc) xs
| otherwise = acc
fromAllo
:: MonadFinance m
@ -262,7 +319,7 @@ fromAllo
-> TaggedAcnt
-> Allocation
-> m [BudgetTxType]
fromAllo day meta from Allocation {alloTo, alloAmts} = do
fromAllo day meta from Allocation_ {alloTo, alloAmts} = do
-- TODO this is going to be repeated a zillion times (might matter)
-- res <- expandTarget alloPath
return $ fmap toBT alloAmts
@ -281,31 +338,31 @@ fromAllo day meta from Allocation {alloTo, alloAmts} = do
, bttType = FixedAmt
}
-- TODO maybe allow tags here?
fromTax
:: MonadFinance m
=> Day
-> BudgetMeta
-> AcntID
-> Tax
-> m (EitherErr BudgetTxType)
fromTax day meta from Tax {taxAcnt = to, taxValue = v} = do
res <- checkAcntType ExpenseT to
return $ fmap go res
where
go to_ =
BudgetTxType
{ bttTx =
BudgetTx
{ btFrom = TaggedAcnt from []
, btWhen = day
, btTo = TaggedAcnt to_ []
, btValue = dec2Rat v
, btDesc = ""
, btMeta = meta
}
, bttType = FixedAmt
}
-- -- TODO maybe allow tags here?
-- fromTax
-- :: MonadFinance m
-- => Day
-- -> BudgetMeta
-- -> AcntID
-- -> Tax
-- -> m (EitherErr BudgetTxType)
-- fromTax day meta from Tax {taxAcnt = to, taxValue = v} = do
-- res <- checkAcntType ExpenseT to
-- return $ fmap go res
-- where
-- go to_ =
-- BudgetTxType
-- { bttTx =
-- BudgetTx
-- { btFrom = TaggedAcnt from []
-- , btWhen = day
-- , btTo = TaggedAcnt to_ []
-- , btValue = dec2Rat v
-- , btDesc = ""
-- , btMeta = meta
-- }
-- , bttType = FixedAmt
-- }
balanceIncome :: Income -> EitherErr Rational
balanceIncome
@ -319,13 +376,13 @@ balanceIncome
| bal < 0 = Left $ IncomeError dp
| otherwise = Right bal
where
bal = dec2Rat g - sum (sumAllocation <$> pre ++ post) - sumTaxes tax
bal = dec2Rat g - sum (sumAllocation <$> pre ++ tax ++ post)
sumAllocation :: Allocation -> Rational
sumAllocation = sum . fmap (dec2Rat . amtValue) . alloAmts
sumTaxes :: [Tax] -> Rational
sumTaxes = sum . fmap (dec2Rat . taxValue)
-- sumTaxes :: [Tax] -> Rational
-- sumTaxes = sum . fmap (dec2Rat . taxValue)
expandTransfers
:: MonadFinance m
@ -341,7 +398,7 @@ expandTransfer :: MonadFinance m => CommitRId -> T.Text -> Transfer -> SqlPersis
expandTransfer key name Transfer {transAmounts, transTo, transCurrency, transFrom} =
-- whenHash CTExpense t (Right []) $ \key ->
fmap (fmap concat . concatEithersL) $
forM transAmounts $ \(TimeAmount (Amount desc v) atype pat) -> do
forM transAmounts $ \(TimeAmount pat (Amount desc v) atype) -> do
withDates pat $ \day ->
let meta =
BudgetMeta

View File

@ -49,14 +49,12 @@ makeHaskellTypesWith
, SingleConstructor "Decimal" "D" "(./dhall/Types.dhall).Decimal"
, SingleConstructor "MatchVal" "MatchVal" "(./dhall/Types.dhall).MatchVal.Type"
, SingleConstructor "Manual" "Manual" "(./dhall/Types.dhall).Manual"
, SingleConstructor "Tax" "Tax" "(./dhall/Types.dhall).Tax"
, SingleConstructor "Amount" "Amount" "(./dhall/Types.dhall).Amount"
, SingleConstructor "TimeAmount" "TimeAmount" "(./dhall/Types.dhall).TimeAmount"
, SingleConstructor "Allocation" "Allocation" "(./dhall/Types.dhall).Allocation"
, SingleConstructor "Income" "Income" "(./dhall/Types.dhall).Income"
, SingleConstructor "Budget" "Budget" "(./dhall/Types.dhall).Budget"
, SingleConstructor "Transfer" "Transfer" "(./dhall/Types.dhall).Transfer"
, SingleConstructor "Exchange" "Exchange" "(./dhall/Types.dhall).Exchange"
, -- , SingleConstructor "TimeAmount" "TimeAmount" "(./dhall/Types.dhall).TimeAmount"
-- , SingleConstructor "Income" "Income" "(./dhall/Types.dhall).Income"
-- , SingleConstructor "Budget" "Budget" "(./dhall/Types.dhall).Budget"
-- , SingleConstructor "Transfer" "Transfer" "(./dhall/Types.dhall).Transfer"
SingleConstructor "Exchange" "Exchange" "(./dhall/Types.dhall).Exchange"
, SingleConstructor "TaggedAcnt" "TaggedAcnt" "(./dhall/Types.dhall).TaggedAcnt"
, SingleConstructor "AcntSet" "AcntSet" "(./dhall/Types.dhall).AcntSet.Type"
, SingleConstructor "ShadowMatch" "ShadowMatch" "(./dhall/Types.dhall).ShadowMatch.Type"
@ -146,6 +144,12 @@ instance Ord GregorianM where
GregorianM {gmYear = y, gmMonth = m}
GregorianM {gmYear = y', gmMonth = m'} = compare y y' <> compare m m'
deriving instance Eq Interval
deriving instance Ord Interval
deriving instance Hashable Interval
deriving instance Eq ModPat
deriving instance Ord ModPat
@ -170,26 +174,55 @@ deriving instance Show DatePat
deriving instance Hashable DatePat
data Budget = Budget
{ budgetLabel :: Text
, incomes :: [Income]
, pretax :: [IntervalAllocation]
, tax :: [IntervalAllocation]
, posttax :: [IntervalAllocation]
, transfers :: [Transfer]
, shadowTransfers :: [ShadowTransfer]
}
deriving instance Eq Budget
deriving instance Generic Budget
deriving instance Hashable Budget
deriving instance FromDhall Budget
deriving instance Eq TaggedAcnt
deriving instance Hashable TaggedAcnt
deriving instance Ord TaggedAcnt
type CurID = T.Text
data Income = Income
{ incGross :: Decimal
, incCurrency :: CurID
, incWhen :: DatePat
, incPretax :: [Allocation]
, incTaxes :: [Allocation]
, incPosttax :: [Allocation]
, incFrom :: TaggedAcnt
, incToBal :: TaggedAcnt
}
deriving instance Eq Income
deriving instance Generic Income
deriving instance Hashable Income
deriving instance Eq Tax
deriving instance Hashable Tax
deriving instance FromDhall Income
deriving instance Eq Amount
deriving instance Ord Amount
deriving instance Hashable Amount
deriving instance Eq Exchange
@ -200,10 +233,32 @@ deriving instance Eq BudgetCurrency
deriving instance Hashable BudgetCurrency
data Allocation_ a = Allocation_
{ alloTo :: TaggedAcnt
, alloAmts :: [a]
, alloCur :: BudgetCurrency
}
type Allocation = Allocation_ Amount
deriving instance Eq Allocation
deriving instance Generic Allocation
deriving instance Hashable Allocation
deriving instance FromDhall Allocation
type IntervalAllocation = Allocation_ IntervalAmount
deriving instance Eq IntervalAllocation
deriving instance Generic IntervalAllocation
deriving instance Hashable IntervalAllocation
deriving instance FromDhall IntervalAllocation
toPersistText :: Show a => a -> PersistValue
toPersistText = PersistText . T.pack . show
@ -216,16 +271,54 @@ fromPersistText what x =
deriving instance Eq AmountType
deriving instance Ord AmountType
deriving instance Hashable AmountType
deriving instance Eq TimeAmount
data TimeAmount a = TimeAmount
{ taWhen :: a
, taAmt :: Amount
, taAmtType :: AmountType
}
deriving (Eq, Ord, Functor, Generic, FromDhall, Hashable, Foldable, Traversable)
deriving instance Hashable TimeAmount
type DateAmount = TimeAmount DatePat
-- deriving instance Eq DateAmount
-- deriving instance Generic DateAmount
-- deriving instance Hashable DateAmount
-- deriving instance FromDhall DateAmount
type IntervalAmount = TimeAmount Interval
-- deriving instance Eq IntervalAmount
-- deriving instance Ord IntervalAmount
-- deriving instance Generic IntervalAmount
-- deriving instance Hashable IntervalAmount
-- deriving instance FromDhall IntervalAmount
data Transfer = Transfer
{ transFrom :: TaggedAcnt
, transTo :: TaggedAcnt
, transAmounts :: [DateAmount]
, transCurrency :: BudgetCurrency
}
deriving instance Eq Transfer
deriving instance Generic Transfer
deriving instance Hashable Transfer
deriving instance FromDhall Transfer
deriving instance Eq ShadowTransfer
deriving instance Hashable ShadowTransfer
@ -258,6 +351,8 @@ deriving instance Show MatchDate
deriving instance Eq Decimal
deriving instance Ord Decimal
deriving instance Hashable Decimal
deriving instance Show Decimal
@ -360,8 +455,6 @@ instance FromDhall a => FromDhall (Config_ a)
-- TODO newtypes for these?
type AcntID = T.Text
type CurID = T.Text
type TagID = T.Text
data Statement

View File

@ -6,6 +6,7 @@ module Internal.Utils
, matches
, fromGregorian'
, resolveBounds
, resolveBounds_
, leftToMaybe
, dec2Rat
, concatEithers2
@ -130,9 +131,13 @@ inBounds :: (Day, Day) -> Day -> Bool
inBounds (d0, d1) x = d0 <= x && x < d1
resolveBounds :: Interval -> EitherErr Bounds
resolveBounds Interval {intStart = s, intEnd = e} =
resolveBounds i@Interval {intStart = s} =
resolveBounds_ (s {gYear = gYear s + 50}) i
resolveBounds_ :: Gregorian -> Interval -> EitherErr Bounds
resolveBounds_ def Interval {intStart = s, intEnd = e} =
case fromGregorian' <$> e of
Nothing -> Right $ toBounds $ fromGregorian' $ s {gYear = gYear s + 50}
Nothing -> Right $ toBounds $ fromGregorian' def
Just e_
| s_ < e_ -> Right $ toBounds e_
| otherwise -> Left $ BoundsError s e