WIP add shadow transfers
This commit is contained in:
parent
d2c7c0484a
commit
048872253f
|
@ -230,8 +230,36 @@ let Transfer =
|
|||
, transCurrency : CurID
|
||||
}
|
||||
|
||||
let ShadowMatch =
|
||||
{ Type =
|
||||
{ smFrom : List AcntID
|
||||
, smTo : List AcntID
|
||||
, smDate : Optional MatchDate
|
||||
, smVal : MatchVal.Type
|
||||
}
|
||||
, default =
|
||||
{ smFrom = [] : List AcntID
|
||||
, smTo = [] : List AcntID
|
||||
, smDate = None MatchDate
|
||||
, smVal = MatchVal.default
|
||||
}
|
||||
}
|
||||
|
||||
let ShadowTransfer =
|
||||
{ stFrom : AcntID
|
||||
, stTo : AcntID
|
||||
, stCurrency : CurID
|
||||
, stDesc : Text
|
||||
, stMatch : ShadowMatch.Type
|
||||
, stRatio : Decimal
|
||||
}
|
||||
|
||||
let Budget =
|
||||
{ budgetLabel : Text, income : List Income, transfers : List Transfer }
|
||||
{ budgetLabel : Text
|
||||
, income : List Income
|
||||
, transfers : List Transfer
|
||||
, shadowTransfers : List ShadowTransfer
|
||||
}
|
||||
|
||||
in { CurID
|
||||
, AcntID
|
||||
|
@ -279,4 +307,6 @@ in { CurID
|
|||
, TimeAmount
|
||||
, AmountType
|
||||
, TransferTarget
|
||||
, ShadowMatch
|
||||
, ShadowTransfer
|
||||
}
|
||||
|
|
|
@ -120,14 +120,60 @@ withDates dp f = do
|
|||
-- 5. insert all transactions
|
||||
|
||||
insertBudget :: MonadFinance m => Budget -> SqlPersistT m [InsertError]
|
||||
insertBudget Budget {budgetLabel = name, income = is, transfers = es} = do
|
||||
insertBudget Budget {budgetLabel = name, income = is, transfers = es, shadowTransfers = ss} = do
|
||||
res1 <- mapM (insertIncome name) is
|
||||
res2 <- expandTransfers name es
|
||||
unlessLefts (concatEithers2 (fmap concat $ concatEithersL res1) res2 (++)) $
|
||||
\txs -> do
|
||||
let bals = balanceTransfers txs
|
||||
unlessLefts (addShadowTransfers ss txs) $ \shadow -> do
|
||||
let bals = balanceTransfers $ txs ++ shadow
|
||||
concat <$> mapM insertBudgetTx bals
|
||||
|
||||
-- TODO this is going to be O(n*m), which might be a problem?
|
||||
addShadowTransfers :: [ShadowTransfer] -> [BudgetTxType] -> EitherErrs [BudgetTxType]
|
||||
addShadowTransfers ms txs =
|
||||
fmap catMaybes $
|
||||
concatEitherL $
|
||||
fmap (uncurry fromShadow) $
|
||||
[(t, m) | t <- txs, m <- ms]
|
||||
|
||||
fromShadow :: BudgetTxType -> ShadowTransfer -> EitherErr (Maybe BudgetTxType)
|
||||
fromShadow tx t@ShadowTransfer {stFrom, stTo, stDesc, stRatio} = do
|
||||
res <- shadowMatches (stMatch t) tx
|
||||
return $
|
||||
if not res
|
||||
then Nothing
|
||||
else
|
||||
Just $
|
||||
BudgetTxType
|
||||
{ bttTx =
|
||||
-- TODO does this actually share the same metadata as the "parent" tx?
|
||||
BudgetTx
|
||||
{ btMeta = btMeta $ bttTx tx
|
||||
, btWhen = btWhen $ bttTx tx
|
||||
, -- TODO what are these supposed to do?
|
||||
btFrom = BudgetSplit stFrom Nothing
|
||||
, btTo = BudgetSplit stTo Nothing
|
||||
, btValue = dec2Rat stRatio * (btValue $ bttTx tx)
|
||||
, btDesc = stDesc
|
||||
}
|
||||
, bttType = FixedAmt
|
||||
}
|
||||
|
||||
shadowMatches :: ShadowMatch -> BudgetTxType -> EitherErr Bool
|
||||
shadowMatches ShadowMatch {smFrom, smTo, smDate, smVal} tx = do
|
||||
-- TODO what does the amount do for each of the different types?
|
||||
valRes <- valMatches smVal (btValue tx_)
|
||||
return $
|
||||
memberMaybe (bsAcnt $ btFrom tx_) smFrom
|
||||
&& memberMaybe (bsAcnt $ btTo tx_) smTo
|
||||
&& maybe True (`dateMatches` (btWhen tx_)) smDate
|
||||
&& valRes
|
||||
where
|
||||
tx_ = bttTx tx
|
||||
memberMaybe _ [] = True
|
||||
memberMaybe xs ys = xs `elem` ys
|
||||
|
||||
balanceTransfers :: [BudgetTxType] -> [BudgetTx]
|
||||
balanceTransfers ts = snd $ L.mapAccumR go initBals $ L.sortOn (btWhen . bttTx) ts
|
||||
where
|
||||
|
|
|
@ -53,6 +53,8 @@ makeHaskellTypesWith
|
|||
, SingleConstructor "Income" "Income" "(./dhall/Types.dhall).Income"
|
||||
, SingleConstructor "Budget" "Budget" "(./dhall/Types.dhall).Budget"
|
||||
, SingleConstructor "Transfer" "Transfer" "(./dhall/Types.dhall).Transfer"
|
||||
, SingleConstructor "ShadowMatch" "ShadowMatch" "(./dhall/Types.dhall).ShadowMatch"
|
||||
, SingleConstructor "ShadowTransfer" "ShadowTransfer" "(./dhall/Types.dhall).ShadowTransfer"
|
||||
]
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
|
@ -309,6 +311,14 @@ deriving instance Eq Transfer
|
|||
|
||||
deriving instance Hashable Transfer
|
||||
|
||||
deriving instance Eq ShadowTransfer
|
||||
|
||||
deriving instance Hashable ShadowTransfer
|
||||
|
||||
deriving instance Eq ShadowMatch
|
||||
|
||||
deriving instance Hashable ShadowMatch
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Statements (data from the past)
|
||||
|
||||
|
@ -479,7 +489,7 @@ data ConfigHashes = ConfigHashes
|
|||
, chImport :: ![Int]
|
||||
}
|
||||
|
||||
data ConfigType = CTIncome | CTExpense | CTManual | CTImport
|
||||
data ConfigType = CTIncome | CTExpense | CTShadow | CTManual | CTImport
|
||||
deriving (Eq, Show, Read, Enum)
|
||||
|
||||
instance PersistFieldSql ConfigType where
|
||||
|
|
|
@ -32,6 +32,8 @@ module Internal.Utils
|
|||
, plural
|
||||
, compileMatch
|
||||
, compileOptions
|
||||
, dateMatches
|
||||
, valMatches
|
||||
)
|
||||
where
|
||||
|
||||
|
|
Loading…
Reference in New Issue