app/Main.hs

@@ -1,8 +1,7 @@
-{-# LANGUAGE ImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
 
 module Main (main) where
 
-import Control.Monad.Reader
 import qualified Data.Text.IO as TI
 import Internal.Config
 import Internal.Database.Ops
@@ -163,11 +162,11 @@ runSync c = do
     case res of
       Left es -> throwIO $ InsertException es
       Right s -> do
-        let run = mapReaderT $ flip runReaderT (s $ takeDirectory c)
+        flip runReaderT (s $ takeDirectory c) $ do
-        es1 <- concat <$> mapM (run . insertBudget) (budget config)
+          es1 <- concat <$> mapM insertBudget (budget config)
-        es2 <- run $ insertStatements config
+          es2 <- 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.2.
+-- This file has been generated from package.yaml by hpack version 0.35.1.
 --
 -- see: https://github.com/sol/hpack
 
@@ -36,42 +36,6 @@ 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
@@ -86,7 +50,6 @@ 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
@@ -104,42 +67,6 @@ 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
@@ -155,7 +82,6 @@ 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,14 +25,7 @@ let Weekday = < Mon | Tue | Wed | Thu | Fri | Sat | Sun >
 let RepeatPat =
       { rpStart : Natural, rpBy : Natural, rpRepeats : Optional Natural }
 
-let MDYPat =
+let MDYPat = < Single : Natural | Multi : List Natural | Repeat : RepeatPat >
-      < Single : Natural
-      | Multi : List Natural
-      | Repeat : RepeatPat
-      | After : Natural
-      | Before : Natural
-      | Between : { _between1 : Natural, _between2 : Natural }
-      >
 
 let ModPat =
       { Type =
@@ -187,9 +180,7 @@ let IncomeBucket = < PreTax | IntraTax | PostTax >
 
 let Amount = { amtValue : Decimal, amtDesc : Text }
 
-let AmountType = < FixedAmt | Percent | Target >
+let TimeAmount = { taWhen : DatePat, taAmt : Amount }
-
-let TimeAmount = { taWhen : DatePat, taAmt : Amount, taAmtType : AmountType }
 
 let Tax = { taxAcnt : AcntID, taxValue : Decimal }
 
@@ -266,5 +257,4 @@ in  { CurID
     , Allocation
     , Amount
     , TimeAmount
-    , AmountType
     }

dhall/common.dhall

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

lib/Internal/Config.hs

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

lib/Internal/Database/Model.hs

@@ -1,6 +1,20 @@
+{-# 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
 
@@ -70,42 +84,13 @@ data DBState = DBState
   , kmStatementInterval :: !Bounds
   , kmNewCommits :: ![Int]
   , kmConfigDir :: !FilePath
+  , kmBoundsCache :: !(MVar (M.Map (Bounds, DatePat) [Day]))
   }
 
-type MappingT m = ReaderT DBState (SqlPersistT m)
+type MappingT m a = ReaderT DBState (SqlPersistT m) a
 
 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,3 +1,11 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+
 module Internal.Database.Ops
   ( migrate_
   , nukeTables
@@ -40,7 +48,6 @@ migrate_ c more =
         (openConnection c)
         ( \backend ->
             flip runSqlConn backend $ do
-              _ <- askLoggerIO
               runMigration migrateAll
               more
         )
@@ -191,8 +198,7 @@ updateCurrencies cs = do
   return $ currencyMap curs
 
 currency2Record :: Currency -> Entity CurrencyR
-currency2Record c@Currency {curSymbol, curFullname} =
+currency2Record c@Currency {..} = Entity (toKey c) $ CurrencyR curSymbol curFullname
-  Entity (toKey c) $ CurrencyR curSymbol curFullname
 
 currencyMap :: [Entity CurrencyR] -> CurrencyMap
 currencyMap = M.fromList . fmap (\e -> (currencyRSymbol $ entityVal e, entityKey e))
@@ -285,7 +291,7 @@ xs !? n
         n
 
 flattenAcntRoot :: AccountRoot -> [(AcntType, AccountTree)]
-flattenAcntRoot AccountRoot_ {arIncome, arExpenses, arLiabilities, arAssets, arEquity} =
+flattenAcntRoot AccountRoot_ {..} =
   ((IncomeT,) <$> arIncome)
     ++ ((ExpenseT,) <$> arExpenses)
     ++ ((LiabilityT,) <$> arLiabilities)
@@ -309,6 +315,7 @@ 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 ->
@@ -319,6 +326,7 @@ getDBState c = do
       , kmStatementInterval = s
       , kmNewCommits = hs
       , kmConfigDir = f
+      , kmBoundsCache = v
       }
   where
     bi = resolveBounds $ budgetInterval $ global c

lib/Internal/Insert.hs

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

lib/Internal/Statement.hs

@@ -1,4 +1,8 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE NoImplicitPrelude #-}
 
 module Internal.Statement
   ( readImport
@@ -20,7 +24,7 @@ import qualified RIO.Vector as V
 
 -- TODO this probably won't scale well (pipes?)
 
-readImport :: MonadFinance m => Import -> m (EitherErrs [BalTx])
+readImport :: MonadUnliftIO m => Import -> MappingT m (EitherErrs [BalTx])
 readImport Import {..} = do
   let ores = plural $ compileOptions impTxOpts
   let cres = concatEithersL $ compileMatch <$> impMatches
@@ -33,14 +37,14 @@ readImport Import {..} = do
     Left es -> return $ Left es
 
 readImport_
-  :: MonadFinance m
+  :: MonadUnliftIO m
   => Natural
   -> Word
   -> TxOptsRe
   -> FilePath
-  -> m (EitherErr [TxRecord])
+  -> MappingT m (EitherErr [TxRecord])
 readImport_ n delim tns p = do
-  dir <- askDBState kmConfigDir
+  dir <- asks 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,5 +1,17 @@
 {-# 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
 
@@ -33,7 +45,6 @@ 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"
@@ -292,10 +303,6 @@ 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,3 +1,8 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+
 module Internal.Utils
   ( compareDate
   , inBounds
@@ -73,14 +78,14 @@ xGregToDay :: XGregorian -> Day
 xGregToDay XGregorian {xgYear = y, xgMonth = m, xgDay = d} = fromGregorian (fromIntegral y) m d
 
 gregTup :: Gregorian -> (Integer, Int, Int)
-gregTup Gregorian {gYear, gMonth, gDay} =
+gregTup Gregorian {..} =
   ( fromIntegral gYear
   , fromIntegral gMonth
   , fromIntegral gDay
   )
 
 gregMTup :: GregorianM -> (Integer, Int)
-gregMTup GregorianM {gmYear, gmMonth} =
+gregMTup GregorianM {..} =
   ( fromIntegral gmYear
   , fromIntegral gmMonth
   )
@@ -140,22 +145,20 @@ expandBounds (d, n) = (d, addDays (fromIntegral n + 1) d)
 -- matching
 
 matches :: MatchRe -> TxRecord -> EitherErrs (MatchRes RawTx)
-matches
+matches Match {..} r@TxRecord {..} = do
-  Match {mTx, mOther, mVal, mDate, mDesc}
+  res <- concatEither3 val other desc $ \x y z -> x && y && z
-  r@TxRecord {trDate, trAmount, trDesc, trOther} = do
+  if date && res
-    res <- concatEither3 val other desc $ \x y z -> x && y && z
+    then maybe (Right MatchSkip) (fmap MatchPass . convert) mTx
-    if date && res
+    else Right MatchFail
-      then maybe (Right MatchSkip) (fmap MatchPass . convert) mTx
+  where
-      else Right MatchFail
+    val = valMatches mVal trAmount
-    where
+    date = maybe True (`dateMatches` trDate) mDate
-      val = valMatches mVal trAmount
+    other = foldM (\a o -> (a &&) <$> otherMatches trOther o) True mOther
-      date = maybe True (`dateMatches` trDate) mDate
+    desc = maybe (return True) (matchMaybe trDesc . snd) mDesc
-      other = foldM (\a o -> (a &&) <$> otherMatches trOther o) True mOther
+    convert (ToTx cur a ss) = toTx cur a ss r
-      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 {trAmount, trDate, trDesc} =
+toTx sc sa toSplits r@TxRecord {..} =
   concatEithers2 acRes ssRes $ \(a_, c_) ss_ ->
     let fromSplit =
           Split
@@ -175,7 +178,7 @@ toTx sc sa toSplits r@TxRecord {trAmount, trDate, trDesc} =
     ssRes = concatEithersL $ fmap (resolveSplit r) toSplits
 
 valMatches :: MatchVal -> Rational -> EitherErr Bool
-valMatches MatchVal {mvDen, mvSign, mvNum, mvPrec} x
+valMatches MatchVal {..} x
   | Just d_ <- mvDen, d_ >= p = Left $ MatchValPrecisionError d_ p
   | otherwise =
       Right $
@@ -248,9 +251,8 @@ 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 d
+      Just d -> return $ fromInteger d
       _ -> msg $ T.unwords ["could not parse", what, t]
-    msg :: MonadFail m => T.Text -> m a
     msg m =
       fail $
         T.unpack $
@@ -294,7 +296,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 {sign, whole, decimal, precision} =
+dec2Rat D {..} =
   k * (fromIntegral whole + (fromIntegral decimal % (10 ^ precision)))
   where
     k = if sign then 1 else -1
@@ -362,7 +364,7 @@ showError other = (: []) $ case other of
       splits = T.intercalate ", " $ fmap (singleQuote . showSplit) rss
 
 showGregorian_ :: Gregorian -> T.Text
-showGregorian_ Gregorian {gYear, gMonth, gDay} = T.intercalate "-" $ showT <$> [gYear, gMonth, gDay]
+showGregorian_ Gregorian {..} = T.intercalate "-" $ showT <$> [gYear, gMonth, gDay]
 
 showTx :: TxRecord -> T.Text
 showTx TxRecord {trDate = d, trAmount = v, trDesc = e, trFile = f} =
@@ -426,8 +428,7 @@ showYMD_ md =
 
 showMatchVal :: MatchVal -> Maybe T.Text
 showMatchVal MatchVal {mvSign = Nothing, mvNum = Nothing, mvDen = Nothing} = Nothing
-showMatchVal MatchVal {mvNum, mvDen, mvSign, mvPrec} =
+showMatchVal MatchVal {..} = Just $ singleQuote $ keyVals [(k, v) | (k, Just v) <- kvs]
-  Just $ singleQuote $ keyVals [(k, v) | (k, Just v) <- kvs]
   where
     kvs =
       [ ("sign", (\s -> if s then "+" else "-") <$> mvSign)

package.yaml

@@ -10,59 +10,15 @@ 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
@@ -85,16 +41,34 @@ 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