WIP use tags for splits

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 }
@@ -194,10 +198,13 @@ let Exchange =
 
 let BudgetCurrency = < NoX : CurID | X : Exchange >
 
+let TaggedAcnt = { taAcnt : AcntID, taTags : List TagID }
+
 let Allocation =
-      { alloPath : AcntID
+      { alloTo : TaggedAcnt
+      , alloTags : List TagID
       , alloAmts : List Amount
-      , alloCurrency : BudgetCurrency
+      , alloCur : BudgetCurrency
       }
 
 let Income =
@@ -207,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 : AcntID
+      , incToBal : TaggedAcnt
       }
 
 let Transfer =
-      { transFrom : AcntID
+      { transFrom : TaggedAcnt
-      , transTo : AcntID
+      , transTo : TaggedAcnt
       , transAmounts : List TimeAmount
       , transCurrency : BudgetCurrency
       }
@@ -242,8 +249,8 @@ let ShadowMatch =
       }
 
 let ShadowTransfer =
-      { stFrom : AcntID
+      { stFrom : TaggedAcnt
-      , stTo : AcntID
+      , stTo : TaggedAcnt
       , stCurrency : CurID
       , stDesc : Text
       , stMatch : ShadowMatch.Type
@@ -261,6 +268,7 @@ in  { CurID
     , AcntID
     , SqlConfig
     , Currency
+    , Tag
     , Interval
     , Global
     , Gregorian
@@ -305,4 +313,5 @@ in  { CurID
     , AcntSet
     , BudgetCurrency
     , Exchange
+    , TaggedAcnt
     }

lib/Internal/Database/Ops.hs

@@ -161,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
@@ -173,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
@@ -195,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
 
@@ -306,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
@@ -317,6 +338,7 @@ getDBState c = do
       , kmStatementInterval = s
       , kmNewCommits = hs
       , kmConfigDir = f
+      , kmTag = ts
       }
   where
     bi = resolveBounds $ budgetInterval $ global c

lib/Internal/Insert.hs

@@ -163,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 (btFrom tx_) smFrom
+    memberMaybe (taAcnt $ btFrom tx_) smFrom
-      && memberMaybe (btTo tx_) smTo
+      && memberMaybe (taAcnt $ btTo tx_) smTo
       && maybe True (`dateMatches` (btWhen tx_)) smDate
       && valRes
   where
@@ -205,8 +205,8 @@ data BudgetMeta = BudgetMeta
 data BudgetTx = BudgetTx
   { btMeta :: !BudgetMeta
   , btWhen :: !Day
-  , btFrom :: !AcntID
+  , btFrom :: !TaggedAcnt
-  , btTo :: !AcntID
+  , btTo :: !TaggedAcnt
   , btValue :: !Rational
   , btDesc :: !T.Text
   }
@@ -223,17 +223,18 @@ insertIncome
     whenHash CTIncome i (Right []) $ \c -> do
       let meta = BudgetMeta c (NoX incCurrency) name
       let balRes = balanceIncome i
-      fromRes <- lift $ checkAcntType IncomeT incFrom
+      fromRes <- lift $ checkAcntType IncomeT $ taAcnt incFrom
       case concatEither2 balRes fromRes (,) of
         Left es -> return $ Left es
-        Right (balance, from) ->
+        -- TODO this hole seems sloppy...
+        Right (balance, _) ->
           fmap (fmap (concat . concat)) $
             withDates incWhen $ \day -> do
-              let fromAllos = fmap concat . mapM (lift . fromAllo day meta from)
+              let fromAllos = fmap concat . mapM (lift . fromAllo day meta incFrom)
               pre <- fromAllos incPretax
               tax <-
                 concatEitherL
-                  <$> mapM (lift . fromTax day meta from) incTaxes
+                  <$> mapM (lift . fromTax day meta (taAcnt incFrom)) incTaxes
               post <- fromAllos incPosttax
               let bal =
                     BudgetTxType
@@ -241,7 +242,7 @@ insertIncome
                           BudgetTx
                             { btMeta = meta
                             , btWhen = day
-                            , btFrom = from
+                            , btFrom = incFrom
                             , btTo = incToBal
                             , btValue = balance
                             , btDesc = "balance after deductions"
@@ -254,10 +255,10 @@ fromAllo
   :: MonadFinance m
   => Day
   -> BudgetMeta
-  -> AcntID
+  -> TaggedAcnt
   -> Allocation
   -> 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
   return $ fmap toBT alloAmts
@@ -268,7 +269,7 @@ fromAllo day meta from Allocation {alloPath, alloAmts} = do
             BudgetTx
               { btFrom = from
               , btWhen = day
-              , btTo = alloPath
+              , btTo = alloTo
               , btValue = dec2Rat v
               , btDesc = desc
               , btMeta = meta
@@ -276,6 +277,7 @@ fromAllo day meta from Allocation {alloPath, alloAmts} = do
         , bttType = FixedAmt
         }
 
+-- TODO maybe allow tags here?
 fromTax
   :: MonadFinance m
   => Day
@@ -291,9 +293,9 @@ fromTax day meta from Tax {taxAcnt = to, taxValue = v} = do
       BudgetTxType
         { bttTx =
             BudgetTx
-              { btFrom = from
+              { btFrom = TaggedAcnt from []
               , btWhen = day
-              , btTo = to_
+              , btTo = TaggedAcnt to_ []
               , btValue = dec2Rat v
               , btDesc = ""
               , btMeta = meta
@@ -376,29 +378,31 @@ 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
           }
 
 checkAcntType
@@ -469,6 +473,7 @@ insertImport i = whenHash CTImport i [] $ \c -> do
 --------------------------------------------------------------------------------
 -- low-level transaction stuff
 
+-- TODO tags here?
 txPair
   :: MonadFinance m
   => Day
@@ -480,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
@@ -495,18 +500,22 @@ 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 $
-    s
+    (concatEithers2 (concatEither3 aid cid sign (,,)) $ concatEitherL tags) $
-      { sAcnt = aid_
+      \(aid_, cid_, sign_) tags_ ->
-      , sCurrency = cid_
+        s
-      , sValue = v * fromIntegral (sign2Int sign_)
+          { sAcnt = aid_
-      }
+          , sCurrency = cid_
+          , sValue = sValue * fromIntegral (sign2Int sign_)
+          , sTags = tags_
+          }
 
 insertTx :: MonadUnliftIO m => Key CommitR -> KeyTx -> SqlPersistT m ()
 insertTx c Tx {txDate = d, txDescr = e, txSplits = ss} = do
@@ -514,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)
@@ -532,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/Types.hs

@@ -38,6 +38,7 @@ makeHaskellTypesWith
   , MultipleConstructors "AmountType" "(./dhall/Types.dhall).AmountType"
   , 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,6 +57,7 @@ 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"
@@ -70,6 +72,12 @@ deriving instance Lift Currency
 
 deriving instance Hashable Currency
 
+deriving instance Eq Tag
+
+deriving instance Lift Tag
+
+deriving instance Hashable Tag
+
 deriving instance Eq TimeUnit
 
 deriving instance Ord TimeUnit
@@ -166,6 +174,12 @@ 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
@@ -316,6 +330,7 @@ data Config_ a = Config_
   , currencies :: ![Currency]
   , statements :: ![Statement]
   , accounts :: !a
+  , tags :: ![Tag]
   , sqlConfig :: !SqlConfig
   }
   deriving (Generic)
@@ -342,24 +357,30 @@ instance FromDhall a => FromDhall (Config_ a)
 --------------------------------------------------------------------------------
 -- 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)
 
-data Split a v c = Split
+data Split a v c t = 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
@@ -459,6 +480,10 @@ 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
@@ -481,6 +506,9 @@ SplitR sql=splits
     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
@@ -515,9 +543,12 @@ 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]
@@ -526,7 +557,7 @@ data DBState = DBState
 
 type MappingT m = ReaderT DBState (SqlPersistT m)
 
-type KeySplit = Split AccountRId Rational CurrencyRId
+type KeySplit = Split AccountRId Rational CurrencyRId TagRId
 
 type KeyTx = Tx KeySplit
 
@@ -619,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
 
@@ -636,7 +667,7 @@ 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) ->