WIP use tags for splits

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

@@ -6,10 +6,14 @@ 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 }
@@ -181,10 +185,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,25 +193,18 @@ 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 =
-      { alloPath : TransferTarget
+      { alloTo : TaggedAcnt
+      , alloTags : List TagID
       , alloAmts : List Amount
-      , alloCurrency : BudgetCurrency
+      , alloCur : BudgetCurrency
       }
 
 let Income =
@@ -221,16 +214,16 @@ let Income =
       , incFrom :
           {- this must be an income AcntID, and is the only place income
           accounts may be specified in the entire budget -}
-          AcntID
+          TaggedAcnt
       , incPretax : List Allocation
       , incTaxes : List Tax
       , incPosttax : List Allocation
-      , incToBal : TransferTarget
+      , incToBal : TaggedAcnt
       }
 
 let Transfer =
-      { transFrom : AcntID
+      { transFrom : TaggedAcnt
-      , transTo : TransferTarget
+      , transTo : TaggedAcnt
       , transAmounts : List TimeAmount
       , transCurrency : BudgetCurrency
       }
@@ -256,8 +249,8 @@ let ShadowMatch =
       }
 
 let ShadowTransfer =
-      { stFrom : AcntID
+      { stFrom : TaggedAcnt
-      , stTo : AcntID
+      , stTo : TaggedAcnt
       , stCurrency : CurID
       , stDesc : Text
       , stMatch : ShadowMatch.Type
@@ -275,6 +268,7 @@ in  { CurID
     , AcntID
     , SqlConfig
     , Currency
+    , Tag
     , Interval
     , Global
     , Gregorian
@@ -308,18 +302,16 @@ 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

@@ -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, (^.))
@@ -163,6 +161,13 @@ 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
@@ -175,6 +180,7 @@ updateAccounts ar = do
   mapM_ insert paths
   return acntMap
 
+-- TODO slip-n-slide code...
 insertFull
   :: (MonadUnliftIO m, PersistStoreWrite b, PersistRecordBackend r b)
   => Entity r
@@ -197,6 +203,18 @@ 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
 
@@ -308,6 +326,7 @@ 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
@@ -319,6 +338,7 @@ getDBState c = do
       , kmStatementInterval = s
       , kmNewCommits = hs
       , kmConfigDir = f
+      , kmTag = ts
       }
   where
     bi = resolveBounds $ budgetInterval $ global c

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 (taAcnt $ btFrom tx_) smFrom
-      && memberMaybe (bsAcnt $ btTo tx_) smTo
+      && memberMaybe (taAcnt $ 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 :: !TaggedAcnt
-  , btTo :: !(BudgetSplit ExpenseBucket)
+  , btTo :: !TaggedAcnt
   , btValue :: !Rational
   , btDesc :: !T.Text
   }
@@ -231,55 +223,53 @@ 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 $ taAcnt 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) ->
+        -- TODO this hole seems sloppy...
+        Right (balance, _) ->
           fmap (fmap (concat . concat)) $
             withDates incWhen $ \day -> do
