diff --git a/dhall/Types.dhall b/dhall/Types.dhall index b33ac9a..64fc071 100644 --- a/dhall/Types.dhall +++ b/dhall/Types.dhall @@ -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 } diff --git a/lib/Internal/Insert.hs b/lib/Internal/Insert.hs index 9b33b8f..5383f44 100644 --- a/lib/Internal/Insert.hs +++ b/lib/Internal/Insert.hs @@ -120,13 +120,59 @@ 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 - concat <$> mapM insertBudgetTx bals + 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 diff --git a/lib/Internal/Types.hs b/lib/Internal/Types.hs index e0ae9d7..21b9d45 100644 --- a/lib/Internal/Types.hs +++ b/lib/Internal/Types.hs @@ -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 diff --git a/lib/Internal/Utils.hs b/lib/Internal/Utils.hs index 5ed1426..6cacc74 100644 --- a/lib/Internal/Utils.hs +++ b/lib/Internal/Utils.hs @@ -32,6 +32,8 @@ module Internal.Utils , plural , compileMatch , compileOptions + , dateMatches + , valMatches ) where