WIP add shadow transfers

This commit is contained in:
Nathan Dwarshuis 2023-02-13 19:57:39 -05:00
parent d2c7c0484a
commit 048872253f
4 changed files with 93 additions and 5 deletions

View File

@ -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
} }

View File

@ -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

View File

@ -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

View File

@ -32,6 +32,8 @@ module Internal.Utils
, plural , plural
, compileMatch , compileMatch
, compileOptions , compileOptions
, dateMatches
, valMatches
) )
where where