-              let fromAllos b =
+              let fromAllos = fmap concat . mapM (lift . fromAllo day meta incFrom)
-                    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 (taAcnt incFrom)) incTaxes
-              post <- fromAllos PostTax incPosttax
+              post <- fromAllos incPosttax
               let bal =
                     BudgetTxType
                       { bttTx =
                           BudgetTx
                             { btMeta = meta
                             , btWhen = day
-                            , btFrom = fromFun PostTax
+                            , btFrom = incFrom
-                            , 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
+  -> TaggedAcnt
   -> Allocation
-  -> m (EitherErr [BudgetTxType])
+  -> m [BudgetTxType]
-fromAllo day meta from Allocation {alloPath, alloAmts} = do
+fromAllo day meta from Allocation {alloTo, 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 = alloTo
               , btValue = dec2Rat v
               , btDesc = desc
               , btMeta = meta
@@ -287,22 +277,25 @@ fromAllo day meta from Allocation {alloPath, alloAmts} = do
         , bttType = FixedAmt
         }
 
+-- TODO maybe allow tags here?
 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
+              { btFrom = TaggedAcnt from []
               , btWhen = day
-            , btTo = BudgetSplit to_ (Just Fixed)
+              , btTo = TaggedAcnt to_ []
               , btValue = dec2Rat v
               , btDesc = ""
               , btMeta = meta
@@ -344,11 +337,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 +350,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,87 +361,66 @@ 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)
 
 splitPair
   :: MonadFinance m
-  => AcntID
+  => TaggedAcnt
-  -> AcntID
+  -> TaggedAcnt
   -> 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
-    res1 <- pair xFromCur from xAcnt val
+    let middle = TaggedAcnt xAcnt []
-    res2 <- pair xToCur xAcnt to (val * dec2Rat xRate)
+    res1 <- pair xFromCur from middle val
+    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 a v =
+    split c TaggedAcnt {taAcnt, taTags} v =
       resolveSplit $
         Split
-          { sAcnt = a
+          { sAcnt = taAcnt
           , 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
-  -> (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
 
 --------------------------------------------------------------------------------
@@ -505,6 +473,7 @@ insertImport i = whenHash CTImport i [] $ \c -> do
 --------------------------------------------------------------------------------
 -- low-level transaction stuff
 
+-- TODO tags here?
 txPair
   :: MonadFinance m
   => Day
@@ -516,7 +485,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}
+    split a v = Split {sAcnt = a, sValue = v, sComment = "", sCurrency = cur, sTags = []}
     tx =
       Tx
         { txDescr = desc
@@ -531,17 +500,21 @@ resolveTx t@Tx {txSplits = ss} = do
   return $ fmap (\kss -> t {txSplits = kss}) res
 
 resolveSplit :: MonadFinance m => BalSplit -> m (EitherErrs KeySplit)
-resolveSplit s@Split {sAcnt = p, sCurrency = c, sValue = v} = do
+resolveSplit s@Split {sAcnt, sCurrency, sValue, sTags} = do
-  aid <- lookupAccountKey p
+  aid <- lookupAccountKey sAcnt
-  cid <- lookupCurrency c
+  cid <- lookupCurrency sCurrency
-  sign <- lookupAccountSign p
+  sign <- lookupAccountSign sAcnt
+  tags <- mapM lookupTag sTags
   -- TODO correct sign here?
   -- TODO lenses would be nice here
-  return $ concatEither3 aid cid sign $ \aid_ cid_ sign_ ->
+  return $
+    (concatEithers2 (concatEither3 aid cid sign (,,)) $ concatEitherL tags) $
+      \(aid_, cid_, sign_) tags_ ->
         s
           { sAcnt = aid_
           , sCurrency = cid_
-      , sValue = v * fromIntegral (sign2Int sign_)
+          , sValue = sValue * fromIntegral (sign2Int sign_)
+          , sTags = tags_
           }
 
 insertTx :: MonadUnliftIO m => Key CommitR -> KeyTx -> SqlPersistT m ()
@@ -550,8 +523,10 @@ 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 = aid, sCurrency = cid, sValue = v, sComment = c} = do
+insertSplit t Split {sAcnt, sCurrency, sValue, sComment, sTags} = do
-  insert $ SplitR t cid aid c v
+  k <- insert $ SplitR t sCurrency sAcnt sComment sValue
+  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)
@@ -568,6 +543,9 @@ 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,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,12 +35,10 @@ 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"
@@ -56,42 +57,14 @@ 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"
   ]
 
 -------------------------------------------------------------------------------
--- 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,48 +72,11 @@ deriving instance Lift Currency
 
 deriving instance Hashable Currency
 
-type CurID = T.Text
+deriving instance Eq Tag
 
--------------------------------------------------------------------------------
+deriving instance Lift Tag
--- DHALL CONFIG
--------------------------------------------------------------------------------
 
-data Config_ a = Config_
+deriving instance Hashable Tag
-  { 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
 
@@ -234,13 +170,16 @@ 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
@@ -265,14 +204,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 +214,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 +222,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,27 +238,149 @@ 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)
+
 --------------------------------------------------------------------------------
--- Statements (data from the past)
+-- dhall type overrides (since dhall can't import types with parameters...yet)
+
+-- 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)
 
-deriving instance Eq Manual
+data Split a v c t = Split
-
-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, FromDhall)
+  deriving (Eq, Generic, Hashable, Show)
 
-type ExpSplit = Split SplitAcnt (Maybe SplitNum) SplitCur
+type ExpSplit = Split SplitAcnt (Maybe SplitNum) SplitCur TagID
+
+instance FromDhall ExpSplit
 
 data Tx s = Tx
   { txDescr :: !T.Text
@@ -388,52 +413,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 +466,54 @@ 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
+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
@@ -519,6 +539,60 @@ 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
 
@@ -554,8 +628,6 @@ data TxRecord = TxRecord
 
 type Bounds = (Day, Natural)
 
--- type MaybeBounds = (Maybe Day, Maybe Day)
-
 data Keyed a = Keyed
   { kKey :: !Int64
   , kVal :: !a
@@ -578,9 +650,9 @@ accountSign IncomeT = Credit
 accountSign LiabilityT = Credit
 accountSign EquityT = Credit
 
-type RawSplit = Split AcntID (Maybe Rational) CurID
+type RawSplit = Split AcntID (Maybe Rational) CurID TagID
 
-type BalSplit = Split AcntID Rational CurID
+type BalSplit = Split AcntID Rational CurID TagID
 
 type RawTx = Tx RawSplit
 
@@ -588,11 +660,14 @@ 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 deriving (Show)
+data SplitIDType = AcntField | CurField | TagField deriving (Show)
 
 data LookupSuberr
   = SplitIDField !SplitIDType

lib/Internal/Utils.hs

@@ -170,6 +170,7 @@ toTx sc sa toSplits r@TxRecord {trAmount, trDate, trDesc} =
             , sCurrency = c_
             , sValue = Just trAmount
             , sComment = ""
+            , sTags = [] -- TODO what goes here?
             }
      in Tx
           { txTags = []
@@ -357,8 +358,10 @@ 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) ->