WIP track running balances in budget

app/Main.hs

@@ -1,7 +1,8 @@
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ImplicitPrelude #-}
 
 module Main (main) where
 
+import Control.Monad.Reader
 import qualified Data.Text.IO as TI
 import Internal.Config
 import Internal.Database.Ops
@@ -162,11 +163,11 @@ runSync c = do
     case res of
       Left es -> throwIO $ InsertException es
       Right s -> do
-        flip runReaderT (s $ takeDirectory c) $ do
+        let run = mapReaderT $ flip runReaderT (s $ takeDirectory c)
-          es1 <- concat <$> mapM insertBudget (budget config)
+        es1 <- concat <$> mapM (run . insertBudget) (budget config)
-          es2 <- insertStatements config
+        es2 <- run $ insertStatements config
-          let es = es1 ++ es2
+        let es = es1 ++ es2
-          unless (null es) $ throwIO $ InsertException es
+        unless (null es) $ throwIO $ InsertException es
   where
     err (InsertException es) = do
       liftIO $ mapM_ TI.putStrLn $ concatMap showError es

budget.cabal

@@ -1,6 +1,6 @@
 cabal-version: 1.12
 
--- This file has been generated from package.yaml by hpack version 0.35.1.
+-- This file has been generated from package.yaml by hpack version 0.35.2.
 --
 -- see: https://github.com/sol/hpack
 
@@ -36,6 +36,42 @@ library
       Paths_budget
   hs-source-dirs:
       lib/
+  default-extensions:
+      OverloadedStrings
+      FlexibleContexts
+      FlexibleInstances
+      InstanceSigs
+      MultiParamTypeClasses
+      EmptyCase
+      LambdaCase
+      MultiWayIf
+      NamedFieldPuns
+      TupleSections
+      DeriveFoldable
+      DeriveFunctor
+      DeriveGeneric
+      DeriveLift
+      DeriveTraversable
+      DerivingStrategies
+      DeriveDataTypeable
+      EmptyDataDecls
+      PartialTypeSignatures
+      GeneralizedNewtypeDeriving
+      StandaloneDeriving
+      BangPatterns
+      TypeOperators
+      ScopedTypeVariables
+      TypeApplications
+      ConstraintKinds
+      RankNTypes
+      GADTs
+      DefaultSignatures
+      NoImplicitPrelude
+      FunctionalDependencies
+      DataKinds
+      TypeFamilies
+      BinaryLiterals
+      ViewPatterns
   ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -Wpartial-fields -Werror -O2
   build-depends:
       base >=4.12 && <10
@@ -50,6 +86,7 @@ library
     , hashable
     , lens >=5.0.1
     , monad-logger >=0.3.36
+    , mtl
     , optparse-applicative
     , persistent >=2.13.3.1
     , persistent-sqlite >=2.13.1.0
@@ -67,6 +104,42 @@ executable pwncash
       Paths_budget
   hs-source-dirs:
       app
+  default-extensions:
+      OverloadedStrings
+      FlexibleContexts
+      FlexibleInstances
+      InstanceSigs
+      MultiParamTypeClasses
+      EmptyCase
+      LambdaCase
+      MultiWayIf
+      NamedFieldPuns
+      TupleSections
+      DeriveFoldable
+      DeriveFunctor
+      DeriveGeneric
+      DeriveLift
+      DeriveTraversable
+      DerivingStrategies
+      DeriveDataTypeable
+      EmptyDataDecls
+      PartialTypeSignatures
+      GeneralizedNewtypeDeriving
+      StandaloneDeriving
+      BangPatterns
+      TypeOperators
+      ScopedTypeVariables
+      TypeApplications
+      ConstraintKinds
+      RankNTypes
+      GADTs
+      DefaultSignatures
+      NoImplicitPrelude
+      FunctionalDependencies
+      DataKinds
+      TypeFamilies
+      BinaryLiterals
+      ViewPatterns
   ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -Wpartial-fields -Werror -O2 -threaded
   build-depends:
       base >=4.12 && <10
@@ -82,6 +155,7 @@ executable pwncash
     , hashable
     , lens >=5.0.1
     , monad-logger >=0.3.36
+    , mtl
     , optparse-applicative
     , persistent >=2.13.3.1
     , persistent-sqlite >=2.13.1.0

dhall/Types.dhall

@@ -25,7 +25,14 @@ let Weekday = < Mon | Tue | Wed | Thu | Fri | Sat | Sun >
 let RepeatPat =
       { rpStart : Natural, rpBy : Natural, rpRepeats : Optional Natural }
 
