From 4eae92eb01fc4f08ab86d515f85b6e08702cdb6e Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Sun, 26 Feb 2023 22:53:12 -0500 Subject: [PATCH] WIP use tags for splits --- dhall/Types.dhall | 25 +++++++---- lib/Internal/Database/Ops.hs | 22 ++++++++++ lib/Internal/Insert.hs | 80 +++++++++++++++++++++--------------- lib/Internal/Types.hs | 45 ++++++++++++++++---- lib/Internal/Utils.hs | 3 ++ 5 files changed, 127 insertions(+), 48 deletions(-) diff --git a/dhall/Types.dhall b/dhall/Types.dhall index de72dab..b4f06e6 100644 --- a/dhall/Types.dhall +++ b/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 - , transTo : AcntID + { transFrom : TaggedAcnt + , transTo : TaggedAcnt , transAmounts : List TimeAmount , transCurrency : BudgetCurrency } @@ -242,8 +249,8 @@ let ShadowMatch = } let ShadowTransfer = - { stFrom : AcntID - , stTo : AcntID + { stFrom : TaggedAcnt + , 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 } diff --git a/lib/Internal/Database/Ops.hs b/lib/Internal/Database/Ops.hs index 151f388..aeae945 100644 --- a/lib/Internal/Database/Ops.hs +++ b/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 diff --git a/lib/Internal/Insert.hs b/lib/Internal/Insert.hs index df523a4..2dd5be0 100644 --- a/lib/Internal/Insert.hs +++ b/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 (btTo tx_) smTo + memberMaybe (taAcnt $ btFrom tx_) smFrom + && 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 - , btTo :: !AcntID + , btFrom :: !TaggedAcnt + , 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 - -> AcntID + => TaggedAcnt + -> 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 - res2 <- pair xToCur xAcnt to (val * dec2Rat xRate) + let middle = TaggedAcnt xAcnt [] + 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 - aid <- lookupAccountKey p - cid <- lookupCurrency c - sign <- lookupAccountSign p +resolveSplit s@Split {sAcnt, sCurrency, sValue, sTags} = do + aid <- lookupAccountKey sAcnt + cid <- lookupCurrency sCurrency + 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_ -> - s - { sAcnt = aid_ - , sCurrency = cid_ - , sValue = v * fromIntegral (sign2Int sign_) - } + return $ + (concatEithers2 (concatEither3 aid cid sign (,,)) $ concatEitherL tags) $ + \(aid_, cid_, sign_) tags_ -> + s + { 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 - insert $ SplitR t cid aid c v +insertSplit t Split {sAcnt, sCurrency, sValue, sComment, sTags} = do + 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) diff --git a/lib/Internal/Types.hs b/lib/Internal/Types.hs index c2c289b..ee44484 100644 --- a/lib/Internal/Types.hs +++ b/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 diff --git a/lib/Internal/Utils.hs b/lib/Internal/Utils.hs index 97d5e21..d25460f 100644 --- a/lib/Internal/Utils.hs +++ b/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) ->