WIP use tags for splits

This commit is contained in:
Nathan Dwarshuis 2023-02-26 22:53:12 -05:00
parent 4e38f9ed8d
commit 4eae92eb01
5 changed files with 127 additions and 48 deletions

View File

@ -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
}

View File

@ -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

View File

@ -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,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
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_ ->
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 ()
@ -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)

View File

@ -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

View File

@ -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) ->