-let MDYPat = < Single : Natural | Multi : List Natural | Repeat : RepeatPat >
+let MDYPat =
+      < Single : Natural
+      | Multi : List Natural
+      | Repeat : RepeatPat
+      | After : Natural
+      | Before : Natural
+      | Between : { _between1 : Natural, _between2 : Natural }
+      >
 
 let ModPat =
       { Type =
@@ -180,7 +187,9 @@ let IncomeBucket = < PreTax | IntraTax | PostTax >
 
 let Amount = { amtValue : Decimal, amtDesc : Text }
 
-let TimeAmount = { taWhen : DatePat, taAmt : Amount }
+let AmountType = < FixedAmt | Percent | Target >
+
+let TimeAmount = { taWhen : DatePat, taAmt : Amount, taAmtType : AmountType }
 
 let Tax = { taxAcnt : AcntID, taxValue : Decimal }
 
@@ -257,4 +266,5 @@ in  { CurID
     , Allocation
     , Amount
     , TimeAmount
+    , AmountType
     }

dhall/common.dhall

@@ -4,7 +4,7 @@ let List/map =
 
 let T =
       ./Types.dhall
-        sha256:27c65b31fe1b0dd58ff03ec0a37648f586914c81b81e5f33d3eac5a465475f2b
+        sha256:10af13e592448321c1e298f55a1e924e77b7e64bd35512147e0952de1f3abcfb
 
 let nullSplit =
       \(a : T.SplitAcnt) ->

lib/Internal/Config.hs

@@ -1,5 +1,3 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-
 module Internal.Config
   ( readConfig
   -- , readYaml

lib/Internal/Database/Model.hs

@@ -1,20 +1,6 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DerivingStrategies #-}
-{-# LANGUAGE EmptyDataDecls #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE UndecidableInstances #-}
-{-# LANGUAGE NoImplicitPrelude #-}
 
 module Internal.Database.Model where
 
@@ -84,13 +70,42 @@ data DBState = DBState
   , kmStatementInterval :: !Bounds
   , kmNewCommits :: ![Int]
   , kmConfigDir :: !FilePath
-  , kmBoundsCache :: !(MVar (M.Map (Bounds, DatePat) [Day]))
   }
 
-type MappingT m a = ReaderT DBState (SqlPersistT m) a
+type MappingT m = ReaderT DBState (SqlPersistT m)
 
 type KeySplit = Split AccountRId Rational CurrencyRId
 
 type KeyTx = Tx KeySplit
 
 type TreeR = Tree ([T.Text], AccountRId)
+
+type Balances = M.Map AccountRId Rational
+
+type BalanceM m = ReaderT (MVar Balances) m
+
+class MonadUnliftIO m => MonadFinance m where
+  askDBState :: (DBState -> a) -> m a
+
+instance MonadUnliftIO m => MonadFinance (ReaderT DBState m) where
+  askDBState = asks
+
+class MonadUnliftIO m => MonadBalance m where
+  askBalances :: m (MVar Balances)
+
+  withBalances :: (Balances -> m a) -> m a
+  withBalances f = do
+    bs <- askBalances
+    withMVar bs f
+
+  modifyBalances :: (Balances -> m (Balances, a)) -> m a
+  modifyBalances f = do
+    bs <- askBalances
+    modifyMVar bs f
+
+  lookupBalance :: AccountRId -> m Rational
+  lookupBalance i = withBalances $ return . fromMaybe 0 . M.lookup i
+
+  addBalance :: AccountRId -> Rational -> m ()
+  addBalance i v =
+    modifyBalances $ return . (,()) . M.alter (Just . maybe v (v +)) i

lib/Internal/Database/Ops.hs

@@ -1,11 +1,3 @@
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-
 module Internal.Database.Ops
   ( migrate_
   , nukeTables
@@ -48,6 +40,7 @@ migrate_ c more =
         (openConnection c)
         ( \backend ->
             flip runSqlConn backend $ do
+              _ <- askLoggerIO
               runMigration migrateAll
               more
         )
@@ -198,7 +191,8 @@ updateCurrencies cs = do
   return $ currencyMap curs
 
 currency2Record :: Currency -> Entity CurrencyR
-currency2Record c@Currency {..} = Entity (toKey c) $ CurrencyR curSymbol curFullname
+currency2Record c@Currency {curSymbol, curFullname} =
+  Entity (toKey c) $ CurrencyR curSymbol curFullname
 
 currencyMap :: [Entity CurrencyR] -> CurrencyMap
 currencyMap = M.fromList . fmap (\e -> (currencyRSymbol $ entityVal e, entityKey e))
@@ -291,7 +285,7 @@ xs !? n
         n
 
 flattenAcntRoot :: AccountRoot -> [(AcntType, AccountTree)]
-flattenAcntRoot AccountRoot_ {..} =
+flattenAcntRoot AccountRoot_ {arIncome, arExpenses, arLiabilities, arAssets, arEquity} =
   ((IncomeT,) <$> arIncome)
     ++ ((ExpenseT,) <$> arExpenses)
     ++ ((LiabilityT,) <$> arLiabilities)
@@ -315,7 +309,6 @@ getDBState c = do
   am <- updateAccounts $ accounts c
   cm <- updateCurrencies $ currencies c
   hs <- updateHashes c
-  v <- newMVar M.empty
   -- TODO not sure how I feel about this, probably will change this struct alot
   -- in the future so whatever...for now
   return $ concatEither2 bi si $ \b s f ->
@@ -326,7 +319,6 @@ getDBState c = do
       , kmStatementInterval = s
       , kmNewCommits = hs
       , kmConfigDir = f
-      , kmBoundsCache = v
       }
   where
     bi = resolveBounds $ budgetInterval $ global c

lib/Internal/Insert.hs

@@ -1,8 +1,3 @@
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-
 module Internal.Insert
   ( insertStatements
   , insertBudget
@@ -17,6 +12,8 @@ import Internal.Statement
 import Internal.Types hiding (sign)
 import Internal.Utils
 import RIO hiding (to)
+import qualified RIO.List as L
+import qualified RIO.Map as M
 import qualified RIO.Text as T
 import RIO.Time
 
@@ -43,24 +40,27 @@ expandModPat ModPat {mpStart = s, mpBy = b, mpUnit = u, mpRepeats = r} bs =
       Year -> addGregorianYearsClip
 
 expandCronPat :: Bounds -> CronPat -> EitherErrs [Day]
-expandCronPat b CronPat {..} = concatEither3 yRes mRes dRes $ \ys ms ds ->
+expandCronPat b CronPat {cronYear, cronMonth, cronDay, cronWeekly} =
-  filter validWeekday $
+  concatEither3 yRes mRes dRes $ \ys ms ds ->
-    mapMaybe (uncurry3 toDay) $
+    filter validWeekday $
-      takeWhile (\((y, _), m, d) -> (y, m, d) <= (yb1, mb1, db1)) $
+      mapMaybe (uncurry3 toDay) $
-        dropWhile (\((y, _), m, d) -> (y, m, d) < (yb0, mb0, db0)) $
+        takeWhile (\((y, _), m, d) -> (y, m, d) <= (yb1, mb1, db1)) $
-          [(y, m, d) | y <- (\y -> (y, isLeapYear y)) <$> ys, m <- ms, d <- ds]
+          dropWhile (\((y, _), m, d) -> (y, m, d) < (yb0, mb0, db0)) $
+            [(y, m, d) | y <- (\y -> (y, isLeapYear y)) <$> ys, m <- ms, d <- ds]
   where
     yRes = case cronYear of
       Nothing -> return [yb0 .. yb1]
       Just pat -> do
-        ys <- expandMDYPat (fromIntegral yb1) pat
+        ys <- expandMDYPat (fromIntegral yb0) (fromIntegral yb1) pat
         return $ dropWhile (< yb0) $ fromIntegral <$> ys
     mRes = expandMD 12 cronMonth
     dRes = expandMD 31 cronDay
     (s, e) = expandBounds b
     (yb0, mb0, db0) = toGregorian s
     (yb1, mb1, db1) = toGregorian $ addDays (-1) e
-    expandMD lim = fmap (fromIntegral <$>) . maybe (return [1 .. lim]) (expandMDYPat lim)
+    expandMD lim =
+      fmap (fromIntegral <$>)
+        . maybe (return [1 .. lim]) (expandMDYPat 1 lim)
     expandW (OnDay x) = [fromEnum x]
     expandW (OnDays xs) = fromEnum <$> xs
     ws = maybe [] expandW cronWeekly
@@ -70,56 +70,59 @@ expandCronPat b CronPat {..} = concatEither3 yRes mRes dRes $ \ys ms ds ->
       | m `elem` [4, 6, 9, 11] && d > 30 = Nothing
       | otherwise = Just $ fromGregorian y m d
 
-expandMDYPat :: Natural -> MDYPat -> EitherErr [Natural]
+expandMDYPat :: Natural -> Natural -> MDYPat -> EitherErr [Natural]
-expandMDYPat _ (Single x) = Right [x]
+expandMDYPat lower upper (Single x) = Right [x | lower <= x && x <= upper]
-expandMDYPat _ (Multi xs) = Right xs
+expandMDYPat lower upper (Multi xs) = Right $ dropWhile (<= lower) $ takeWhile (<= upper) xs
-expandMDYPat lim (Repeat RepeatPat {rpStart = s, rpBy = b, rpRepeats = r})
+expandMDYPat lower upper (After x) = Right [max lower x .. upper]
+expandMDYPat lower upper (Before x) = Right [lower .. min upper x]
+expandMDYPat lower upper (Between x y) = Right [max lower x .. min upper y]
+expandMDYPat lower upper (Repeat RepeatPat {rpStart = s, rpBy = b, rpRepeats = r})
   | b < 1 = Left $ PatternError s b r ZeroLength
   | otherwise = do
       k <- limit r
-      return $ takeWhile (<= k) [s + i * b | i <- [0 ..]]
+      return $ dropWhile (<= lower) $ takeWhile (<= k) [s + i * b | i <- [0 ..]]
   where
-    limit Nothing = Right lim
+    limit Nothing = Right upper
     limit (Just n)
       -- this guard not only produces the error for the user but also protects
       -- from an underflow below it
       | n < 1 = Left $ PatternError s b r ZeroRepeats
-      | otherwise = Right $ min (s + b * (n - 1)) lim
+      | otherwise = Right $ min (s + b * (n - 1)) upper
 
 dayToWeekday :: Day -> Int
 dayToWeekday (ModifiedJulianDay d) = mod (fromIntegral d + 2) 7
 
 withDates
-  :: MonadUnliftIO m
+  :: MonadFinance m
   => DatePat
-  -> (Day -> MappingT m a)
+  -> (Day -> SqlPersistT m a)
-  -> MappingT m (EitherErrs [a])
+  -> SqlPersistT m (EitherErrs [a])
 withDates dp f = do
-  bounds <- asks kmBudgetInterval
+  bounds <- lift $ askDBState kmBudgetInterval
   let days = expandDatePat bounds dp
   mapM (mapM f) days
 
 --------------------------------------------------------------------------------
 -- budget
 
-insertBudget :: MonadUnliftIO m => Budget -> MappingT m [InsertError]
+insertBudget :: MonadFinance m => Budget -> SqlPersistT m [InsertError]
 insertBudget Budget {budgetLabel = name, income = is, transfers = es} = do
   es1 <- mapM (insertIncome name) is
-  es2 <- mapM (insertTransfer name) es
+  es2 <- insertTransfers name es
-  return $ concat $ es1 ++ es2
+  return $ concat es1 ++ es2
 
 -- TODO this hashes twice (not that it really matters)
 whenHash
-  :: (Hashable a, MonadUnliftIO m)
+  :: (Hashable a, MonadFinance m)
   => ConfigType
   -> a
   -> b
-  -> (Key CommitR -> MappingT m b)
+  -> (Key CommitR -> SqlPersistT m b)
-  -> MappingT m b
+  -> SqlPersistT m b
 whenHash t o def f = do
   let h = hash o
-  hs <- asks kmNewCommits
+  hs <- lift $ askDBState kmNewCommits
-  if h `elem` hs then f =<< lift (insert $ CommitR h t) else return def
+  if h `elem` hs then f =<< insert (CommitR h t) else return def
 
 -- TODO allow currency conversions here
 data BudgetSplit b = BudgetSplit
@@ -142,26 +145,28 @@ data BudgetTx = BudgetTx
   , btDesc :: !T.Text
   }
 
-insertIncome :: MonadUnliftIO m => T.Text -> Income -> MappingT m [InsertError]
+insertIncome :: MonadFinance m => T.Text -> Income -> SqlPersistT m [InsertError]
-insertIncome name i@Income {..} =
+insertIncome
-  whenHash CTIncome i [] $ \c ->
+  name
-    unlessLeft (balanceIncome i) $ \balance -> do
+  i@Income {incWhen, incCurrency, incFrom, incPretax, incPosttax, incTaxes, incToBal} =
-      res <- withDates incWhen $ \day -> do
+    whenHash CTIncome i [] $ \c ->
-        let meta = BudgetMeta c day incCurrency name
+      unlessLeft (balanceIncome i) $ \balance -> do
-        let fromAllos b = concatMap (fromAllo meta incFrom (Just b))
+        res <- withDates incWhen $ \day -> do
-        let pre = fromAllos PreTax incPretax
+          let meta = BudgetMeta c day incCurrency name
-        let tax = fmap (fromTax meta incFrom) incTaxes
+          let fromAllos b = concatMap (fromAllo meta incFrom (Just b))
-        let post = fromAllos PostTax incPosttax
+          let pre = fromAllos PreTax incPretax
-        let bal =
+          let tax = fmap (fromTax meta incFrom) incTaxes
-              BudgetTx
+          let post = fromAllos PostTax incPosttax
-                { btMeta = meta
+          let bal =
-                , btFrom = BudgetSplit incFrom $ Just PostTax
+                BudgetTx
-                , btTo = BudgetSplit incToBal Nothing
+                  { btMeta = meta
-                , btValue = balance
+                  , btFrom = BudgetSplit incFrom $ Just PostTax
-                , btDesc = "balance after deductions"
+                  , btTo = BudgetSplit incToBal Nothing
-                }
+                  , btValue = balance
-        fmap concat $ mapM insertBudgetTx $ bal : (pre ++ tax ++ post)
+                  , btDesc = "balance after deductions"
-      unlessLefts res $ return . concat
+                  }
+          fmap concat $ mapM insertBudgetTx $ bal : (pre ++ tax ++ post)
+        unlessLefts res $ return . concat
 
 fromAllo
   :: BudgetMeta
@@ -169,7 +174,8 @@ fromAllo
   -> Maybe IncomeBucket
   -> Allocation
   -> [BudgetTx]
-fromAllo meta from ib Allocation {..} = fmap (toBT alloPath) alloAmts
+fromAllo meta from ib Allocation {alloPath, alloAmts, alloBucket} =
+  fmap (toBT alloPath) alloAmts
   where
     toBT to (Amount desc v) =
       BudgetTx
@@ -210,33 +216,98 @@ sumAllocation = sum . fmap (dec2Rat . amtValue) . alloAmts
 sumTaxes :: [Tax] -> Rational
 sumTaxes = sum . fmap (dec2Rat . taxValue)
 
-insertTransfer :: MonadUnliftIO m => T.Text -> Transfer -> MappingT m [InsertError]
+insertTransfers :: MonadFinance m => T.Text -> [Transfer] -> SqlPersistT m [InsertError]
-insertTransfer name t@Transfer {..} =
+insertTransfers name ts = do
-  fmap concat $ whenHash CTExpense t [] $ \key -> do
+  res <- expandTransfers name ts
-    forM transAmounts $ \(TimeAmount amt pat) -> do
+  unlessLefts res $ \txs ->
-      res <- withDates pat $ \day -> insertBudgetTx $ budgetTx amt day key
+    fmap concat <$> mapM insertBudgetTx $ balanceTransfers txs
-      unlessLefts res $ return . concat
-  where
-    meta d c =
-      BudgetMeta
-        { bmWhen = d
-        , bmCur = transCurrency
-        , bmCommit = c
-        , bmName = name
-        }
-    budgetTx (Amount desc v) d c =
-      BudgetTx
-        { btMeta = meta d c
-        , btFrom = BudgetSplit transFrom Nothing
-        , btTo = BudgetSplit transTo Nothing
-        , btValue = dec2Rat v
-        , btDesc = desc
-        }
 
-insertBudgetTx :: MonadUnliftIO m => BudgetTx -> MappingT m [InsertError]
+expandTransfers :: MonadFinance m => T.Text -> [Transfer] -> SqlPersistT m (EitherErrs [TransferTx])
-insertBudgetTx BudgetTx {..} = do
+expandTransfers name ts = do
+  txs <- mapM (expandTransfer name) ts
+  return $ L.sortOn (bmWhen . trxMeta) . concat <$> concatEithersL txs
+
+-- TODO the entire budget needs to have this process applied to it
+balanceTransfers :: [TransferTx] -> [BudgetTx]
+balanceTransfers ts = snd $ L.mapAccumR go initBals $ L.sortOn (bmWhen . trxMeta) ts
+  where
+    initBals = M.fromList $ fmap (,0) $ L.nub $ (fmap trxTo ts ++ fmap trxTo ts)
+    updateBal x = M.update (Just . (+ x))
+    lookupBal = M.findWithDefault (error "this should not happen")
+    go bals TransferTx {trxMeta, trxFrom, trxTo, trxValue, trxType, trxDesc} =
+      let bal = lookupBal trxTo bals
+          x = amtToMove bal trxType trxValue
+          t =
+            BudgetTx
+              { btMeta = trxMeta
+              , btFrom = BudgetSplit trxFrom Nothing
+              , btTo = BudgetSplit trxTo Nothing
+              , btValue = x
+              , btDesc = trxDesc
+              }
+       in (updateBal x trxFrom $ updateBal (-x) trxFrom bals, t)
+    -- TODO might need to query signs to make this intuitive; as it is this will
+    -- probably work, but for credit accounts I might need to supply a negative
+    -- target value
+    amtToMove _ FixedAmt x = x
+    amtToMove bal Percent x = -(x / 100 * bal)
+    amtToMove bal Target x = x - bal
+
+expandTransfer :: MonadFinance m => T.Text -> Transfer -> SqlPersistT m (EitherErrs [TransferTx])
+expandTransfer name t@Transfer {transAmounts, transTo, transCurrency, transFrom} =
+  whenHash CTExpense t (Right []) $ \key -> do
+    res <- forM transAmounts $ \(TimeAmount (Amount desc v) atype pat) ->
+      withDates pat $ \day ->
+        let meta =
+              BudgetMeta
+                { bmWhen = day
+                , bmCur = transCurrency
+                , bmCommit = key
+                , bmName = name
+                }
+         in return $
+              TransferTx
+                { trxMeta = meta
+                , trxFrom = transFrom
+                , trxTo = transTo
+                , trxValue = dec2Rat v
+                , trxType = atype
+                , trxDesc = desc
+                }
+    return $ concat <$> concatEithersL res
+
+data TransferTx = TransferTx
+  { trxMeta :: !BudgetMeta
+  , trxFrom :: !AcntID
+  , trxTo :: !AcntID
+  , trxValue :: !Rational
+  , trxType :: AmountType
+  , trxDesc :: !T.Text
+  }
+
+-- amountBalance
+--   :: (MonadFinance m, MonadBalance m)
+--   => AmountType
+--   -> AcntID
+--   -> Rational
+--   -> SqlPersistT m (EitherErr Rational)
+-- amountBalance at i v = do
+--   res <- lookupAccountKey i
+--   case res of
+--     Left e -> return $ Left e
+--     Right k -> do
+--       b <- lookupBalance k
+--       return $ Right $ case at of
+--         FixedAmt -> v
+--         -- TODO what is the sign for this?
+--         Percent -> v / 100 * b
+--         -- TODO what is the sign for this?
+--         Target -> b - v
+
+insertBudgetTx :: MonadFinance m => BudgetTx -> SqlPersistT m [InsertError]
+insertBudgetTx BudgetTx {btFrom, btTo, btMeta, btValue, btDesc} = do
   res <- splitPair (bsAcnt btFrom) (bsAcnt btTo) (bmCur btMeta) btValue
-  unlessLefts_ res $ \(sFrom, sTo) -> lift $ do
+  unlessLefts_ res $ \(sFrom, sTo) -> do
     k <- insert $ TransactionR (bmCommit btMeta) (bmWhen btMeta) btDesc
     insertBudgetLabel name k IncomeBucketR sFrom btFrom
     insertBudgetLabel name k ExpenseBucketR sTo btTo
@@ -257,12 +328,12 @@ insertBudgetLabel name k bucketType split bs = do
   forM_ (bsBucket bs) $ insert_ . bucketType bk
 
 splitPair
-  :: MonadUnliftIO m
+  :: MonadFinance m
   => AcntID
   -> AcntID
   -> CurID
   -> Rational
-  -> MappingT m (EitherErrs (KeySplit, KeySplit))
+  -> SqlPersistT m (EitherErrs (KeySplit, KeySplit))
 splitPair from to cur val = do
   s1 <- split from (-val)
   s2 <- split to val
@@ -280,14 +351,14 @@ splitPair from to cur val = do
 --------------------------------------------------------------------------------
 -- statements
 
-insertStatements :: MonadUnliftIO m => Config -> MappingT m [InsertError]
+insertStatements :: MonadFinance m => Config -> SqlPersistT m [InsertError]
 insertStatements conf = concat <$> mapM insertStatement (statements conf)
 
-insertStatement :: MonadUnliftIO m => Statement -> MappingT m [InsertError]
+insertStatement :: MonadFinance m => Statement -> SqlPersistT m [InsertError]
 insertStatement (StmtManual m) = insertManual m
 insertStatement (StmtImport i) = insertImport i
 
-insertManual :: MonadUnliftIO m => Manual -> MappingT m [InsertError]
+insertManual :: MonadFinance m => Manual -> SqlPersistT m [InsertError]
 insertManual
   m@Manual
     { manualDate = dp
@@ -298,23 +369,23 @@ insertManual
     , manualDesc = e
     } = do
     whenHash CTManual m [] $ \c -> do
-      bounds <- asks kmStatementInterval
+      bounds <- lift $ askDBState kmStatementInterval
       -- let days = expandDatePat bounds dp
       let dayRes = expandDatePat bounds dp
       unlessLefts dayRes $ \days -> do
         txRes <- mapM tx days
-        unlessLefts_ (concatEithersL txRes) $ lift . mapM_ (insertTx c)
+        unlessLefts_ (concatEithersL txRes) $ mapM_ (insertTx c)
     where
       tx day = txPair day from to u (dec2Rat v) e
 
-insertImport :: MonadUnliftIO m => Import -> MappingT m [InsertError]
+insertImport :: MonadFinance m => Import -> SqlPersistT m [InsertError]
 insertImport i = whenHash CTImport i [] $ \c -> do
   -- TODO this isn't efficient, the whole file will be read and maybe no
   -- transactions will be desired
-  recoverIO (readImport i) $ \r -> unlessLefts r $ \bs -> do
+  recoverIO (lift $ readImport i) $ \r -> unlessLefts r $ \bs -> do
-    bounds <- expandBounds <$> asks kmStatementInterval
+    bounds <- expandBounds <$> lift (askDBState kmStatementInterval)
     res <- mapM resolveTx $ filter (inBounds bounds . txDate) bs
-    unlessLefts_ (concatEithersL res) $ lift . mapM_ (insertTx c)
+    unlessLefts_ (concatEithersL res) $ mapM_ (insertTx c)
   where
     recoverIO x rest = do
       res <- tryIO x
@@ -328,14 +399,14 @@ insertImport i = whenHash CTImport i [] $ \c -> do
 -- low-level transaction stuff
 
 txPair
-  :: MonadUnliftIO m
+  :: MonadFinance m
   => Day
   -> AcntID
   -> AcntID
   -> CurID
   -> Rational
   -> T.Text
-  -> MappingT m (EitherErrs KeyTx)
+  -> SqlPersistT m (EitherErrs KeyTx)
 txPair day from to cur val desc = resolveTx tx
   where
     split a v = Split {sAcnt = a, sValue = v, sComment = "", sCurrency = cur}
@@ -347,12 +418,12 @@ txPair day from to cur val desc = resolveTx tx
         , txSplits = [split from (-val), split to val]
         }
 
-resolveTx :: MonadUnliftIO m => BalTx -> MappingT m (EitherErrs KeyTx)
+resolveTx :: MonadFinance m => BalTx -> SqlPersistT m (EitherErrs KeyTx)
 resolveTx t@Tx {txSplits = ss} = do
   res <- concatEithersL <$> mapM resolveSplit ss
   return $ fmap (\kss -> t {txSplits = kss}) res
 
-resolveSplit :: MonadUnliftIO m => BalSplit -> MappingT m (EitherErrs KeySplit)
+resolveSplit :: MonadFinance m => BalSplit -> SqlPersistT m (EitherErrs KeySplit)
 resolveSplit s@Split {sAcnt = p, sCurrency = c, sValue = v} = do
   aid <- lookupAccountKey p
   cid <- lookupCurrency c
@@ -375,14 +446,14 @@ insertSplit :: MonadUnliftIO m => Key TransactionR -> KeySplit -> SqlPersistT m
 insertSplit t Split {sAcnt = aid, sCurrency = cid, sValue = v, sComment = c} = do
   insert $ SplitR t cid aid c v
 
-lookupAccount :: MonadUnliftIO m => AcntID -> MappingT m (EitherErr (Key AccountR, AcntSign))
+lookupAccount :: MonadFinance m => AcntID -> SqlPersistT m (EitherErr (Key AccountR, AcntSign))
-lookupAccount p = lookupErr (DBKey AcntField) p <$> asks kmAccount
+lookupAccount p = lookupErr (DBKey AcntField) p <$> lift (askDBState kmAccount)
 
-lookupAccountKey :: MonadUnliftIO m => AcntID -> MappingT m (EitherErr (Key AccountR))
+lookupAccountKey :: MonadFinance m => AcntID -> SqlPersistT m (EitherErr (Key AccountR))
 lookupAccountKey = fmap (fmap fst) . lookupAccount
 
-lookupAccountSign :: MonadUnliftIO m => AcntID -> MappingT m (EitherErr AcntSign)
+lookupAccountSign :: MonadFinance m => AcntID -> SqlPersistT m (EitherErr AcntSign)
 lookupAccountSign = fmap (fmap snd) . lookupAccount
 
-lookupCurrency :: MonadUnliftIO m => T.Text -> MappingT m (EitherErr (Key CurrencyR))
+lookupCurrency :: MonadFinance m => T.Text -> SqlPersistT m (EitherErr (Key CurrencyR))
-lookupCurrency c = lookupErr (DBKey CurField) c <$> asks kmCurrency
+lookupCurrency c = lookupErr (DBKey CurField) c <$> lift (askDBState kmCurrency)

lib/Internal/Statement.hs

@@ -1,8 +1,4 @@
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE NoImplicitPrelude #-}
 
 module Internal.Statement
   ( readImport
@@ -24,7 +20,7 @@ import qualified RIO.Vector as V
 
 -- TODO this probably won't scale well (pipes?)
 
-readImport :: MonadUnliftIO m => Import -> MappingT m (EitherErrs [BalTx])
+readImport :: MonadFinance m => Import -> m (EitherErrs [BalTx])
 readImport Import {..} = do
   let ores = plural $ compileOptions impTxOpts
   let cres = concatEithersL $ compileMatch <$> impMatches
@@ -37,14 +33,14 @@ readImport Import {..} = do
     Left es -> return $ Left es
 
 readImport_
-  :: MonadUnliftIO m
+  :: MonadFinance m
   => Natural
   -> Word
   -> TxOptsRe
   -> FilePath
-  -> MappingT m (EitherErr [TxRecord])
+  -> m (EitherErr [TxRecord])
 readImport_ n delim tns p = do
-  dir <- asks kmConfigDir
+  dir <- askDBState kmConfigDir
   bs <- liftIO $ BL.readFile $ dir </> p
   case decodeByNameWithP (parseTxRecord p tns) opts $ skip bs of
     Left m -> return $ Left $ ParseError $ T.pack m

lib/Internal/Types.hs

@@ -1,17 +1,5 @@
 {-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE DeriveLift #-}
-{-# LANGUAGE DeriveTraversable #-}
-{-# LANGUAGE DerivingStrategies #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE NoImplicitPrelude #-}
 
 module Internal.Types where
 
@@ -45,6 +33,7 @@ makeHaskellTypesWith
   , MultipleConstructors "SplitNum" "(./dhall/Types.dhall).SplitNum"
   , MultipleConstructors "ExpenseBucket" "(./dhall/Types.dhall).ExpenseBucket"
   , MultipleConstructors "IncomeBucket" "(./dhall/Types.dhall).IncomeBucket"
+  , MultipleConstructors "AmountType" "(./dhall/Types.dhall).AmountType"
   , SingleConstructor "Currency" "Currency" "(./dhall/Types.dhall).Currency"
   , SingleConstructor "Gregorian" "Gregorian" "(./dhall/Types.dhall).Gregorian"
   , SingleConstructor "GregorianM" "GregorianM" "(./dhall/Types.dhall).GregorianM"
@@ -303,6 +292,10 @@ instance PersistField ExpenseBucket where
 instance PersistFieldSql ExpenseBucket where
   sqlType _ = SqlString
 
+deriving instance Eq AmountType
+
+deriving instance Hashable AmountType
+
 deriving instance Eq TimeAmount
 
 deriving instance Hashable TimeAmount

lib/Internal/Utils.hs

@@ -1,8 +1,3 @@
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-
 module Internal.Utils
   ( compareDate
   , inBounds
@@ -78,14 +73,14 @@ xGregToDay :: XGregorian -> Day
 xGregToDay XGregorian {xgYear = y, xgMonth = m, xgDay = d} = fromGregorian (fromIntegral y) m d
 
 gregTup :: Gregorian -> (Integer, Int, Int)
-gregTup Gregorian {..} =
+gregTup Gregorian {gYear, gMonth, gDay} =
   ( fromIntegral gYear
   , fromIntegral gMonth
   , fromIntegral gDay
   )
 
 gregMTup :: GregorianM -> (Integer, Int)
-gregMTup GregorianM {..} =
+gregMTup GregorianM {gmYear, gmMonth} =
   ( fromIntegral gmYear
   , fromIntegral gmMonth
   )
@@ -145,20 +140,22 @@ expandBounds (d, n) = (d, addDays (fromIntegral n + 1) d)
 -- matching
 
 matches :: MatchRe -> TxRecord -> EitherErrs (MatchRes RawTx)
-matches Match {..} r@TxRecord {..} = do
+matches
-  res <- concatEither3 val other desc $ \x y z -> x && y && z
+  Match {mTx, mOther, mVal, mDate, mDesc}
-  if date && res
+  r@TxRecord {trDate, trAmount, trDesc, trOther} = do
-    then maybe (Right MatchSkip) (fmap MatchPass . convert) mTx
+    res <- concatEither3 val other desc $ \x y z -> x && y && z
-    else Right MatchFail
+    if date && res
-  where
+      then maybe (Right MatchSkip) (fmap MatchPass . convert) mTx
-    val = valMatches mVal trAmount
+      else Right MatchFail
-    date = maybe True (`dateMatches` trDate) mDate
+    where
-    other = foldM (\a o -> (a &&) <$> otherMatches trOther o) True mOther
+      val = valMatches mVal trAmount
-    desc = maybe (return True) (matchMaybe trDesc . snd) mDesc
+      date = maybe True (`dateMatches` trDate) mDate
-    convert (ToTx cur a ss) = toTx cur a ss r
+      other = foldM (\a o -> (a &&) <$> otherMatches trOther o) True mOther
+      desc = maybe (return True) (matchMaybe trDesc . snd) mDesc
+      convert (ToTx cur a ss) = toTx cur a ss r
 
 toTx :: SplitCur -> SplitAcnt -> [ExpSplit] -> TxRecord -> EitherErrs RawTx
-toTx sc sa toSplits r@TxRecord {..} =
+toTx sc sa toSplits r@TxRecord {trAmount, trDate, trDesc} =
   concatEithers2 acRes ssRes $ \(a_, c_) ss_ ->
     let fromSplit =
           Split
@@ -178,7 +175,7 @@ toTx sc sa toSplits r@TxRecord {..} =
     ssRes = concatEithersL $ fmap (resolveSplit r) toSplits
 
 valMatches :: MatchVal -> Rational -> EitherErr Bool
-valMatches MatchVal {..} x
+valMatches MatchVal {mvDen, mvSign, mvNum, mvPrec} x
   | Just d_ <- mvDen, d_ >= p = Left $ MatchValPrecisionError d_ p
   | otherwise =
       Right $
@@ -251,8 +248,9 @@ parseRational (pat, re) s = case matchGroupsMaybe s re of
   _ -> msg "malformed decimal"
   where
     readT what t = case readMaybe $ T.unpack t of
-      Just d -> return $ fromInteger d
+      Just d -> return d
       _ -> msg $ T.unwords ["could not parse", what, t]
+    msg :: MonadFail m => T.Text -> m a
     msg m =
       fail $
         T.unpack $
@@ -296,7 +294,7 @@ fmtRational precision x = T.concat [s, txt n', ".", pad 2 "0" $ txt d']
     pad i c z = T.append (T.replicate (i - T.length z) c) z
 
 dec2Rat :: Decimal -> Rational
-dec2Rat D {..} =
+dec2Rat D {sign, whole, decimal, precision} =
   k * (fromIntegral whole + (fromIntegral decimal % (10 ^ precision)))
   where
     k = if sign then 1 else -1
@@ -364,7 +362,7 @@ showError other = (: []) $ case other of
       splits = T.intercalate ", " $ fmap (singleQuote . showSplit) rss
 
 showGregorian_ :: Gregorian -> T.Text
-showGregorian_ Gregorian {..} = T.intercalate "-" $ showT <$> [gYear, gMonth, gDay]
+showGregorian_ Gregorian {gYear, gMonth, gDay} = T.intercalate "-" $ showT <$> [gYear, gMonth, gDay]
 
 showTx :: TxRecord -> T.Text
 showTx TxRecord {trDate = d, trAmount = v, trDesc = e, trFile = f} =
@@ -428,7 +426,8 @@ showYMD_ md =
 
 showMatchVal :: MatchVal -> Maybe T.Text
 showMatchVal MatchVal {mvSign = Nothing, mvNum = Nothing, mvDen = Nothing} = Nothing
-showMatchVal MatchVal {..} = Just $ singleQuote $ keyVals [(k, v) | (k, Just v) <- kvs]
+showMatchVal MatchVal {mvNum, mvDen, mvSign, mvPrec} =
+  Just $ singleQuote $ keyVals [(k, v) | (k, Just v) <- kvs]
   where
     kvs =
       [ ("sign", (\s -> if s then "+" else "-") <$> mvSign)

package.yaml

@@ -10,15 +10,59 @@ extra-source-files:
 - README.md
 - ChangeLog.md
 
-# Metadata used when publishing your package
 # synopsis:            Short description of your package
 # category:            Web
 
-# To avoid duplicated efforts in documentation and dealing with the
-# complications of embedding Haddock markup inside cabal files, it is
-# common to point users to the README.md file.
 description:         Please see the README on GitHub at <https://github.com/ndwarshuis/budget#readme>
 
+default-extensions:
+  - OverloadedStrings
+  - FlexibleContexts
+  - FlexibleInstances
+  - InstanceSigs
+  - MultiParamTypeClasses
+  - EmptyCase
+  - LambdaCase
+  - MultiWayIf
+  - NamedFieldPuns
+  - TupleSections
+  - DeriveFoldable
+  - DeriveFunctor
+  - DeriveGeneric
+  - DeriveLift
+  - DeriveTraversable
+  - DerivingStrategies
+  - DeriveDataTypeable
+  - EmptyDataDecls
+  - PartialTypeSignatures
+  - GeneralizedNewtypeDeriving
+  - StandaloneDeriving
+  - BangPatterns
+  - TypeOperators
+  - ScopedTypeVariables
+  - TypeApplications
+  - ConstraintKinds
+  - RankNTypes
+  - GADTs
+  - DefaultSignatures
+  - NoImplicitPrelude
+  - FunctionalDependencies
+  - DataKinds
+  - TypeFamilies
+  - BinaryLiterals
+  - ViewPatterns
+
+ghc-options:
+- -Wall
+- -Wcompat
+- -Widentities
+- -Wincomplete-record-updates
+- -Wincomplete-uni-patterns
+- -Wredundant-constraints
+- -Wpartial-fields
+- -Werror
+- -O2
+
 dependencies:
 - base >= 4.12 && < 10
 - rio >= 0.1.21.0
@@ -41,34 +85,16 @@ dependencies:
 - recursion-schemes
 - data-fix
 - filepath
+- mtl
 
 library:
   source-dirs: lib/
-  ghc-options:
-  - -Wall
-  - -Wcompat
-  - -Widentities
-  - -Wincomplete-record-updates
-  - -Wincomplete-uni-patterns
-  - -Wredundant-constraints
-  - -Wpartial-fields
-  - -Werror
-  - -O2
 
 executables:
   pwncash:
     main:                Main.hs
     source-dirs:         app
     ghc-options:
-    - -Wall
-    - -Wcompat
-    - -Widentities
-    - -Wincomplete-record-updates
-    - -Wincomplete-uni-patterns
-    - -Wredundant-constraints
-    - -Wpartial-fields
-    - -Werror
-    - -O2
     - -threaded
     dependencies:
     - budget