WIP add shadow transfers
This commit is contained in:
parent
d2c7c0484a
commit
048872253f
|
@ -230,8 +230,36 @@ let Transfer =
|
||||||
, transCurrency : CurID
|
, 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 =
|
let Budget =
|
||||||
{ budgetLabel : Text, income : List Income, transfers : List Transfer }
|
{ budgetLabel : Text
|
||||||
|
, income : List Income
|
||||||
|
, transfers : List Transfer
|
||||||
|
, shadowTransfers : List ShadowTransfer
|
||||||
|
}
|
||||||
|
|
||||||
in { CurID
|
in { CurID
|
||||||
, AcntID
|
, AcntID
|
||||||
|
@ -279,4 +307,6 @@ in { CurID
|
||||||
, TimeAmount
|
, TimeAmount
|
||||||
, AmountType
|
, AmountType
|
||||||
, TransferTarget
|
, TransferTarget
|
||||||
|
, ShadowMatch
|
||||||
|
, ShadowTransfer
|
||||||
}
|
}
|
||||||
|
|
|
@ -120,13 +120,59 @@ withDates dp f = do
|
||||||
-- 5. insert all transactions
|
-- 5. insert all transactions
|
||||||
|
|
||||||
insertBudget :: MonadFinance m => Budget -> SqlPersistT m [InsertError]
|
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
|
res1 <- mapM (insertIncome name) is
|
||||||
res2 <- expandTransfers name es
|
res2 <- expandTransfers name es
|
||||||
unlessLefts (concatEithers2 (fmap concat $ concatEithersL res1) res2 (++)) $
|
unlessLefts (concatEithers2 (fmap concat $ concatEithersL res1) res2 (++)) $
|
||||||
\txs -> do
|
\txs -> do
|
||||||
let bals = balanceTransfers txs
|
unlessLefts (addShadowTransfers ss txs) $ \shadow -> do
|
||||||
concat <$> mapM insertBudgetTx bals
|
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 :: [BudgetTxType] -> [BudgetTx]
|
||||||
balanceTransfers ts = snd $ L.mapAccumR go initBals $ L.sortOn (btWhen . bttTx) ts
|
balanceTransfers ts = snd $ L.mapAccumR go initBals $ L.sortOn (btWhen . bttTx) ts
|
||||||
|
|
|
@ -53,6 +53,8 @@ makeHaskellTypesWith
|
||||||
, SingleConstructor "Income" "Income" "(./dhall/Types.dhall).Income"
|
, SingleConstructor "Income" "Income" "(./dhall/Types.dhall).Income"
|
||||||
, SingleConstructor "Budget" "Budget" "(./dhall/Types.dhall).Budget"
|
, SingleConstructor "Budget" "Budget" "(./dhall/Types.dhall).Budget"
|
||||||
, SingleConstructor "Transfer" "Transfer" "(./dhall/Types.dhall).Transfer"
|
, 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 Hashable Transfer
|
||||||
|
|
||||||
|
deriving instance Eq ShadowTransfer
|
||||||
|
|
||||||
|
deriving instance Hashable ShadowTransfer
|
||||||
|
|
||||||
|
deriving instance Eq ShadowMatch
|
||||||
|
|
||||||
|
deriving instance Hashable ShadowMatch
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- Statements (data from the past)
|
-- Statements (data from the past)
|
||||||
|
|
||||||
|
@ -479,7 +489,7 @@ data ConfigHashes = ConfigHashes
|
||||||
, chImport :: ![Int]
|
, chImport :: ![Int]
|
||||||
}
|
}
|
||||||
|
|
||||||
data ConfigType = CTIncome | CTExpense | CTManual | CTImport
|
data ConfigType = CTIncome | CTExpense | CTShadow | CTManual | CTImport
|
||||||
deriving (Eq, Show, Read, Enum)
|
deriving (Eq, Show, Read, Enum)
|
||||||
|
|
||||||
instance PersistFieldSql ConfigType where
|
instance PersistFieldSql ConfigType where
|
||||||
|
|
|
@ -32,6 +32,8 @@ module Internal.Utils
|
||||||
, plural
|
, plural
|
||||||
, compileMatch
|
, compileMatch
|
||||||
, compileOptions
|
, compileOptions
|
||||||
|
, dateMatches
|
||||||
|
, valMatches
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue