budget.cabal

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

dhall/Types.dhall

@@ -6,14 +6,10 @@ let CurID = Text
 
 let AcntID = Text
 
-let TagID = Text
-
 let SqlConfig {- TODO pgsql -} = < Sqlite : Text | Postgres >
 
 let Currency = { curSymbol : CurID, curFullname : Text }
 
-let Tag = { tagID : TagID, tagDesc : Text }
-
 let Gregorian = { gYear : Natural, gMonth : Natural, gDay : Natural }
 
 let GregorianM = { gmYear : Natural, gmMonth : Natural }
@@ -185,6 +181,10 @@ 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,18 +193,25 @@ 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 TaggedAcnt = { taAcnt : AcntID, taTags : List TagID }
-
 let Allocation =
-      { alloTo : TaggedAcnt
+      { alloPath : TransferTarget
-      , alloTags : List TagID
       , alloAmts : List Amount
-      , alloCur : BudgetCurrency
+      , alloCurrency : BudgetCurrency
       }
 
 let Income =
@@ -214,16 +221,16 @@ let Income =
       , incFrom :
           {- this must be an income AcntID, and is the only place income
           accounts may be specified in the entire budget -}
-          TaggedAcnt
+          AcntID
       , incPretax : List Allocation
       , incTaxes : List Tax
       , incPosttax : List Allocation
-      , incToBal : TaggedAcnt
+      , incToBal : TransferTarget
       }
 
 let Transfer =
-      { transFrom : TaggedAcnt
+      { transFrom : AcntID
-      , transTo : TaggedAcnt
+      , transTo : TransferTarget
       , transAmounts : List TimeAmount
       , transCurrency : BudgetCurrency
       }
@@ -249,8 +256,8 @@ let ShadowMatch =
       }
 
 let ShadowTransfer =
-      { stFrom : TaggedAcnt
+      { stFrom : AcntID
-      , stTo : TaggedAcnt
+      , stTo : AcntID
       , stCurrency : CurID
       , stDesc : Text
       , stMatch : ShadowMatch.Type
@@ -268,7 +275,6 @@ in  { CurID
     , AcntID
     , SqlConfig
     , Currency
-    , Tag
     , Interval
     , Global
     , Gregorian
@@ -302,16 +308,18 @@ in  { CurID
     , Statement
     , Transfer
     , Income
+    , IncomeBucket
+    , ExpenseBucket
     , Budget
     , Tax
     , Allocation
     , Amount
     , TimeAmount
     , AmountType
+    , TransferTarget
     , ShadowMatch
     , ShadowTransfer
     , AcntSet
     , BudgetCurrency
     , Exchange
-    , TaggedAcnt
     }

lib/Internal/Database/Model.hs

@@ -0,0 +1,111 @@
+{-# 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,6 +1,7 @@
 module Internal.Database.Ops
   ( migrate_
   , nukeTables
+  -- , showBalances
   , updateHashes
   , getDBState
   , tree2Records
@@ -17,6 +18,7 @@ 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, (^.))
@@ -161,13 +163,6 @@ deleteCurrency e = delete $ do
   where
     k = entityKey e
 
-deleteTag :: MonadUnliftIO m => Entity TagR -> SqlPersistT m ()
-deleteTag e = delete $ do
-  c <- from $ table @TagR
-  where_ (c ^. TagRId ==. val k)
-  where
-    k = entityKey e
-
 updateAccounts :: MonadUnliftIO m => AccountRoot -> SqlPersistT m AccountMap
 updateAccounts ar = do
   let (acnts, paths, acntMap) = indexAcntRoot ar
@@ -180,7 +175,6 @@ updateAccounts ar = do
   mapM_ insert paths
   return acntMap
 
--- TODO slip-n-slide code...
 insertFull
   :: (MonadUnliftIO m, PersistStoreWrite b, PersistRecordBackend r b)
   => Entity r
@@ -203,18 +197,6 @@ currency2Record c@Currency {curSymbol, curFullname} =
 currencyMap :: [Entity CurrencyR] -> CurrencyMap
 currencyMap = M.fromList . fmap (\e -> (currencyRSymbol $ entityVal e, entityKey e))
 
-updateTags :: MonadUnliftIO m => [Tag] -> SqlPersistT m TagMap
-updateTags cs = do
-  let tags = fmap toRecord cs
-  tags' <- select $ from $ table @TagR
-  let (toIns, toDel) = setDiff tags tags'
-  mapM_ deleteTag toDel
-  mapM_ insertFull toIns
-  return $ tagMap tags
-  where
-    toRecord t@(Tag {tagID, tagDesc}) = Entity (toKey t) $ TagR tagID tagDesc
-    tagMap = M.fromList . fmap (\e -> (tagRSymbol $ entityVal e, entityKey e))
-
 toKey :: (ToBackendKey SqlBackend b, Hashable a) => a -> Key b
 toKey = toSqlKey . fromIntegral . hash
 
@@ -326,7 +308,6 @@ getDBState
 getDBState c = do
   am <- updateAccounts $ accounts c
   cm <- updateCurrencies $ currencies c
-  ts <- updateTags $ tags c
   hs <- updateHashes c
   -- TODO not sure how I feel about this, probably will change this struct alot
   -- in the future so whatever...for now
@@ -338,7 +319,6 @@ getDBState c = do
       , kmStatementInterval = s
       , kmNewCommits = hs
       , kmConfigDir = f
-      , kmTag = ts
       }
   where
     bi = resolveBounds $ budgetInterval $ global c

lib/Internal/Insert.hs

@@ -8,6 +8,7 @@ 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
@@ -150,8 +151,9 @@ fromShadow tx t@ShadowTransfer {stFrom, stTo, stDesc, stRatio} = do
                 BudgetTx
                   { btMeta = btMeta $ bttTx tx
                   , btWhen = btWhen $ bttTx tx
-                  , btFrom = stFrom
+                  , -- TODO what are these supposed to do?
-                  , btTo = stTo
+                    btFrom = BudgetSplit stFrom Nothing
+                  , btTo = BudgetSplit stTo Nothing
                   , btValue = dec2Rat stRatio * (btValue $ bttTx tx)
                   , btDesc = stDesc
                   }
@@ -163,8 +165,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 (taAcnt $ btFrom tx_) smFrom
+    memberMaybe (bsAcnt $ btFrom tx_) smFrom
-      && memberMaybe (taAcnt $ btTo tx_) smTo
+      && memberMaybe (bsAcnt $ btTo tx_) smTo
       && maybe True (`dateMatches` (btWhen tx_)) smDate
       && valRes
   where
@@ -179,13 +181,13 @@ balanceTransfers ts = snd $ L.mapAccumR go initBals $ L.sortOn (btWhen . bttTx)
       M.fromList $
         fmap (,0) $
           L.nub $
-            (fmap (btTo . bttTx) ts ++ fmap (btTo . bttTx) ts)
+            (fmap (bsAcnt . btTo . bttTx) ts ++ fmap (bsAcnt . 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 = btFrom tx
+          from = bsAcnt $ btFrom tx
-          to = btTo tx
+          to = bsAcnt $ btTo tx
           bal = lookupBal to bals
           x = amtToMove bal (bttType btt) (btValue tx)
        in (updateBal x to $ updateBal (-x) from bals, tx {btValue = x})
@@ -196,6 +198,12 @@ 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
@@ -205,8 +213,8 @@ data BudgetMeta = BudgetMeta
 data BudgetTx = BudgetTx
   { btMeta :: !BudgetMeta
   , btWhen :: !Day
-  , btFrom :: !TaggedAcnt
+  , btFrom :: !(BudgetSplit IncomeBucket)
-  , btTo :: !TaggedAcnt
+  , btTo :: !(BudgetSplit ExpenseBucket)
   , btValue :: !Rational
   , btDesc :: !T.Text
   }
@@ -223,53 +231,55 @@ insertIncome
     whenHash CTIncome i (Right []) $ \c -> do
       let meta = BudgetMeta c (NoX incCurrency) name
       let balRes = balanceIncome i
-      fromRes <- lift $ checkAcntType IncomeT $ taAcnt incFrom
+      fromRes <- lift $ checkAcntType IncomeT incFrom (\j -> BudgetSplit j . Just)
-      case concatEither2 balRes fromRes (,) of
+      toRes <- lift $ expandTarget incToBal
+      case concatEither3 balRes fromRes toRes (,,) of
         Left es -> return $ Left es
-        -- TODO this hole seems sloppy...
+        Right (balance, fromFun, to) ->
-        Right (balance, _) ->
           fmap (fmap (concat . concat)) $
             withDates incWhen $ \day -> do
-              let fromAllos = fmap concat . mapM (lift . fromAllo day meta incFrom)
+              let fromAllos b =
-              pre <- fromAllos incPretax
+                    fmap (fmap concat . concatEitherL)
+                      . mapM (lift . fromAllo day meta (fromFun b))
+              pre <- fromAllos PreTax incPretax
               tax <-
                 concatEitherL
-                  <$> mapM (lift . fromTax day meta (taAcnt incFrom)) incTaxes
+                  <$> mapM (lift . fromTax day meta (fromFun IntraTax)) incTaxes
-              post <- fromAllos incPosttax
+              post <- fromAllos PostTax incPosttax
               let bal =
                     BudgetTxType
                       { bttTx =
                           BudgetTx
                             { btMeta = meta
                             , btWhen = day
-                            , btFrom = incFrom
+                            , btFrom = fromFun PostTax
-                            , btTo = incToBal
+                            , btTo = to
                             , btValue = balance
                             , btDesc = "balance after deductions"
                             }
                       , bttType = FixedAmt
                       }
-              return $ concatEithersL [Right [bal], tax, Right pre, Right post]
+              return $ concatEithersL [Right [bal], tax, pre, post]
 
 fromAllo
   :: MonadFinance m
   => Day
   -> BudgetMeta
-  -> TaggedAcnt
+  -> BudgetSplit IncomeBucket
   -> Allocation
-  -> m [BudgetTxType]
+  -> m (EitherErr [BudgetTxType])
-fromAllo day meta from Allocation {alloTo, alloAmts} = do
+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 $ fmap toBT alloAmts
+  return $ (\to -> fmap (toBT to) alloAmts) <$> res
   where
-    toBT (Amount desc v) =
+    toBT to (Amount desc v) =
       BudgetTxType
         { bttTx =
             BudgetTx
               { btFrom = from
               , btWhen = day
-              , btTo = alloTo
+              , btTo = to
               , btValue = dec2Rat v
               , btDesc = desc
               , btMeta = meta
@@ -277,25 +287,22 @@ fromAllo day meta from Allocation {alloTo, alloAmts} = do
         , bttType = FixedAmt
         }
 
--- TODO maybe allow tags here?
 fromTax
   :: MonadFinance m
   => Day
   -> BudgetMeta
-  -> AcntID
+  -> BudgetSplit IncomeBucket
   -> Tax
   -> m (EitherErr BudgetTxType)
-fromTax day meta from Tax {taxAcnt = to, taxValue = v} = do
+fromTax day meta from Tax {taxAcnt = to, taxValue = v} =
-  res <- checkAcntType ExpenseT to
+  -- TODO this is going to be repeated a zillion times (might matter)
-  return $ fmap go res
+  checkAcntType ExpenseT to $ \to_ ->
-  where
-    go to_ =
     BudgetTxType
       { bttTx =
           BudgetTx
-              { btFrom = TaggedAcnt from []
+            { btFrom = from
             , btWhen = day
-              , btTo = TaggedAcnt to_ []
+            , btTo = BudgetSplit to_ (Just Fixed)
             , btValue = dec2Rat v
             , btDesc = ""
             , btMeta = meta
@@ -337,7 +344,11 @@ 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
-        withDates pat $ \day ->
+        -- TODO this is going to be repeated a zillion times (might matter)
+        res <- lift $ expandTarget transTo
+        case res of
+          Left e -> return $ Left [e]
+          Right to -> withDates pat $ \day ->
             let meta =
                   BudgetMeta
                     { bmCur = transCurrency
@@ -350,8 +361,8 @@ expandTransfer name t@Transfer {transAmounts, transTo, transCurrency, transFrom}
                         BudgetTx
                           { btMeta = meta
                           , btWhen = day
-                        , btFrom = transFrom
+                          , btFrom = BudgetSplit transFrom Nothing
-                        , btTo = transTo
+                          , btTo = to
                           , btValue = dec2Rat v
                           , btDesc = desc
                           }
@@ -361,66 +372,87 @@ 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 btFrom btTo (bmCur btMeta) btValue
+  res <- lift $ splitPair (bsAcnt btFrom) (bsAcnt 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 k from
+      insertBudgetLabel name k IncomeBucketR from btFrom
-      insertBudgetLabel k to
+      insertBudgetLabel name k ExpenseBucketR to btTo
-    insertBudgetLabel k split = do
+    name = bmName btMeta
+
+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
-      insert_ $ BudgetLabelR sk $ bmName btMeta
+  bk <- insert $ BudgetLabelR sk name
+  forM_ (bsBucket bs) $ insert_ . bucketType bk
 
 type SplitPair = (KeySplit, KeySplit)
 
 splitPair
   :: MonadFinance m
-  => TaggedAcnt
+  => AcntID
-  -> TaggedAcnt
+  -> AcntID
   -> BudgetCurrency
   -> Rational
   -> m (EitherErrs (SplitPair, Maybe SplitPair))
 splitPair from to cur val = case cur of
   NoX curid -> fmap (fmap (,Nothing)) $ pair curid from to val
   X (Exchange {xFromCur, xToCur, xAcnt, xRate}) -> do
-    let middle = TaggedAcnt xAcnt []
+    res1 <- pair xFromCur from xAcnt val
-    res1 <- pair xFromCur from middle val
+    res2 <- pair xToCur xAcnt to (val * dec2Rat xRate)
-    res2 <- pair xToCur middle to (val * dec2Rat xRate)
     return $ concatEithers2 res1 res2 $ \a b -> (a, Just b)
   where
     pair curid from_ to_ v = do
       s1 <- split curid from_ (-v)
       s2 <- split curid to_ v
       return $ concatEithers2 s1 s2 (,)
-    split c TaggedAcnt {taAcnt, taTags} v =
+    split c a v =
       resolveSplit $
         Split
-          { sAcnt = taAcnt
+          { sAcnt = a
           , sValue = v
           , sComment = ""
           , sCurrency = c
-          , sTags = taTags
           }
 
+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
-  -> m (EitherErr AcntID)
+  -> (AcntID -> a)
+  -> m (EitherErr a)
 checkAcntType t = checkAcntTypes (t :| [])
 
 checkAcntTypes
   :: MonadFinance m
   => NE.NonEmpty AcntType
   -> AcntID
-  -> m (EitherErr AcntID)
+  -> (AcntID -> a)
-checkAcntTypes ts i = (go =<<) <$> lookupAccountType i
+  -> m (EitherErr a)
+checkAcntTypes ts i f = (go =<<) <$> lookupAccountType i
   where
     go t
-      | t `L.elem` ts = Right i
+      | t `L.elem` ts = Right $ f i
       | otherwise = Left $ AccountError i ts
 
 --------------------------------------------------------------------------------
@@ -473,7 +505,6 @@ insertImport i = whenHash CTImport i [] $ \c -> do
 --------------------------------------------------------------------------------
 -- low-level transaction stuff
 
--- TODO tags here?
 txPair
   :: MonadFinance m
   => Day
@@ -485,7 +516,7 @@ txPair
   -> m (EitherErrs KeyTx)
 txPair day from to cur val desc = resolveTx tx
   where
-    split a v = Split {sAcnt = a, sValue = v, sComment = "", sCurrency = cur, sTags = []}
+    split a v = Split {sAcnt = a, sValue = v, sComment = "", sCurrency = cur}
     tx =
       Tx
         { txDescr = desc
@@ -500,21 +531,17 @@ resolveTx t@Tx {txSplits = ss} = do
   return $ fmap (\kss -> t {txSplits = kss}) res
 
 resolveSplit :: MonadFinance m => BalSplit -> m (EitherErrs KeySplit)
-resolveSplit s@Split {sAcnt, sCurrency, sValue, sTags} = do
+resolveSplit s@Split {sAcnt = p, sCurrency = c, sValue = v} = do
-  aid <- lookupAccountKey sAcnt
+  aid <- lookupAccountKey p
-  cid <- lookupCurrency sCurrency
+  cid <- lookupCurrency c
-  sign <- lookupAccountSign sAcnt
+  sign <- lookupAccountSign p
-  tags <- mapM lookupTag sTags
   -- TODO correct sign here?
   -- TODO lenses would be nice here
-  return $
+  return $ concatEither3 aid cid sign $ \aid_ cid_ sign_ ->
-    (concatEithers2 (concatEither3 aid cid sign (,,)) $ concatEitherL tags) $
-      \(aid_, cid_, sign_) tags_ ->
     s
       { sAcnt = aid_
       , sCurrency = cid_
-          , sValue = sValue * fromIntegral (sign2Int sign_)
+      , sValue = v * fromIntegral (sign2Int sign_)
-          , sTags = tags_
       }
 
 insertTx :: MonadUnliftIO m => Key CommitR -> KeyTx -> SqlPersistT m ()
@@ -523,10 +550,8 @@ insertTx c Tx {txDate = d, txDescr = e, txSplits = ss} = do
   mapM_ (insertSplit k) ss
 
 insertSplit :: MonadUnliftIO m => Key TransactionR -> KeySplit -> SqlPersistT m (Key SplitR)
-insertSplit t Split {sAcnt, sCurrency, sValue, sComment, sTags} = do
+insertSplit t Split {sAcnt = aid, sCurrency = cid, sValue = v, sComment = c} = do
-  k <- insert $ SplitR t sCurrency sAcnt sComment sValue
+  insert $ SplitR t cid aid c v
-  mapM_ (insert_ . TagRelationR k) sTags
-  return k
 
 lookupAccount :: MonadFinance m => AcntID -> m (EitherErr (Key AccountR, AcntSign, AcntType))
 lookupAccount p = lookupErr (DBKey AcntField) p <$> (askDBState kmAccount)
@@ -543,9 +568,6 @@ lookupAccountType = fmap (fmap thdOf3) . lookupAccount
 lookupCurrency :: MonadFinance m => T.Text -> m (EitherErr (Key CurrencyR))
 lookupCurrency c = lookupErr (DBKey CurField) c <$> (askDBState kmCurrency)
 
-lookupTag :: MonadFinance m => TagID -> m (EitherErr (Key TagR))
-lookupTag c = lookupErr (DBKey TagField) c <$> (askDBState kmTag)
-
 -- TODO this hashes twice (not that it really matters)
 whenHash
   :: (Hashable a, MonadFinance m)

lib/Internal/Statement.hs

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

lib/Internal/Types.hs

@@ -1,7 +1,5 @@
 {-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE UndecidableInstances #-}
 
 module Internal.Types where
 
@@ -9,7 +7,6 @@ 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)
@@ -35,10 +32,12 @@ 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 "Tag" "Tag" "(./dhall/Types.dhall).Tag"
   , SingleConstructor "Gregorian" "Gregorian" "(./dhall/Types.dhall).Gregorian"
   , SingleConstructor "GregorianM" "GregorianM" "(./dhall/Types.dhall).GregorianM"
   , SingleConstructor "Interval" "Interval" "(./dhall/Types.dhall).Interval"
@@ -57,14 +56,42 @@ makeHaskellTypesWith
   , SingleConstructor "Budget" "Budget" "(./dhall/Types.dhall).Budget"
   , SingleConstructor "Transfer" "Transfer" "(./dhall/Types.dhall).Transfer"
   , SingleConstructor "Exchange" "Exchange" "(./dhall/Types.dhall).Exchange"
-  , SingleConstructor "TaggedAcnt" "TaggedAcnt" "(./dhall/Types.dhall).TaggedAcnt"
   , SingleConstructor "AcntSet" "AcntSet" "(./dhall/Types.dhall).AcntSet.Type"
   , SingleConstructor "ShadowMatch" "ShadowMatch" "(./dhall/Types.dhall).ShadowMatch.Type"
   , SingleConstructor "ShadowTransfer" "ShadowTransfer" "(./dhall/Types.dhall).ShadowTransfer"
   ]
 
 -------------------------------------------------------------------------------
--- lots of instances for dhall types
+-- account tree
+
+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
 
@@ -72,11 +99,48 @@ deriving instance Lift Currency
 
 deriving instance Hashable Currency
 
-deriving instance Eq Tag
+type CurID = T.Text
 
-deriving instance Lift Tag
+-------------------------------------------------------------------------------
+-- DHALL CONFIG
+-------------------------------------------------------------------------------
 
-deriving instance Hashable Tag
+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
 
@@ -170,16 +234,13 @@ deriving instance Show DatePat
 
 deriving instance Hashable DatePat
 
+--------------------------------------------------------------------------------
+-- Budget (projecting into the future)
+
 deriving instance Eq Budget
 
 deriving instance Hashable Budget
 
-deriving instance Eq TaggedAcnt
-
-deriving instance Hashable TaggedAcnt
-
-deriving instance Ord TaggedAcnt
-
 deriving instance Eq Income
 
 deriving instance Hashable Income
@@ -204,6 +265,14 @@ 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
 
@@ -214,6 +283,30 @@ 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
@@ -222,6 +315,10 @@ deriving instance Eq TimeAmount
 
 deriving instance Hashable TimeAmount
 
+deriving instance Eq TransferTarget
+
+deriving instance Hashable TransferTarget
+
 deriving instance Eq Transfer
 
 deriving instance Hashable Transfer
@@ -238,149 +335,27 @@ 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
-  , tags :: ![Tag]
-  , 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)
-
 --------------------------------------------------------------------------------
--- dhall type overrides (since dhall can't import types with parameters...yet)
+-- Statements (data from the past)
-
--- TODO newtypes for these?
-type AcntID = T.Text
-
-type CurID = T.Text
-
-type TagID = T.Text
 
 data Statement
   = StmtManual !Manual
   | StmtImport !Import
   deriving (Eq, Hashable, Generic, FromDhall)
 
-data Split a v c t = Split
+deriving instance Eq Manual
+
+deriving instance Hashable Manual
+
+data Split a v c = Split
   { sAcnt :: !a
   , sValue :: !v
   , sCurrency :: !c
   , sComment :: !T.Text
-  , sTags :: ![t]
   }
-  deriving (Eq, Generic, Hashable, Show)
+  deriving (Eq, Generic, Hashable, Show, FromDhall)
 
-type ExpSplit = Split SplitAcnt (Maybe SplitNum) SplitCur TagID
+type ExpSplit = Split SplitAcnt (Maybe SplitNum) SplitCur
-
-instance FromDhall ExpSplit
 
 data Tx s = Tx
   { txDescr :: !T.Text
@@ -413,6 +388,52 @@ 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
@@ -466,54 +487,13 @@ data Match re = Match
 deriving instance Show (Match T.Text)
 
 --------------------------------------------------------------------------------
--- DATABASE MODEL
+-- Specialized dhall types
---------------------------------------------------------------------------------
 
-share
+deriving instance Eq Decimal
-  [mkPersist sqlSettings, mkMigrate "migrateAll"]
+
-  [persistLowerCase|
+deriving instance Hashable Decimal
-CommitR sql=commits
+
-    hash Int
+deriving instance Show Decimal
-    type ConfigType
-    deriving Show Eq
-CurrencyR sql=currencies
-    symbol T.Text
-    fullname T.Text
-    deriving Show Eq
-TagR sql=tags
-    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
-TagRelationR sql=tag_relations
-    split SplitRId OnDeleteCascade
-    tag TagRId OnDeleteCascade
-BudgetLabelR sql=budget_labels
-    split SplitRId OnDeleteCascade
-    budgetName T.Text
-    deriving Show Eq
-|]
 
 --------------------------------------------------------------------------------
 -- database cache types
@@ -539,60 +519,6 @@ 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
-
-type TagMap = M.Map TagID TagRId
-
-data DBState = DBState
-  { kmCurrency :: !CurrencyMap
-  , kmAccount :: !AccountMap
-  , kmTag :: !TagMap
-  , kmBudgetInterval :: !Bounds
-  , kmStatementInterval :: !Bounds
-  , kmNewCommits :: ![Int]
-  , kmConfigDir :: !FilePath
-  }
-
-type MappingT m = ReaderT DBState (SqlPersistT m)
-
-type KeySplit = Split AccountRId Rational CurrencyRId TagRId
-
-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
 
@@ -628,6 +554,8 @@ data TxRecord = TxRecord
 
 type Bounds = (Day, Natural)
 
+-- type MaybeBounds = (Maybe Day, Maybe Day)
+
 data Keyed a = Keyed
   { kKey :: !Int64
   , kVal :: !a
@@ -650,9 +578,9 @@ accountSign IncomeT = Credit
 accountSign LiabilityT = Credit
 accountSign EquityT = Credit
 
-type RawSplit = Split AcntID (Maybe Rational) CurID TagID
+type RawSplit = Split AcntID (Maybe Rational) CurID
 
-type BalSplit = Split AcntID Rational CurID TagID
+type BalSplit = Split AcntID Rational CurID
 
 type RawTx = Tx RawSplit
 
@@ -660,14 +588,11 @@ 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)
 
-data SplitIDType = AcntField | CurField | TagField deriving (Show)
+data SplitIDType = AcntField | CurField deriving (Show)
 
 data LookupSuberr
   = SplitIDField !SplitIDType

lib/Internal/Utils.hs

@@ -170,7 +170,6 @@ toTx sc sa toSplits r@TxRecord {trAmount, trDate, trDesc} =
             , sCurrency = c_
             , sValue = Just trAmount
             , sComment = ""
-            , sTags = [] -- TODO what goes here?
             }
      in Tx
           { txTags = []
@@ -358,10 +357,8 @@ showError other = (: []) $ case other of
         SplitValField -> "split value"
         MatchField mt -> T.unwords [matchName mt, "match"]
         DBKey st -> T.unwords ["database", idName st, "ID key"]
-      -- TODO this should be its own function
       idName AcntField = "account"
       idName CurField = "currency"
-      idName TagField = "tag"
       matchName MatchNumeric = "numeric"
       matchName MatchText = "text"
   (IncomeError dp) ->