ADD local budget interval
This commit is contained in:
parent
6117784d0e
commit
5dfbc3ef41
|
|
@ -19,8 +19,15 @@ import Database.Esqueleto.Experimental ((==.), (^.))
|
|||
import qualified Database.Esqueleto.Experimental as E
|
||||
import Database.Esqueleto.Internal.Internal (SqlSelect)
|
||||
import Database.Persist.Monad
|
||||
-- import Database.Persist.Sql hiding (delete, runMigration, (==.), (||.))
|
||||
import Database.Persist.Sqlite hiding (delete, deleteWhere, insert, insertKey, runMigration, (==.), (||.))
|
||||
import Database.Persist.Sqlite hiding
|
||||
( delete
|
||||
, deleteWhere
|
||||
, insert
|
||||
, insertKey
|
||||
, runMigration
|
||||
, (==.)
|
||||
, (||.)
|
||||
)
|
||||
import GHC.Err
|
||||
import Internal.Types
|
||||
import Internal.Utils
|
||||
|
|
|
|||
|
|
@ -95,6 +95,22 @@ expandMDYPat lower upper (Repeat RepeatPat {rpStart = s, rpBy = b, rpRepeats = r
|
|||
dayToWeekday :: Day -> Int
|
||||
dayToWeekday (ModifiedJulianDay d) = mod (fromIntegral d + 2) 7
|
||||
|
||||
askDays
|
||||
:: (MonadFinance m, MonadInsertError m)
|
||||
=> DatePat
|
||||
-> Maybe Interval
|
||||
-> m [Day]
|
||||
askDays dp i = do
|
||||
globalBounds <- askDBState kmBudgetInterval
|
||||
case i of
|
||||
Just i' -> do
|
||||
localBounds <- liftExcept $ resolveBounds i'
|
||||
let bounds = intersectBounds globalBounds localBounds
|
||||
maybe (return []) expand bounds
|
||||
Nothing -> expand globalBounds
|
||||
where
|
||||
expand bs = liftExcept $ expandDatePat bs dp
|
||||
|
||||
withDates
|
||||
:: (MonadSqlQuery m, MonadFinance m, MonadInsertError m)
|
||||
=> DatePat
|
||||
|
|
@ -105,15 +121,13 @@ withDates dp f = do
|
|||
days <- liftExcept $ expandDatePat bounds dp
|
||||
combineErrors $ fmap f days
|
||||
|
||||
foldDates
|
||||
:: (MonadSqlQuery m, MonadFinance m, MonadInsertError m)
|
||||
=> DatePat
|
||||
foldDays
|
||||
:: MonadInsertError m
|
||||
=> (Day -> Day -> m a)
|
||||
-> Day
|
||||
-> (Day -> Day -> m a)
|
||||
-> [Day]
|
||||
-> m [a]
|
||||
foldDates dp start f = do
|
||||
bounds <- askDBState kmBudgetInterval
|
||||
days <- liftExcept $ expandDatePat bounds dp
|
||||
foldDays f start days =
|
||||
combineErrors $
|
||||
snd $
|
||||
L.mapAccumL (\prevDay day -> (day, f prevDay day)) start days
|
||||
|
|
@ -145,11 +159,12 @@ insertBudget
|
|||
, bgtPretax
|
||||
, bgtTax
|
||||
, bgtPosttax
|
||||
, bgtInterval
|
||||
} =
|
||||
whenHash CTBudget b () $ \key -> do
|
||||
intAllos <- combineError3 pre_ tax_ post_ (,,)
|
||||
let res1 = mapErrors (insertIncome key bgtLabel intAllos) bgtIncomes
|
||||
let res2 = expandTransfers key bgtLabel bgtTransfers
|
||||
let res1 = mapErrors (insertIncome key bgtLabel intAllos bgtInterval) bgtIncomes
|
||||
let res2 = expandTransfers key bgtLabel bgtInterval bgtTransfers
|
||||
txs <- combineError (concat <$> res1) res2 (++)
|
||||
m <- askDBState kmCurrency
|
||||
shadow <- liftExcept $ addShadowTransfers m bgtShadowTransfers txs
|
||||
|
|
@ -160,7 +175,7 @@ insertBudget
|
|||
post_ = sortAllos bgtPosttax
|
||||
sortAllos = liftExcept . combineErrors . fmap sortAllo
|
||||
|
||||
type BoundAllocation = Allocation (Day, Day)
|
||||
type BoundAllocation = Allocation Bounds
|
||||
|
||||
type IntAllocations =
|
||||
( [BoundAllocation PretaxValue]
|
||||
|
|
@ -180,7 +195,7 @@ sortAllo a@Allocation {alloAmts = as} = do
|
|||
res <- case xs of
|
||||
[] -> resolveBounds start
|
||||
(y : _) -> resolveBounds_ (intStart $ amtWhen y) start
|
||||
foldBounds (x {amtWhen = expandBounds res} : acc) xs
|
||||
foldBounds (x {amtWhen = res} : acc) xs
|
||||
|
||||
-- TODO this is going to be O(n*m), which might be a problem?
|
||||
addShadowTransfers
|
||||
|
|
@ -209,35 +224,35 @@ fromShadow cm tx t@ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, st
|
|||
Just $
|
||||
-- TODO does this actually share the same metadata as the "parent" tx?
|
||||
FlatTransfer
|
||||
{ cbtMeta = cbtMeta tx
|
||||
, cbtWhen = cbtWhen tx
|
||||
, cbtCur = stCurrency
|
||||
, cbtFrom = stFrom
|
||||
, cbtTo = stTo
|
||||
, cbtValue = UnbalancedValue stType $ v * cvValue (cbtValue tx)
|
||||
, cbtDesc = stDesc
|
||||
{ ftMeta = ftMeta tx
|
||||
, ftWhen = ftWhen tx
|
||||
, ftCur = stCurrency
|
||||
, ftFrom = stFrom
|
||||
, ftTo = stTo
|
||||
, ftValue = UnbalancedValue stType $ v * cvValue (ftValue tx)
|
||||
, ftDesc = stDesc
|
||||
}
|
||||
|
||||
shadowMatches :: TransferMatcher -> UnbalancedTransfer -> InsertExcept Bool
|
||||
shadowMatches TransferMatcher {tmFrom, tmTo, tmDate, tmVal} tx = do
|
||||
valRes <- valMatches tmVal $ cvValue $ cbtValue tx
|
||||
valRes <- valMatches tmVal $ cvValue $ ftValue tx
|
||||
return $
|
||||
memberMaybe (taAcnt $ cbtFrom tx) tmFrom
|
||||
&& memberMaybe (taAcnt $ cbtTo tx) tmTo
|
||||
&& maybe True (`dateMatches` cbtWhen tx) tmDate
|
||||
memberMaybe (taAcnt $ ftFrom tx) tmFrom
|
||||
&& memberMaybe (taAcnt $ ftTo tx) tmTo
|
||||
&& maybe True (`dateMatches` ftWhen tx) tmDate
|
||||
&& valRes
|
||||
where
|
||||
memberMaybe x AcntSet {asList, asInclude} =
|
||||
(if asInclude then id else not) $ x `elem` asList
|
||||
|
||||
balanceTransfers :: [UnbalancedTransfer] -> [BalancedTransfer]
|
||||
balanceTransfers = snd . L.mapAccumR go M.empty . reverse . L.sortOn cbtWhen
|
||||
balanceTransfers = snd . L.mapAccumR go M.empty . reverse . L.sortOn ftWhen
|
||||
where
|
||||
go bals f@FlatTransfer {cbtFrom, cbtTo, cbtValue = UnbalancedValue {cvValue, cvType}} =
|
||||
let balTo = M.findWithDefault 0 cbtTo bals
|
||||
go bals f@FlatTransfer {ftFrom, ftTo, ftValue = UnbalancedValue {cvValue, cvType}} =
|
||||
let balTo = M.findWithDefault 0 ftTo bals
|
||||
x = amtToMove balTo cvType cvValue
|
||||
bals' = mapAdd_ cbtTo x $ mapAdd_ cbtFrom (-x) bals
|
||||
in (bals', f {cbtValue = x})
|
||||
bals' = mapAdd_ ftTo x $ mapAdd_ ftFrom (-x) bals
|
||||
in (bals', f {ftValue = x})
|
||||
-- TODO might need to query signs to make this intuitive; as it is this will
|
||||
-- probably work, but for credit accounts I might need to supply a negative
|
||||
-- target value
|
||||
|
|
@ -255,13 +270,13 @@ data BudgetMeta = BudgetMeta
|
|||
deriving (Show)
|
||||
|
||||
data FlatTransfer v = FlatTransfer
|
||||
{ cbtFrom :: !TaggedAcnt
|
||||
, cbtTo :: !TaggedAcnt
|
||||
, cbtValue :: !v
|
||||
, cbtWhen :: !Day
|
||||
, cbtDesc :: !T.Text
|
||||
, cbtMeta :: !BudgetMeta
|
||||
, cbtCur :: !BudgetCurrency
|
||||
{ ftFrom :: !TaggedAcnt
|
||||
, ftTo :: !TaggedAcnt
|
||||
, ftValue :: !v
|
||||
, ftWhen :: !Day
|
||||
, ftDesc :: !T.Text
|
||||
, ftMeta :: !BudgetMeta
|
||||
, ftCur :: !BudgetCurrency
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
|
|
@ -276,16 +291,18 @@ type UnbalancedTransfer = FlatTransfer UnbalancedValue
|
|||
type BalancedTransfer = FlatTransfer Rational
|
||||
|
||||
insertIncome
|
||||
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
|
||||
:: (MonadInsertError m, MonadFinance m)
|
||||
=> CommitRId
|
||||
-> T.Text
|
||||
-> IntAllocations
|
||||
-> Maybe Interval
|
||||
-> Income
|
||||
-> m [UnbalancedTransfer]
|
||||
insertIncome
|
||||
key
|
||||
name
|
||||
(intPre, intTax, intPost)
|
||||
localInterval
|
||||
Income
|
||||
{ incWhen
|
||||
, incCurrency
|
||||
|
|
@ -304,7 +321,8 @@ insertIncome
|
|||
-- 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 :(
|
||||
res <- foldDates incWhen start (allocate precision gross)
|
||||
days <- askDays incWhen localInterval
|
||||
res <- foldDays (allocate precision gross) start days
|
||||
return $ concat res
|
||||
where
|
||||
start = fromGregorian' $ pStart incPayPeriod
|
||||
|
|
@ -330,13 +348,13 @@ insertIncome
|
|||
balance = aftertaxGross - sumAllos post
|
||||
bal =
|
||||
FlatTransfer
|
||||
{ cbtMeta = meta
|
||||
, cbtWhen = day
|
||||
, cbtFrom = incFrom
|
||||
, cbtCur = NoX incCurrency
|
||||
, cbtTo = incToBal
|
||||
, cbtValue = UnbalancedValue BTFixed balance
|
||||
, cbtDesc = "balance after deductions"
|
||||
{ ftMeta = meta
|
||||
, ftWhen = day
|
||||
, ftFrom = incFrom
|
||||
, ftCur = NoX incCurrency
|
||||
, ftTo = incToBal
|
||||
, ftValue = UnbalancedValue BTFixed balance
|
||||
, ftDesc = "balance after deductions"
|
||||
}
|
||||
in if balance < 0
|
||||
then throwError $ InsertException [IncomeError day name balance]
|
||||
|
|
@ -404,13 +422,13 @@ allo2Trans
|
|||
-> UnbalancedTransfer
|
||||
allo2Trans meta day from FlatAllocation {faValue, faTo, faDesc, faCur} =
|
||||
FlatTransfer
|
||||
{ cbtMeta = meta
|
||||
, cbtWhen = day
|
||||
, cbtFrom = from
|
||||
, cbtCur = faCur
|
||||
, cbtTo = faTo
|
||||
, cbtValue = UnbalancedValue BTFixed faValue
|
||||
, cbtDesc = faDesc
|
||||
{ ftMeta = meta
|
||||
, ftWhen = day
|
||||
, ftFrom = from
|
||||
, ftCur = faCur
|
||||
, ftTo = faTo
|
||||
, ftValue = UnbalancedValue BTFixed faValue
|
||||
, ftDesc = faDesc
|
||||
}
|
||||
|
||||
allocateTax
|
||||
|
|
@ -501,12 +519,19 @@ expandTransfers
|
|||
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
|
||||
=> CommitRId
|
||||
-> T.Text
|
||||
-> Maybe Interval
|
||||
-> [BudgetTransfer]
|
||||
-> m [UnbalancedTransfer]
|
||||
expandTransfers key name ts =
|
||||
fmap (L.sortOn cbtWhen . concat) $
|
||||
expandTransfers key name localInterval ts = do
|
||||
txs <-
|
||||
fmap (L.sortOn ftWhen . concat) $
|
||||
combineErrors $
|
||||
fmap (expandTransfer key name) ts
|
||||
case localInterval of
|
||||
Nothing -> return txs
|
||||
Just i -> do
|
||||
bounds <- liftExcept $ resolveBounds i
|
||||
return $ filter (inBounds bounds . ftWhen) txs
|
||||
|
||||
initialCurrency :: BudgetCurrency -> CurID
|
||||
initialCurrency (NoX c) = c
|
||||
|
|
@ -533,28 +558,28 @@ expandTransfer key name Transfer {transAmounts, transTo, transCurrency, transFro
|
|||
let meta = BudgetMeta {bmCommit = key, bmName = name}
|
||||
return
|
||||
FlatTransfer
|
||||
{ cbtMeta = meta
|
||||
, cbtWhen = day
|
||||
, cbtCur = transCurrency
|
||||
, cbtFrom = transFrom
|
||||
, cbtTo = transTo
|
||||
, cbtValue = UnbalancedValue y $ roundPrecision precision v
|
||||
, cbtDesc = desc
|
||||
{ ftMeta = meta
|
||||
, ftWhen = day
|
||||
, ftCur = transCurrency
|
||||
, ftFrom = transFrom
|
||||
, ftTo = transTo
|
||||
, ftValue = UnbalancedValue y $ roundPrecision precision v
|
||||
, ftDesc = desc
|
||||
}
|
||||
|
||||
insertBudgetTx :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m) => BalancedTransfer -> m ()
|
||||
insertBudgetTx FlatTransfer {cbtFrom, cbtTo, cbtMeta, cbtCur, cbtValue, cbtDesc, cbtWhen} = do
|
||||
((sFrom, sTo), exchange) <- splitPair cbtFrom cbtTo cbtCur cbtValue
|
||||
insertBudgetTx FlatTransfer {ftFrom, ftTo, ftMeta, ftCur, ftValue, ftDesc, ftWhen} = do
|
||||
((sFrom, sTo), exchange) <- splitPair ftFrom ftTo ftCur ftValue
|
||||
insertPair sFrom sTo
|
||||
forM_ exchange $ uncurry insertPair
|
||||
where
|
||||
insertPair from to = do
|
||||
k <- insert $ TransactionR (bmCommit cbtMeta) cbtWhen cbtDesc
|
||||
k <- insert $ TransactionR (bmCommit ftMeta) ftWhen ftDesc
|
||||
insertBudgetLabel k from
|
||||
insertBudgetLabel k to
|
||||
insertBudgetLabel k split = do
|
||||
sk <- insertSplit k split
|
||||
insert_ $ BudgetLabelR sk $ bmName cbtMeta
|
||||
insert_ $ BudgetLabelR sk $ bmName ftMeta
|
||||
|
||||
type SplitPair = (KeySplit, KeySplit)
|
||||
|
||||
|
|
@ -646,7 +671,7 @@ insertHistTransfer
|
|||
readHistStmt :: (MonadUnliftIO m, MonadFinance m) => Statement -> m (Maybe (CommitR, [KeyTx]))
|
||||
readHistStmt i = whenHash_ CTImport i $ do
|
||||
bs <- readImport i
|
||||
bounds <- expandBounds <$> askDBState kmStatementInterval
|
||||
bounds <- askDBState kmStatementInterval
|
||||
liftIOExceptT $ mapErrors resolveTx $ filter (inBounds bounds . txDate) bs
|
||||
|
||||
insertHistStmt :: (MonadSqlQuery m) => CommitR -> [KeyTx] -> m ()
|
||||
|
|
|
|||
|
|
@ -200,6 +200,7 @@ data Budget = Budget
|
|||
, bgtPosttax :: [MultiAllocation PosttaxValue]
|
||||
, bgtTransfers :: [BudgetTransfer]
|
||||
, bgtShadowTransfers :: [ShadowTransfer]
|
||||
, bgtInterval :: !(Maybe Interval)
|
||||
}
|
||||
|
||||
deriving instance Hashable PretaxValue
|
||||
|
|
|
|||
|
|
@ -8,6 +8,7 @@ module Internal.Utils
|
|||
, fromGregorian'
|
||||
, resolveBounds
|
||||
, resolveBounds_
|
||||
, intersectBounds
|
||||
, liftInner
|
||||
, liftExceptT
|
||||
, liftExcept
|
||||
|
|
@ -161,14 +162,26 @@ compareDate (In md offset) x = do
|
|||
fromGregorian' :: Gregorian -> Day
|
||||
fromGregorian' = uncurry3 fromGregorian . gregTup
|
||||
|
||||
-- TODO misleading name
|
||||
inBounds :: (Day, Day) -> Day -> Bool
|
||||
inBounds (d0, d1) x = d0 <= x && x < d1
|
||||
inBounds :: Bounds -> Day -> Bool
|
||||
inBounds bs = withinDays (expandBounds bs)
|
||||
|
||||
withinDays :: (Day, Day) -> Day -> Bool
|
||||
withinDays (d0, d1) x = d0 <= x && x < d1
|
||||
|
||||
resolveBounds :: Interval -> InsertExcept Bounds
|
||||
resolveBounds i@Interval {intStart = s} =
|
||||
resolveBounds_ (s {gYear = gYear s + 50}) i
|
||||
|
||||
-- TODO not DRY
|
||||
intersectBounds :: Bounds -> Bounds -> Maybe Bounds
|
||||
intersectBounds a b =
|
||||
if b' > a' then Nothing else Just (a', fromIntegral $ diffDays b' a' - 1)
|
||||
where
|
||||
(a0, a1) = expandBounds a
|
||||
(b0, b1) = expandBounds b
|
||||
a' = max a0 a1
|
||||
b' = min b0 b1
|
||||
|
||||
resolveBounds_ :: Gregorian -> Interval -> InsertExcept Bounds
|
||||
resolveBounds_ def Interval {intStart = s, intEnd = e} =
|
||||
case fromGregorian' <$> e of
|
||||
|
|
|
|||
Loading…
Reference in New Issue