ENH remove buckets entirely

budget.cabal

@@ -26,7 +26,6 @@ source-repository head
 library
   exposed-modules:
       Internal.Config
-      Internal.Database.Model
       Internal.Database.Ops
       Internal.Insert
       Internal.Statement

dhall/Types.dhall

@@ -181,10 +181,6 @@ let Import =
 
 let Statement = < StmtManual : Manual | StmtImport : Import >
 
-let ExpenseBucket = < Fixed | Investment | Savings | Guiltless >
-
-let IncomeBucket = < PreTax | IntraTax | PostTax >
-
 let Amount = { amtValue : Decimal, amtDesc : Text }
 
 let AmountType = < FixedAmt | Percent | Target >
@@ -193,23 +189,13 @@ let TimeAmount = { taWhen : DatePat, taAmt : Amount, taAmtType : AmountType }
 
 let Tax = { taxAcnt : AcntID, taxValue : Decimal }
 
-let TransferTarget =
-      < ExpenseTarget :
-          { _1xtarget :
-              {- this is the only place expense accounts may be specified -}
-              AcntID
-          , _2xtarget : ExpenseBucket
-          }
-      | GenericTarget : AcntID
-      >
-
 let Exchange =
       { xFromCur : CurID, xToCur : CurID, xAcnt : AcntID, xRate : Decimal }
 
 let BudgetCurrency = < NoX : CurID | X : Exchange >
 
 let Allocation =
-      { alloPath : TransferTarget
+      { alloPath : AcntID
       , alloAmts : List Amount
       , alloCurrency : BudgetCurrency
       }
@@ -225,12 +211,12 @@ let Income =
       , incPretax : List Allocation
       , incTaxes : List Tax
       , incPosttax : List Allocation
-      , incToBal : TransferTarget
+      , incToBal : AcntID
       }
 
 let Transfer =
       { transFrom : AcntID
-      , transTo : TransferTarget
+      , transTo : AcntID
       , transAmounts : List TimeAmount
       , transCurrency : BudgetCurrency
       }
