ENH use intervals to define allocations
This commit is contained in:
parent
d89b63e59a
commit
ad4cb6a702
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue