ADD calculations for running balances in statements

app/Main.hs

@@ -180,13 +180,13 @@ runSync c = do
 
     -- update the DB
     runSqlQueryT pool $ withTransaction $ flip runReaderT state $ do
-      let hTransRes = mapErrors insertHistTransfer hTs
+      let runHist = do
-      let bgtRes = mapErrors insertBudget $ budget config
+            ts <- catMaybes <$> mapErrors readHistTransfer hTs
+            insertHistory $ bSs ++ ts
+      let runBudget = mapErrors insertBudget $ budget config
       updateDBState updates -- TODO this will only work if foreign keys are deferred
-      res <- runExceptT $ do
+      res <- runExceptT $ combineError runHist runBudget $ \_ _ -> ()
-        mapM_ (uncurry insertHistStmt) bSs
+      rerunnableIO $ fromEither res -- TODO why is this here?
-        combineError hTransRes bgtRes $ \_ _ -> ()
-      rerunnableIO $ fromEither res
   where
     root = takeDirectory c
     err (InsertException es) = do

dhall/Types.dhall

@@ -396,15 +396,30 @@ let FieldMatcher_ =
 
 let FieldMatcher = FieldMatcher_ Text
 
-let EntryNumGetter =
+let FromEntryNumGetter =
     {-
     Means to get a numeric value from a statement row.
 
-    LookupN: lookup the value from a field
+    FLookupN: lookup the value from a field
-    ConstN: a constant value
+    FConstN: a constant value
-    AmountN: the value of the 'Amount' column
+    FAmountN: the value of the 'Amount' column
+    FBalanceN: the amount required to make the target account reach a balance
     -}
-      < LookupN : Text | ConstN : Double | AmountN : Double >
+      < FLookupN : Text
+      | FConstN : Double
+      | FAmountN : Double
+      | FBalanceN : Double
+      >
+
+let ToEntryNumGetter =
+    {-
+    Means to get a numeric value from a statement row.
+
+    TLookupN: lookup the value from a field
+    TConstN: a constant value
+    TAmountN: the value of the 'Amount' column
+    -}
+      < TLookupN : Text | TConstN : Double | TAmountN : Double >
 
 let EntryTextGetter =
     {-
@@ -477,8 +492,8 @@ let FromEntryGetter =
     Means for getting an entry from a given row in a statement to apply to the
     credit side of the transaction.
     -}
-      { Type = Entry EntryAcntGetter EntryNumGetter EntryCurGetter TagID
+      { Type = Entry EntryAcntGetter FromEntryNumGetter EntryCurGetter TagID
-      , default = { eValue = None EntryNumGetter, eComment = "" }
+      , default = { eValue = None FromEntryNumGetter, eComment = "" }
       }
 
 let ToEntryGetter =
@@ -487,8 +502,8 @@ let ToEntryGetter =
     debit side of the transaction.
     -}
       { Type =
-          Entry EntryAcntGetter (Optional EntryNumGetter) EntryCurGetter TagID
+          Entry EntryAcntGetter (Optional ToEntryNumGetter) EntryCurGetter TagID
-      , default = { eValue = None EntryNumGetter, eComment = "" }
+      , default = { eValue = None ToEntryNumGetter, eComment = "" }
       }
 
 let TxGetter =
@@ -1073,7 +1088,8 @@ in  { CurID
     , DateMatcher
     , FieldMatcher
     , FieldMatcher_
-    , EntryNumGetter
+    , FromEntryNumGetter
+    , ToEntryNumGetter
     , Field
     , FieldMap
     , Entry

dhall/common.dhall

@@ -96,7 +96,7 @@ let partN =
         let toEntry =
               \(x : PartEntry) ->
                     nullEntry (T.EntryAcntGetter.ConstT x._1) c
-                //  { eValue = Some (T.EntryNumGetter.ConstN x._2)
+                //  { eValue = Some (T.ToEntryNumGetter.TConstN x._2)
                     , eComment = x._3
                     }
 

lib/Internal/Budget.hs

@@ -74,10 +74,6 @@ balanceTransfers = snd . L.mapAccumR go M.empty . reverse . L.sortOn ftWhen
     amtToMove bal BTPercent x = -(x / 100 * bal)
     amtToMove bal BTTarget x = x - bal
 