@@ -308,15 +294,12 @@ in  { CurID
     , Statement
     , Transfer
     , Income
-    , IncomeBucket
-    , ExpenseBucket
     , Budget
     , Tax
     , Allocation
     , Amount
     , TimeAmount
     , AmountType
-    , TransferTarget
     , ShadowMatch
     , ShadowTransfer
     , AcntSet

lib/Internal/Database/Model.hs

@@ -1,111 +0,0 @@
-{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE UndecidableInstances #-}
-
-module Internal.Database.Model where
-
-import Database.Esqueleto.Experimental
-import Database.Persist.TH
-import Internal.Types
-import RIO
-import qualified RIO.Map as M
-import qualified RIO.Text as T
-import RIO.Time
-
-share
-  [mkPersist sqlSettings, mkMigrate "migrateAll"]
-  [persistLowerCase|
-CommitR sql=commits
-    hash Int
-    type ConfigType
-    deriving Show Eq
-CurrencyR sql=currencies
-    symbol T.Text
-    fullname T.Text
-    deriving Show Eq
-AccountR sql=accounts
-    name T.Text
-    fullpath T.Text
-    desc T.Text
-    deriving Show Eq
-AccountPathR sql=account_paths
-    parent AccountRId OnDeleteCascade
-    child AccountRId OnDeleteCascade
-    depth Int
-    deriving Show Eq
-TransactionR sql=transactions
-    commit CommitRId OnDeleteCascade
-    date Day
-    description T.Text
-    deriving Show Eq
-SplitR sql=splits
-    transaction TransactionRId OnDeleteCascade
-    currency CurrencyRId OnDeleteCascade
-    account AccountRId OnDeleteCascade
-    memo T.Text
-    value Rational
-    deriving Show Eq
-BudgetLabelR sql=budget_labels
-    split SplitRId OnDeleteCascade
-    budgetName T.Text
-    deriving Show Eq
-ExpenseBucketR sql=expense_buckets
-    budgetLabel BudgetLabelRId OnDeleteCascade
-    bucket ExpenseBucket
-    deriving Show Eq
-IncomeBucketR sql=income_buckets
-    budgetLabel BudgetLabelRId OnDeleteCascade
-    bucket IncomeBucket
-    deriving Show Eq
-|]
-
-type AccountMap = M.Map AcntID (AccountRId, AcntSign, AcntType)
-
-type CurrencyMap = M.Map CurID CurrencyRId
-
-data DBState = DBState
-  { kmCurrency :: !CurrencyMap
-  , kmAccount :: !AccountMap
-  , kmBudgetInterval :: !Bounds
-  , kmStatementInterval :: !Bounds
-  , kmNewCommits :: ![Int]
-  , kmConfigDir :: !FilePath
-  }
-
-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,7 +1,6 @@
 module Internal.Database.Ops
   ( migrate_
   , nukeTables
-  -- , showBalances
   , updateHashes
   , getDBState
   , tree2Records
@@ -18,7 +17,6 @@ import Database.Persist.Sql hiding (delete, (==.), (||.))
 import Database.Persist.Sqlite hiding (delete, (==.), (||.))
 import Database.Sqlite hiding (Config)
 import GHC.Err
-import Internal.Database.Model
 import Internal.Types
 import Internal.Utils
 import RIO hiding (LogFunc, isNothing, on, (^.))

lib/Internal/Insert.hs

@@ -8,7 +8,6 @@ import Data.Hashable
 import Database.Persist.Class
 import Database.Persist.Sql hiding (Single, Statement)
 import GHC.Utils.Misc hiding (split)
-import Internal.Database.Model
 import Internal.Statement
 import Internal.Types hiding (sign)
 import Internal.Utils
@@ -151,9 +150,8 @@ fromShadow tx t@ShadowTransfer {stFrom, stTo, stDesc, stRatio} = do
                 BudgetTx
                   { btMeta = btMeta $ bttTx tx
                   , btWhen = btWhen $ bttTx tx
-                  , -- TODO what are these supposed to do?
+                  , btFrom = stFrom
-                    btFrom = BudgetSplit stFrom Nothing
+                  , btTo = stTo
-                  , btTo = BudgetSplit stTo Nothing
                   , btValue = dec2Rat stRatio * (btValue $ bttTx tx)
                   , btDesc = stDesc
                   }
@@ -165,8 +163,8 @@ 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 (btFrom tx_) smFrom
-      && memberMaybe (bsAcnt $ btTo tx_) smTo
+      && memberMaybe (btTo tx_) smTo
       && maybe True (`dateMatches` (btWhen tx_)) smDate
       && valRes
   where
@@ -181,13 +179,13 @@ balanceTransfers ts = snd $ L.mapAccumR go initBals $ L.sortOn (btWhen . bttTx)
       M.fromList $
         fmap (,0) $
           L.nub $
-            (fmap (bsAcnt . btTo . bttTx) ts ++ fmap (bsAcnt . btTo . bttTx) ts)
+            (fmap (btTo . bttTx) ts ++ fmap (btTo . bttTx) ts)
     updateBal x = M.update (Just . (+ x))
     lookupBal = M.findWithDefault (error "this should not happen")
     go bals btt =
       let tx = bttTx btt
-          from = bsAcnt $ btFrom tx
+          from = btFrom tx
-          to = bsAcnt $ btTo tx
+          to = btTo tx
           bal = lookupBal to bals
           x = amtToMove bal (bttType btt) (btValue tx)
        in (updateBal x to $ updateBal (-x) from bals, tx {btValue = x})
@@ -198,12 +196,6 @@ balanceTransfers ts = snd $ L.mapAccumR go initBals $ L.sortOn (btWhen . bttTx)
     amtToMove bal Percent x = -(x / 100 * bal)
     amtToMove bal Target x = x - bal
 
--- TODO allow currency conversions here
-data BudgetSplit b = BudgetSplit
-  { bsAcnt :: !AcntID
-  , bsBucket :: !(Maybe b)
-  }
-
 data BudgetMeta = BudgetMeta
   { bmCommit :: !(Key CommitR)
   , bmCur :: !BudgetCurrency
@@ -213,8 +205,8 @@ data BudgetMeta = BudgetMeta
 data BudgetTx = BudgetTx
   { btMeta :: !BudgetMeta
   , btWhen :: !Day
-  , btFrom :: !(BudgetSplit IncomeBucket)
+  , btFrom :: !AcntID
-  , btTo :: !(BudgetSplit ExpenseBucket)
+  , btTo :: !AcntID
   , btValue :: !Rational
   , btDesc :: !T.Text
   }
@@ -231,55 +223,52 @@ insertIncome
     whenHash CTIncome i (Right []) $ \c -> do
       let meta = BudgetMeta c (NoX incCurrency) name
       let balRes = balanceIncome i
-      fromRes <- lift $ checkAcntType IncomeT incFrom (\j -> BudgetSplit j . Just)
+      fromRes <- lift $ checkAcntType IncomeT incFrom
-      toRes <- lift $ expandTarget incToBal
+      case concatEither2 balRes fromRes (,) of
-      case concatEither3 balRes fromRes toRes (,,) of
         Left es -> return $ Left es
-        Right (balance, fromFun, to) ->
+        Right (balance, from) ->
           fmap (fmap (concat . concat)) $
             withDates incWhen $ \day -> do
-              let fromAllos b =
+              let fromAllos = fmap concat . mapM (lift . fromAllo day meta from)
-                    fmap (fmap concat . concatEitherL)
+              pre <- fromAllos incPretax
-                      . mapM (lift . fromAllo day meta (fromFun b))
-              pre <- fromAllos PreTax incPretax
               tax <-
                 concatEitherL
-                  <$> mapM (lift . fromTax day meta (fromFun IntraTax)) incTaxes
+                  <$> mapM (lift . fromTax day meta from) incTaxes
-              post <- fromAllos PostTax incPosttax
+              post <- fromAllos incPosttax
               let bal =
                     BudgetTxType
                       { bttTx =
                           BudgetTx
                             { btMeta = meta
                             , btWhen = day
-                            , btFrom = fromFun PostTax
+                            , btFrom = from
-                            , btTo = to
+                            , btTo = incToBal
                             , btValue = balance
                             , btDesc = "balance after deductions"
                             }
                       , bttType = FixedAmt
                       }
-              return $ concatEithersL [Right [bal], tax, pre, post]
+              return $ concatEithersL [Right [bal], tax, Right pre, Right post]
 
 fromAllo
   :: MonadFinance m
   => Day
   -> BudgetMeta
-  -> BudgetSplit IncomeBucket
+  -> AcntID
   -> Allocation
-  -> m (EitherErr [BudgetTxType])
+  -> m [BudgetTxType]
 fromAllo day meta from Allocation {alloPath, alloAmts} = do
   -- TODO this is going to be repeated a zillion times (might matter)
-  res <- expandTarget alloPath
+  -- res <- expandTarget alloPath
-  return $ (\to -> fmap (toBT to) alloAmts) <$> res
+  return $ fmap toBT alloAmts
   where
-    toBT to (Amount desc v) =
+    toBT (Amount desc v) =
       BudgetTxType
         { bttTx =
             BudgetTx
               { btFrom = from
               , btWhen = day
-              , btTo = to
+              , btTo = alloPath
               , btValue = dec2Rat v
               , btDesc = desc
               , btMeta = meta
@@ -291,18 +280,20 @@ fromTax
   :: MonadFinance m
   => Day
   -> BudgetMeta
-  -> BudgetSplit IncomeBucket
+  -> AcntID
   -> Tax
   -> m (EitherErr BudgetTxType)
-fromTax day meta from Tax {taxAcnt = to, taxValue = v} =
+fromTax day meta from Tax {taxAcnt = to, taxValue = v} = do
-  -- TODO this is going to be repeated a zillion times (might matter)
+  res <- checkAcntType ExpenseT to
-  checkAcntType ExpenseT to $ \to_ ->
+  return $ fmap go res
+  where
+    go to_ =
       BudgetTxType
         { bttTx =
             BudgetTx
               { btFrom = from
               , btWhen = day
-            , btTo = BudgetSplit to_ (Just Fixed)
+              , btTo = to_
               , btValue = dec2Rat v
               , btDesc = ""
               , btMeta = meta
@@ -344,11 +335,7 @@ expandTransfer name t@Transfer {transAmounts, transTo, transCurrency, transFrom}
   whenHash CTExpense t (Right []) $ \key ->
     fmap (fmap concat . concatEithersL) $
       forM transAmounts $ \(TimeAmount (Amount desc v) atype pat) -> do
-        -- TODO this is going to be repeated a zillion times (might matter)
+        withDates pat $ \day ->
-        res <- lift $ expandTarget transTo
-        case res of
-          Left e -> return $ Left [e]
-          Right to -> withDates pat $ \day ->
           let meta =
                 BudgetMeta
                   { bmCur = transCurrency
@@ -361,8 +348,8 @@ expandTransfer name t@Transfer {transAmounts, transTo, transCurrency, transFrom}
                       BudgetTx
                         { btMeta = meta
                         , btWhen = day
-                          , btFrom = BudgetSplit transFrom Nothing
+                        , btFrom = transFrom
-                          , btTo = to
+                        , btTo = transTo
                         , btValue = dec2Rat v
                         , btDesc = desc
                         }
@@ -372,29 +359,18 @@ expandTransfer name t@Transfer {transAmounts, transTo, transCurrency, transFrom}
 
 insertBudgetTx :: MonadFinance m => BudgetTx -> SqlPersistT m [InsertError]
 insertBudgetTx BudgetTx {btFrom, btTo, btMeta, btValue, btDesc, btWhen} = do
-  res <- lift $ splitPair (bsAcnt btFrom) (bsAcnt btTo) (bmCur btMeta) btValue
+  res <- lift $ splitPair btFrom btTo (bmCur btMeta) btValue
   unlessLefts_ res $ \((sFrom, sTo), exchange) -> do
     insertPair sFrom sTo
     forM_ exchange $ \(xFrom, xTo) -> insertPair xFrom xTo
   where
     insertPair from to = do
       k <- insert $ TransactionR (bmCommit btMeta) btWhen btDesc
-      insertBudgetLabel name k IncomeBucketR from btFrom
+      insertBudgetLabel k from
-      insertBudgetLabel name k ExpenseBucketR to btTo
+      insertBudgetLabel k to
-    name = bmName btMeta
+    insertBudgetLabel k split = do
-
-insertBudgetLabel
-  :: (MonadUnliftIO m, PersistRecordBackend record SqlBackend)
-  => T.Text
-  -> Key TransactionR
-  -> (Key BudgetLabelR -> a -> record)
-  -> KeySplit
-  -> BudgetSplit a
-  -> SqlPersistT m ()
-insertBudgetLabel name k bucketType split bs = do
       sk <- insertSplit k split
-  bk <- insert $ BudgetLabelR sk name
+      insert_ $ BudgetLabelR sk $ bmName btMeta
-  forM_ (bsBucket bs) $ insert_ . bucketType bk
 
 type SplitPair = (KeySplit, KeySplit)
 
@@ -425,34 +401,22 @@ splitPair from to cur val = case cur of
           , sCurrency = c
           }
 
-expandTarget
-  :: MonadFinance m
-  => TransferTarget
-  -> m (EitherErr (BudgetSplit ExpenseBucket))
-expandTarget t = case t of
-  ExpenseTarget i b -> checkAcntType ExpenseT i $ (`BudgetSplit` (Just b))
-  GenericTarget i ->
-    checkAcntTypes (LiabilityT :| [AssetT, EquityT]) i $
-      (`BudgetSplit` Nothing)
-
 checkAcntType
   :: MonadFinance m
   => AcntType
   -> AcntID
-  -> (AcntID -> a)
+  -> m (EitherErr AcntID)
-  -> m (EitherErr a)
 checkAcntType t = checkAcntTypes (t :| [])
 
 checkAcntTypes
   :: MonadFinance m
   => NE.NonEmpty AcntType
   -> AcntID
-  -> (AcntID -> a)
+  -> m (EitherErr AcntID)
-  -> m (EitherErr a)
+checkAcntTypes ts i = (go =<<) <$> lookupAccountType i
-checkAcntTypes ts i f = (go =<<) <$> lookupAccountType i
   where
     go t
-      | t `L.elem` ts = Right $ f i
+      | t `L.elem` ts = Right i
       | otherwise = Left $ AccountError i ts
 
 --------------------------------------------------------------------------------

lib/Internal/Statement.hs

@@ -6,7 +6,6 @@ module Internal.Statement
 where
 
 import Data.Csv
-import Internal.Database.Model
 import Internal.Types
 import Internal.Utils
 import RIO

lib/Internal/Types.hs

@@ -1,5 +1,7 @@
 {-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE UndecidableInstances #-}
 
 module Internal.Types where
 
@@ -7,6 +9,7 @@ import Data.Fix (Fix (..), foldFix)
 import Data.Functor.Foldable (embed)
 import qualified Data.Functor.Foldable.TH as TH
 import Database.Persist.Sql hiding (Desc, In, Statement)
+import Database.Persist.TH
 import Dhall hiding (embed, maybe)
 import Dhall.TH
 import Language.Haskell.TH.Syntax (Lift)
@@ -32,10 +35,7 @@ makeHaskellTypesWith
   , MultipleConstructors "MatchYMD" "(./dhall/Types.dhall).MatchYMD"
   , MultipleConstructors "MatchDate" "(./dhall/Types.dhall).MatchDate"
   , MultipleConstructors "SplitNum" "(./dhall/Types.dhall).SplitNum"
-  , MultipleConstructors "ExpenseBucket" "(./dhall/Types.dhall).ExpenseBucket"
-  , MultipleConstructors "IncomeBucket" "(./dhall/Types.dhall).IncomeBucket"
   , MultipleConstructors "AmountType" "(./dhall/Types.dhall).AmountType"
-  , MultipleConstructors "TransferTarget" "(./dhall/Types.dhall).TransferTarget"
   , MultipleConstructors "BudgetCurrency" "(./dhall/Types.dhall).BudgetCurrency"
   , SingleConstructor "Currency" "Currency" "(./dhall/Types.dhall).Currency"
   , SingleConstructor "Gregorian" "Gregorian" "(./dhall/Types.dhall).Gregorian"
@@ -62,36 +62,7 @@ makeHaskellTypesWith
   ]
 
 -------------------------------------------------------------------------------
--- account tree
+-- lots of instances for dhall types
-
-data AccountTree
-  = Placeholder T.Text T.Text [AccountTree]
-  | Account T.Text T.Text
-  deriving (Eq, Generic, Hashable)
-
-TH.makeBaseFunctor ''AccountTree
-
-deriving instance Generic (AccountTreeF a)
-
-deriving instance FromDhall a => FromDhall (AccountTreeF a)
-
-data AccountRoot_ a = AccountRoot_
-  { arAssets :: ![a]
-  , arEquity :: ![a]
-  , arExpenses :: ![a]
-  , arIncome :: ![a]
-  , arLiabilities :: ![a]
-  }
-  deriving (Generic)
-
-type AccountRootF = AccountRoot_ (Fix AccountTreeF)
-
-deriving instance FromDhall AccountRootF
-
-type AccountRoot = AccountRoot_ AccountTree
-
--------------------------------------------------------------------------------
--- curencies
 
 deriving instance Eq Currency
 
@@ -99,49 +70,6 @@ deriving instance Lift Currency
 
 deriving instance Hashable Currency
 
-type CurID = T.Text
-
--------------------------------------------------------------------------------
--- DHALL CONFIG
--------------------------------------------------------------------------------
-
-data Config_ a = Config_
-  { global :: !Global
-  , budget :: ![Budget]
-  , currencies :: ![Currency]
-  , statements :: ![Statement]
-  , accounts :: !a
-  , sqlConfig :: !SqlConfig
-  }
-  deriving (Generic)
-
-type ConfigF = Config_ AccountRootF
-
-type Config = Config_ AccountRoot
-
-unfix :: ConfigF -> Config
-unfix c@Config_ {accounts = a} = c {accounts = a'}
-  where
-    a' =
-      AccountRoot_
-        { arAssets = unfixTree arAssets
-        , arEquity = unfixTree arEquity
-        , arExpenses = unfixTree arExpenses
-        , arIncome = unfixTree arIncome
-        , arLiabilities = unfixTree arLiabilities
-        }
-    unfixTree f = foldFix embed <$> f a
-
-instance FromDhall a => FromDhall (Config_ a)
-
--------------------------------------------------------------------------------
--- accounts
-
-type AcntID = T.Text
-
---------------------------------------------------------------------------------
--- Time Patterns (for assigning when budget events will happen)
-
 deriving instance Eq TimeUnit
 
 deriving instance Ord TimeUnit
@@ -234,9 +162,6 @@ deriving instance Show DatePat
 
 deriving instance Hashable DatePat
 
---------------------------------------------------------------------------------
--- Budget (projecting into the future)
-
 deriving instance Eq Budget
 
 deriving instance Hashable Budget
@@ -265,14 +190,6 @@ deriving instance Eq Allocation
 
 deriving instance Hashable Allocation
 
-deriving instance Eq IncomeBucket
-
-deriving instance Hashable IncomeBucket
-
-deriving instance Show IncomeBucket
-
-deriving instance Read IncomeBucket
-
 toPersistText :: Show a => a -> PersistValue
 toPersistText = PersistText . T.pack . show
 
@@ -283,30 +200,6 @@ fromPersistText what (PersistText t) = case readMaybe $ T.unpack t of
 fromPersistText what x =
   Left $ T.unwords ["error when deserializing", what, "; got", T.pack (show x)]
 
-instance PersistField IncomeBucket where
-  toPersistValue = toPersistText
-
-  fromPersistValue = fromPersistText "IncomeBucket"
-
-instance PersistFieldSql IncomeBucket where
-  sqlType _ = SqlString
-
-deriving instance Eq ExpenseBucket
-
-deriving instance Hashable ExpenseBucket
-
-deriving instance Show ExpenseBucket
-
-deriving instance Read ExpenseBucket
-
-instance PersistField ExpenseBucket where
-  toPersistValue = toPersistText
-
-  fromPersistValue = fromPersistText "ExpenseBucket"
-
-instance PersistFieldSql ExpenseBucket where
-  sqlType _ = SqlString
-
 deriving instance Eq AmountType
 
 deriving instance Hashable AmountType
@@ -315,10 +208,6 @@ deriving instance Eq TimeAmount
 
 deriving instance Hashable TimeAmount
 
-deriving instance Eq TransferTarget
-
-deriving instance Hashable TransferTarget
-
 deriving instance Eq Transfer
 
 deriving instance Hashable Transfer
@@ -335,18 +224,133 @@ deriving instance Eq ShadowMatch
 
 deriving instance Hashable ShadowMatch
 
+deriving instance Eq MatchVal
+
+deriving instance Hashable MatchVal
+
+deriving instance Show MatchVal
+
+deriving instance Eq MatchYMD
+
+deriving instance Hashable MatchYMD
+
+deriving instance Show MatchYMD
+
+deriving instance Eq MatchDate
+
+deriving instance Hashable MatchDate
+
+deriving instance Show MatchDate
+
+deriving instance Eq Decimal
+
+deriving instance Hashable Decimal
+
+deriving instance Show Decimal
+
+-- TODO this just looks silly...but not sure how to simplify it
+instance Ord MatchYMD where
+  compare (Y y) (Y y') = compare y y'
+  compare (YM g) (YM g') = compare g g'
+  compare (YMD g) (YMD g') = compare g g'
+  compare (Y y) (YM g) = compare y (gmYear g) <> LT
+  compare (Y y) (YMD g) = compare y (gYear g) <> LT
+  compare (YM g) (Y y') = compare (gmYear g) y' <> GT
+  compare (YMD g) (Y y') = compare (gYear g) y' <> GT
+  compare (YM g) (YMD g') = compare g (gregM g') <> LT
+  compare (YMD g) (YM g') = compare (gregM g) g' <> GT
+
+gregM :: Gregorian -> GregorianM
+gregM Gregorian {gYear = y, gMonth = m} =
+  GregorianM {gmYear = y, gmMonth = m}
+
+instance Ord MatchDate where
+  compare (On d) (On d') = compare d d'
+  compare (In d r) (In d' r') = compare d d' <> compare r r'
+  compare (On d) (In d' _) = compare d d' <> LT
+  compare (In d _) (On d') = compare d d' <> GT
+
+deriving instance Eq SplitNum
+
+deriving instance Hashable SplitNum
+
+deriving instance Show SplitNum
+
+deriving instance Eq Manual
+
+deriving instance Hashable Manual
+
+-------------------------------------------------------------------------------
+-- top level type with fixed account tree to unroll the recursion in the dhall
+-- account tree type
+
+data AccountTree
+  = Placeholder T.Text T.Text [AccountTree]
+  | Account T.Text T.Text
+  deriving (Eq, Generic, Hashable)
+
+TH.makeBaseFunctor ''AccountTree
+
+deriving instance Generic (AccountTreeF a)
+
+deriving instance FromDhall a => FromDhall (AccountTreeF a)
+
+data AccountRoot_ a = AccountRoot_
+  { arAssets :: ![a]
+  , arEquity :: ![a]
+  , arExpenses :: ![a]
+  , arIncome :: ![a]
+  , arLiabilities :: ![a]
+  }
+  deriving (Generic)
+
+type AccountRootF = AccountRoot_ (Fix AccountTreeF)
+
+deriving instance FromDhall AccountRootF
+
+type AccountRoot = AccountRoot_ AccountTree
+
+data Config_ a = Config_
+  { global :: !Global
+  , budget :: ![Budget]
+  , currencies :: ![Currency]
+  , statements :: ![Statement]
+  , accounts :: !a
+  , sqlConfig :: !SqlConfig
+  }
+  deriving (Generic)
+
+type ConfigF = Config_ AccountRootF
+
+type Config = Config_ AccountRoot
+
+unfix :: ConfigF -> Config
+unfix c@Config_ {accounts = a} = c {accounts = a'}
+  where
+    a' =
+      AccountRoot_
+        { arAssets = unfixTree arAssets
+        , arEquity = unfixTree arEquity
+        , arExpenses = unfixTree arExpenses
+        , arIncome = unfixTree arIncome
+        , arLiabilities = unfixTree arLiabilities
+        }
+    unfixTree f = foldFix embed <$> f a
+
+instance FromDhall a => FromDhall (Config_ a)
+
 --------------------------------------------------------------------------------
--- Statements (data from the past)
+-- dhall type overrides (since dhall can't import types with parameters...yet)
+
+type AcntID = T.Text
+
+type CurID = T.Text
 
 data Statement
   = StmtManual !Manual
   | StmtImport !Import
   deriving (Eq, Hashable, Generic, FromDhall)
 
-deriving instance Eq Manual
-
-deriving instance Hashable Manual
-
 data Split a v c = Split
   { sAcnt :: !a
   , sValue :: !v
@@ -388,52 +392,6 @@ data Import = Import
   }
   deriving (Eq, Hashable, Generic, FromDhall)
 
-deriving instance Eq MatchVal
-
-deriving instance Hashable MatchVal
-
-deriving instance Show MatchVal
-
-deriving instance Eq MatchYMD
-
-deriving instance Hashable MatchYMD
-
-deriving instance Show MatchYMD
-
-deriving instance Eq MatchDate
-
-deriving instance Hashable MatchDate
-
-deriving instance Show MatchDate
-
--- TODO this just looks silly...but not sure how to simplify it
-instance Ord MatchYMD where
-  compare (Y y) (Y y') = compare y y'
-  compare (YM g) (YM g') = compare g g'
-  compare (YMD g) (YMD g') = compare g g'
-  compare (Y y) (YM g) = compare y (gmYear g) <> LT
-  compare (Y y) (YMD g) = compare y (gYear g) <> LT
-  compare (YM g) (Y y') = compare (gmYear g) y' <> GT
-  compare (YMD g) (Y y') = compare (gYear g) y' <> GT
-  compare (YM g) (YMD g') = compare g (gregM g') <> LT
-  compare (YMD g) (YM g') = compare (gregM g) g' <> GT
-
-gregM :: Gregorian -> GregorianM
-gregM Gregorian {gYear = y, gMonth = m} =
-  GregorianM {gmYear = y, gmMonth = m}
-
-instance Ord MatchDate where
-  compare (On d) (On d') = compare d d'
-  compare (In d r) (In d' r') = compare d d' <> compare r r'
-  compare (On d) (In d' _) = compare d d' <> LT
-  compare (In d _) (On d') = compare d d' <> GT
-
-deriving instance Eq SplitNum
-
-deriving instance Hashable SplitNum
-
-deriving instance Show SplitNum
-
 -- | the value of a field in split (text version)
 -- can either be a raw (constant) value, a lookup from the record, or a map
 -- between the lookup and some other value
@@ -487,13 +445,47 @@ data Match re = Match
 deriving instance Show (Match T.Text)
 
 --------------------------------------------------------------------------------
--- Specialized dhall types
+-- DATABASE MODEL
+--------------------------------------------------------------------------------
 
-deriving instance Eq Decimal
+share
-
+  [mkPersist sqlSettings, mkMigrate "migrateAll"]
-deriving instance Hashable Decimal
+  [persistLowerCase|
-
+CommitR sql=commits
-deriving instance Show Decimal
+    hash Int
+    type ConfigType
+    deriving Show Eq
+CurrencyR sql=currencies
+    symbol T.Text
+    fullname T.Text
+    deriving Show Eq
+AccountR sql=accounts
+    name T.Text
+    fullpath T.Text
+    desc T.Text
+    deriving Show Eq
+AccountPathR sql=account_paths
+    parent AccountRId OnDeleteCascade
+    child AccountRId OnDeleteCascade
+    depth Int
+    deriving Show Eq
+TransactionR sql=transactions
+    commit CommitRId OnDeleteCascade
+    date Day
+    description T.Text
+    deriving Show Eq
+SplitR sql=splits
+    transaction TransactionRId OnDeleteCascade
+    currency CurrencyRId OnDeleteCascade
+    account AccountRId OnDeleteCascade
+    memo T.Text
+    value Rational
+    deriving Show Eq
+BudgetLabelR sql=budget_labels
+    split SplitRId OnDeleteCascade
+    budgetName T.Text
+    deriving Show Eq
+|]
 
 --------------------------------------------------------------------------------
 -- database cache types
@@ -519,6 +511,57 @@ instance PersistField ConfigType where
     maybe (Left $ "could not parse: " <> v) Right $ readMaybe $ T.unpack v
   fromPersistValue _ = Left "wrong type"
 
+type AccountMap = M.Map AcntID (AccountRId, AcntSign, AcntType)
+
+type CurrencyMap = M.Map CurID CurrencyRId
+
+data DBState = DBState
+  { kmCurrency :: !CurrencyMap
+  , kmAccount :: !AccountMap
+  , kmBudgetInterval :: !Bounds
+  , kmStatementInterval :: !Bounds
+  , kmNewCommits :: ![Int]
+  , kmConfigDir :: !FilePath
+  }
+
+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
+
 -------------------------------------------------------------------------------
 -- misc
 
@@ -554,8 +597,6 @@ data TxRecord = TxRecord
 
 type Bounds = (Day, Natural)
 
--- type MaybeBounds = (Maybe Day, Maybe Day)
-
 data Keyed a = Keyed
   { kKey :: !Int64
   , kVal :: !a
@@ -588,6 +629,9 @@ type BalTx = Tx BalSplit
 
 data MatchRes a = MatchPass !a | MatchFail | MatchSkip
 
+--------------------------------------------------------------------------------
+-- exception types
+
 data BalanceType = TooFewSplits | NotOneBlank deriving (Show)
 
 data MatchType = MatchNumeric | MatchText deriving (Show)