WIP add shadow transfers

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
     }

lib/Internal/Insert.hs

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

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

lib/Internal/Utils.hs

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