--- TODO this seems too general for this module
-mapAdd_ :: (Ord k, Num v) => k -> v -> M.Map k v -> M.Map k v
-mapAdd_ k v = M.alter (maybe (Just v) (Just . (+ v))) k
-
 insertBudgetTx
   :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
   => BalancedTransfer

lib/Internal/Database.hs

@@ -411,6 +411,6 @@ resolveEntry s@Entry {eAcnt, eCurrency, eValue, eTags} = do
       s
         { eAcnt = aid
         , eCurrency = cid
-        , eValue = eValue * fromIntegral (sign2Int sign)
+        , eValue = fromIntegral (sign2Int sign) * eValue
         , eTags = tags
         }

lib/Internal/History.hs

@@ -1,8 +1,8 @@
 module Internal.History
-  ( splitHistory
+  ( readHistStmt
-  , insertHistTransfer
+  , readHistTransfer
-  , readHistStmt
+  , insertHistory
-  , insertHistStmt
+  , splitHistory
   )
 where
 
@@ -17,72 +17,92 @@ import qualified RIO.ByteString.Lazy as BL
 import RIO.FilePath
 import qualified RIO.List as L
 import qualified RIO.Map as M
+import qualified RIO.NonEmpty as NE
 import qualified RIO.Text as T
 import RIO.Time
 import qualified RIO.Vector as V
 
+-- readHistory
+--   :: (MonadInsertError m, MonadFinance m, MonadUnliftIO m)
+--   => FilePath
+--   -> [History]
+--   -> m [(CommitR, [RawTx])]
+-- readHistory root hs = do
+--   let (ts, ss) = splitHistory hs
+--   ts' <- catMaybes <$> mapErrorsIO readHistTransfer ts
+--   ss' <- catMaybes <$> mapErrorsIO (readHistStmt root) ss
+--   return $ ts' ++ ss'
+
+readHistTransfer
+  :: (MonadInsertError m, MonadFinance m)
+  => HistTransfer
+  -> m (Maybe (CommitR, [RawTx]))
+readHistTransfer
+  m@Transfer
+    { transFrom = from
+    , transTo = to
+    , transCurrency = u
+    , transAmounts = amts
+    } = do
+    whenHash_ CTManual m $ do
+      bounds <- askDBState kmStatementInterval
+      let precRes = lookupCurrencyPrec u
+      let go Amount {amtWhen, amtValue, amtDesc} = do
+            let dayRes = liftExcept $ expandDatePat bounds amtWhen
+            (days, precision) <- combineError dayRes precRes (,)
+            let tx day = txPair day from to u (roundPrecision precision amtValue) amtDesc
+            return $ fmap tx days
+      concat <$> mapErrors go amts
+
+groupKey :: Ord c => (a -> c) -> [(a, b)] -> [(a, [b])]
+groupKey f = fmap go . NE.groupAllWith (f . fst)
+  where
+    go xs@((c, _) :| _) = (c, NE.toList $ fmap snd xs)
+
+readHistStmt
+  :: (MonadUnliftIO m, MonadFinance m)
+  => FilePath
+  -> Statement
+  -> m (Maybe (CommitR, [RawTx]))
+readHistStmt root i = whenHash_ CTImport i $ do
+  bs <- readImport root i
+  bounds <- askDBState kmStatementInterval
+  return $ filter (inDaySpan bounds . txDate) bs
+
 splitHistory :: [History] -> ([HistTransfer], [Statement])
 splitHistory = partitionEithers . fmap go
   where
     go (HistTransfer x) = Left x
     go (HistStatement x) = Right x
 
-insertHistTransfer
+insertHistory
   :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
-  => HistTransfer
+  => [(CommitR, [RawTx])]
   -> m ()
-insertHistTransfer
+insertHistory hs = do
-  m@Transfer
+  bs <- balanceTxs $ concatMap (\(c, xs) -> fmap (c,) xs) hs
-    { transFrom = from
+  forM_ (groupKey (\(CommitR h _) -> h) bs) $ \(c, ts) -> do
-    , transTo = to
-    , transCurrency = u
-    , transAmounts = amts
-    } = do
-    whenHash CTManual m () $ \c -> do
-      bounds <- askDBState kmStatementInterval
-      let precRes = lookupCurrencyPrec u
-      let go Amount {amtWhen, amtValue, amtDesc} = do
-            let dayRes = liftExcept $ expandDatePat bounds amtWhen
-            (days, precision) <- combineError dayRes precRes (,)
-            let tx day = txPair day from to u (roundPrecision precision amtValue) amtDesc
-            keys <- combineErrors $ fmap tx days
-            mapM_ (insertTx c) keys
-      void $ combineErrors $ fmap go amts
-
-readHistStmt
-  :: (MonadUnliftIO m, MonadFinance m)
-  => FilePath
-  -> Statement
-  -> m (Maybe (CommitR, [KeyTx]))
-readHistStmt root i = whenHash_ CTImport i $ do
-  bs <- readImport root i
-  bounds <- askDBState kmStatementInterval
-  liftIOExceptT $ mapErrors resolveTx $ filter (inDaySpan bounds . txDate) bs
-
-insertHistStmt :: (MonadSqlQuery m) => CommitR -> [KeyTx] -> m ()
-insertHistStmt c ks = do
     ck <- insert c
-  mapM_ (insertTx ck) ks
+    mapM_ (insertTx ck) ts
 
 --------------------------------------------------------------------------------
 -- low-level transaction stuff
 
 -- TODO tags here?
 txPair
-  :: (MonadInsertError m, MonadFinance m)
+  :: Day
-  => Day
   -> AcntID
   -> AcntID
   -> CurID
   -> Rational
   -> T.Text
-  -> m KeyTx
+  -> RawTx
-txPair day from to cur val desc = resolveTx tx
+txPair day from to cur val desc = tx
   where
     split a v =
       Entry
         { eAcnt = a
-        , eValue = v
+        , eValue = ConstD v
         , eComment = ""
         , eCurrency = cur
         , eTags = []
@@ -109,7 +129,7 @@ insertTx c Tx {txDate = d, txDescr = e, txEntries = ss} = do
 -- Statements
 
 -- TODO this probably won't scale well (pipes?)
-readImport :: (MonadUnliftIO m, MonadFinance m) => FilePath -> Statement -> m [BalTx]
+readImport :: (MonadUnliftIO m, MonadFinance m) => FilePath -> Statement -> m [RawTx]
 readImport root Statement {stmtTxOpts, stmtParsers, stmtSkipLines, stmtDelim, stmtPaths} = do
   let ores = compileOptions stmtTxOpts
   let cres = combineErrors $ compileMatch <$> stmtParsers
@@ -155,11 +175,13 @@ parseTxRecord p TxOpts {toDate, toAmountFmt, toDesc, toAmount, toOther, toDateFm
       d' <- parseTimeM True defaultTimeLocale (T.unpack toDateFmt) d
       return $ Just $ TxRecord d' a e os p
 
-matchRecords :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM [BalTx]
+-- TODO need to somehow balance temporally here (like I do in the budget for
+-- directives that "pay off" a balance)
+matchRecords :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM [RawTx]
 matchRecords ms rs = do
   (matched, unmatched, notfound) <- matchAll (matchPriorities ms) rs
   case (matched, unmatched, notfound) of
-    (ms_, [], []) -> liftInner $ combineErrors $ fmap balanceTx ms_
+    (ms_, [], []) -> return ms_ -- liftInner $ combineErrors $ fmap balanceTx ms_
     (_, us, ns) -> throwError $ InsertException [StatementError us ns]
 
 matchPriorities :: [MatchRe] -> [MatchGroup]
@@ -303,12 +325,49 @@ matchNonDates ms = go ([], [], initZipper ms)
             MatchFail -> (matched, r : unmatched)
        in go (m, u, resetZipper z') rs
 
-balanceTx :: RawTx -> InsertExcept BalTx
+balanceTxs
-balanceTx t@Tx {txEntries = ss} = do
+  :: (MonadInsertError m, MonadFinance m)
-  bs <- balanceEntries ss
+  => [(CommitR, RawTx)]
-  return $ t {txEntries = bs}
+  -> m [(CommitR, KeyTx)]
+balanceTxs ts = do
+  bs <- mapM balanceTx $ snd $ L.mapAccumR balanceTxTargets M.empty ts'
+  return $ zip cs bs
+  where
+    (cs, ts') = L.unzip $ L.sortOn (txDate . snd) ts
 
-balanceEntries :: [RawEntry] -> InsertExcept [BalEntry]
+balanceTxTargets
+  :: (Ord a, Ord c)
+  => M.Map (a, c) Rational
+  -> Tx (Entry a (Deferred Rational) c t)
+  -> (M.Map (a, c) Rational, Tx (Entry a (Maybe Rational) c t))
+balanceTxTargets bals t@Tx {txEntries} = (bals', t {txEntries = es})
+  where
+    (bals', es) = L.mapAccumR balanceEntryTargets bals txEntries
+
+balanceEntryTargets
+  :: (Ord a, Ord c)
+  => M.Map (a, c) Rational
+  -> Entry a (Deferred Rational) c t
+  -> (M.Map (a, c) Rational, Entry a (Maybe Rational) c t)
+balanceEntryTargets bals e@Entry {eValue, eAcnt, eCurrency} = (bals', e {eValue = v})
+  where
+    key = (eAcnt, eCurrency)
+    curBal = M.findWithDefault 0 key bals
+    v = case eValue of
+      ConstD x -> Just x
+      Target x -> Just $ x - curBal
+      Derive -> Nothing
+    bals' = maybe bals (\y -> mapAdd_ key y bals) v
+
+balanceTx
+  :: (MonadInsertError m, MonadFinance m)
+  => Tx (Entry AcntID (Maybe Rational) CurID TagID)
+  -> m KeyTx
+balanceTx t@Tx {txEntries = ss} = do
+  bs <- liftExcept $ balanceEntries ss
+  resolveTx $ t {txEntries = bs}
+
+balanceEntries :: [Entry AcntID (Maybe Rational) CurID TagID] -> InsertExcept [BalEntry]
 balanceEntries ss =
   fmap concat
     <$> mapM (uncurry bal)

lib/Internal/Types/Dhall.hs

@@ -32,7 +32,8 @@ makeHaskellTypesWith
   , MultipleConstructors "DatePat" "(./dhall/Types.dhall).DatePat"
   , MultipleConstructors "YMDMatcher" "(./dhall/Types.dhall).YMDMatcher"
   , MultipleConstructors "DateMatcher" "(./dhall/Types.dhall).DateMatcher"
-  , MultipleConstructors "EntryNumGetter" "(./dhall/Types.dhall).EntryNumGetter"
+  , MultipleConstructors "ToEntryNumGetter" "(./dhall/Types.dhall).ToEntryNumGetter"
+  , MultipleConstructors "FromEntryNumGetter" "(./dhall/Types.dhall).FromEntryNumGetter"
   , MultipleConstructors "BudgetCurrency" "(./dhall/Types.dhall).BudgetCurrency"
   , MultipleConstructors "BudgetTransferType" "(./dhall/Types.dhall).BudgetTransferType"
   , MultipleConstructors "TaxMethod" "(./dhall/Types.dhall).TaxMethod"
@@ -97,7 +98,8 @@ deriveProduct
   , "YMDMatcher"
   , "BudgetCurrency"
   , "Exchange"
-  , "EntryNumGetter"
+  , "FromEntryNumGetter"
+  , "ToEntryNumGetter"
   , "TemporalScope"
   , "SqlConfig"
   , "PretaxValue"
@@ -338,7 +340,9 @@ instance Ord DateMatcher where
   compare (On d) (In d' _) = compare d d' <> LT
   compare (In d _) (On d') = compare d d' <> GT
 
-deriving instance Hashable EntryNumGetter
+deriving instance Hashable FromEntryNumGetter
+
+deriving instance Hashable ToEntryNumGetter
 
 -------------------------------------------------------------------------------
 -- top level type with fixed account tree to unroll the recursion in the dhall
@@ -421,9 +425,9 @@ data History
   | HistStatement !Statement
   deriving (Eq, Generic, Hashable, FromDhall)
 
-type ToEntryGetter = Entry EntryAcnt (Maybe EntryNumGetter) EntryCur TagID
+type ToEntryGetter = Entry EntryAcnt (Maybe ToEntryNumGetter) EntryCur TagID
 
-type FromEntryGetter = Entry EntryAcnt EntryNumGetter EntryCur TagID
+type FromEntryGetter = Entry EntryAcnt FromEntryNumGetter EntryCur TagID
 
 instance FromDhall ToEntryGetter
 

lib/Internal/Types/Main.hs

@@ -59,8 +59,12 @@ data DBUpdates = DBUpdates
 
 type CurrencyM = Reader CurrencyMap
 
+type DeferredKeyEntry = Entry AccountRId (Deferred Rational) CurrencyRId TagRId
+
 type KeyEntry = Entry AccountRId Rational CurrencyRId TagRId
 
+type DeferredKeyTx = Tx DeferredKeyEntry
+
 type KeyTx = Tx KeyEntry
 
 type TreeR = Tree ([T.Text], AccountRId)
@@ -127,9 +131,12 @@ accountSign IncomeT = Credit
 accountSign LiabilityT = Credit
 accountSign EquityT = Credit
 
-type RawEntry = Entry AcntID (Maybe Rational) CurID TagID
+data Deferred a = ConstD a | Target a | Derive
+  deriving (Show, Functor, Foldable, Traversable)
 
-type RawFromEntry = Entry AcntID Rational CurID TagID
+type RawEntry = Entry AcntID (Deferred Rational) CurID TagID
+
+-- type RawFromEntry = Entry AcntID (Deferred Rational) CurID TagID
 
 type BalEntry = Entry AcntID Rational CurID TagID
 
@@ -172,7 +179,7 @@ data InsertError
   | ParseError !T.Text
   | ConversionError !T.Text
   | LookupError !LookupSuberr !T.Text
-  | BalanceError !BalanceType !CurID ![RawEntry]
+  | BalanceError !BalanceType !CurID ![Entry AcntID (Maybe Rational) CurID TagID]
   | IncomeError !Day !T.Text !Rational
   | PatternError !Natural !Natural !(Maybe Natural) !PatternSuberr
   | DaySpanError !Gregorian !(Maybe Gregorian)

lib/Internal/Utils.hs

@@ -55,6 +55,7 @@ module Internal.Utils
   , lookupCurrencyKey
   , lookupCurrencyPrec
   , lookupTag
+  , mapAdd_
   )
 where
 
@@ -319,26 +320,24 @@ toTx sc sa fromEntries toEntries r@TxRecord {trAmount, trDate, trDesc} = do
     (combineError acntRes curRes (,))
     (combineError fromRes toRes (,))
     $ \(a, c) (fs, ts) ->
-      let fromValue = trAmount - sum (fmap eValue fs)
+      let fromEntry =
-          fromEntry =
             Entry
               { eAcnt = a
               , eCurrency = c
-              , eValue = Just fromValue
+              , eValue = ConstD trAmount
               , eComment = "" -- TODO actually fill this in
               , eTags = [] -- TODO what goes here?
               }
        in Tx
             { txDate = trDate
             , txDescr = trDesc
-            , txEntries = fromEntry : fmap liftEntry fs ++ ts
+            , txEntries = fromEntry : fs ++ ts
             }
   where
     acntRes = liftInner $ resolveAcnt r sa
     curRes = liftInner $ resolveCurrency r sc
     fromRes = combineErrors $ fmap (resolveFromEntry r) fromEntries
     toRes = combineErrors $ fmap (resolveToEntry r) toEntries
-    liftEntry e = e {eValue = Just $ eValue e}
 
 valMatches :: ValMatcher -> Rational -> InsertExcept Bool
 valMatches ValMatcher {vmDen, vmSign, vmNum, vmPrec} x
@@ -364,20 +363,8 @@ otherMatches dict m = case m of
   where
     lookup_ t n = lookupErr (MatchField t) n dict
 
-resolveFromEntry :: TxRecord -> FromEntryGetter -> InsertExceptT CurrencyM RawFromEntry
+resolveFromEntry :: TxRecord -> FromEntryGetter -> InsertExceptT CurrencyM RawEntry
 resolveFromEntry r s@Entry {eAcnt, eValue, eCurrency} = do
-  m <- ask
-  liftInner $ combineErrorM3 acntRes curRes valRes $ \a c v -> do
-    v' <- roundPrecisionCur c m v
-    return $ s {eAcnt = a, eValue = v', eCurrency = c}
-  where
-    acntRes = resolveAcnt r eAcnt
-    curRes = resolveCurrency r eCurrency
-    valRes = resolveValue r eValue
-
--- TODO wet code (kinda, not sure if it's worth combining with above)
-resolveToEntry :: TxRecord -> ToEntryGetter -> InsertExceptT CurrencyM RawEntry
-resolveToEntry r s@Entry {eAcnt, eValue, eCurrency} = do
   m <- ask
   liftInner $ combineErrorM3 acntRes curRes valRes $ \a c v -> do
     v' <- mapM (roundPrecisionCur c m) v
@@ -385,7 +372,19 @@ resolveToEntry r s@Entry {eAcnt, eValue, eCurrency} = do
   where
     acntRes = resolveAcnt r eAcnt
     curRes = resolveCurrency r eCurrency
-    valRes = mapM (resolveValue r) eValue
+    valRes = resolveFromValue r eValue
+
+-- TODO wet code (kinda, not sure if it's worth combining with above)
+resolveToEntry :: TxRecord -> ToEntryGetter -> InsertExceptT CurrencyM RawEntry
+resolveToEntry r s@Entry {eAcnt, eValue, eCurrency} = do
+  m <- ask
+  liftInner $ combineErrorM3 acntRes curRes valRes $ \a c v -> do
+    v' <- mapM (roundPrecisionCur c m) v
+    return $ s {eAcnt = a, eValue = maybe Derive Target v', eCurrency = c}
+  where
+    acntRes = resolveAcnt r eAcnt
+    curRes = resolveCurrency r eCurrency
+    valRes = mapM (resolveToValue r) eValue
 
 liftInner :: Monad m => ExceptT e Identity a -> ExceptT e m a
 liftInner = mapExceptT (return . runIdentity)
@@ -470,11 +469,19 @@ mapErrorsIO f xs = do
 collectErrorsIO :: MonadUnliftIO m => [m a] -> m [a]
 collectErrorsIO = mapErrorsIO id
 
-resolveValue :: TxRecord -> EntryNumGetter -> InsertExcept Double
+resolveFromValue :: TxRecord -> FromEntryNumGetter -> InsertExcept (Deferred Double)
-resolveValue TxRecord {trOther, trAmount} s = case s of
+resolveFromValue TxRecord {trOther, trAmount} s = case s of
-  (LookupN t) -> readDouble =<< lookupErr EntryValField t trOther
+  (FLookupN t) -> ConstD <$> (readDouble =<< lookupErr EntryValField t trOther)
-  (ConstN c) -> return c
+  (FConstN c) -> return $ ConstD c
-  AmountN m -> return $ (* m) $ fromRational trAmount
+  FAmountN m -> return $ ConstD $ (* m) $ fromRational trAmount
+  FBalanceN x -> return $ Target x
+
+-- TODO not DRY
+resolveToValue :: TxRecord -> ToEntryNumGetter -> InsertExcept Double
+resolveToValue TxRecord {trOther, trAmount} s = case s of
+  (TLookupN t) -> readDouble =<< lookupErr EntryValField t trOther
+  (TConstN c) -> return c
+  TAmountN m -> return $ (* m) $ fromRational trAmount
 
 resolveAcnt :: TxRecord -> EntryAcnt -> InsertExcept T.Text
 resolveAcnt = resolveEntryField AcntField
@@ -750,7 +757,7 @@ showMatchOther (Val (Field f mv)) =
     , singleQuote $ fromMaybe "*" $ showValMatcher mv
     ]
 
-showEntry :: RawEntry -> T.Text
+showEntry :: Entry AcntID (Maybe Rational) CurID TagID -> T.Text
 showEntry Entry {eAcnt, eValue, eComment} =
   keyVals
     [ ("account", eAcnt)
@@ -849,6 +856,9 @@ unlessLefts_ e f = unlessLefts e (\x -> void (f x) >> return mzero)
 -- thrice :: (a -> d) -> (b -> e) -> (c -> f) -> (a, b, c) -> (d, e, f)
 -- thrice f1 f2 f3 (x, y, z) = (f1 x, f2 y, f3 z)
 
+mapAdd_ :: (Ord k, Num v) => k -> v -> M.Map k v -> M.Map k v
+mapAdd_ k v = M.alter (maybe (Just v) (Just . (+ v))) k
+
 uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d
 uncurry3 f (a, b, c) = f a b c