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 AcntID = Text
let TagID = Text
let SqlConfig {- TODO pgsql -} = < Sqlite : Text | Postgres > let SqlConfig {- TODO pgsql -} = < Sqlite : Text | Postgres >
let Currency = { curSymbol : CurID, curFullname : Text } let Currency = { curSymbol : CurID, curFullname : Text }
let Tag = { tagID : TagID, tagDesc : Text }
let Gregorian = { gYear : Natural, gMonth : Natural, gDay : Natural } let Gregorian = { gYear : Natural, gMonth : Natural, gDay : Natural }
let GregorianM = { gmYear : Natural, gmMonth : Natural } let GregorianM = { gmYear : Natural, gmMonth : Natural }
@ -194,10 +198,13 @@ let Exchange =
let BudgetCurrency = < NoX : CurID | X : Exchange > let BudgetCurrency = < NoX : CurID | X : Exchange >
let TaggedAcnt = { taAcnt : AcntID, taTags : List TagID }
let Allocation = let Allocation =
{ alloPath : AcntID { alloTo : TaggedAcnt
, alloTags : List TagID
, alloAmts : List Amount , alloAmts : List Amount
, alloCurrency : BudgetCurrency , alloCur : BudgetCurrency
} }
let Income = let Income =
@ -207,16 +214,16 @@ let Income =
, incFrom : , incFrom :
{- this must be an income AcntID, and is the only place income {- this must be an income AcntID, and is the only place income
accounts may be specified in the entire budget -} accounts may be specified in the entire budget -}
AcntID TaggedAcnt
, incPretax : List Allocation , incPretax : List Allocation
, incTaxes : List Tax , incTaxes : List Tax
, incPosttax : List Allocation , incPosttax : List Allocation
, incToBal : AcntID , incToBal : TaggedAcnt
} }
let Transfer = let Transfer =
{ transFrom : AcntID { transFrom : TaggedAcnt
, transTo : AcntID , transTo : TaggedAcnt
, transAmounts : List TimeAmount , transAmounts : List TimeAmount
, transCurrency : BudgetCurrency , transCurrency : BudgetCurrency
} }
@ -242,8 +249,8 @@ let ShadowMatch =
} }
let ShadowTransfer = let ShadowTransfer =
{ stFrom : AcntID { stFrom : TaggedAcnt
, stTo : AcntID , stTo : TaggedAcnt
, stCurrency : CurID , stCurrency : CurID
, stDesc : Text , stDesc : Text
, stMatch : ShadowMatch.Type , stMatch : ShadowMatch.Type
@ -261,6 +268,7 @@ in { CurID
, AcntID , AcntID
, SqlConfig , SqlConfig
, Currency , Currency
, Tag
, Interval , Interval
, Global , Global
, Gregorian , Gregorian
@ -305,4 +313,5 @@ in { CurID
, AcntSet , AcntSet
, BudgetCurrency , BudgetCurrency
, Exchange , Exchange
, TaggedAcnt
} }

View File

@ -161,6 +161,13 @@ deleteCurrency e = delete $ do
where where
k = entityKey e 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 :: MonadUnliftIO m => AccountRoot -> SqlPersistT m AccountMap
updateAccounts ar = do updateAccounts ar = do
let (acnts, paths, acntMap) = indexAcntRoot ar let (acnts, paths, acntMap) = indexAcntRoot ar
@ -173,6 +180,7 @@ updateAccounts ar = do
mapM_ insert paths mapM_ insert paths
return acntMap return acntMap
-- TODO slip-n-slide code...
insertFull insertFull
:: (MonadUnliftIO m, PersistStoreWrite b, PersistRecordBackend r b) :: (MonadUnliftIO m, PersistStoreWrite b, PersistRecordBackend r b)
=> Entity r => Entity r
@ -195,6 +203,18 @@ currency2Record c@Currency {curSymbol, curFullname} =
currencyMap :: [Entity CurrencyR] -> CurrencyMap currencyMap :: [Entity CurrencyR] -> CurrencyMap
currencyMap = M.fromList . fmap (\e -> (currencyRSymbol $ entityVal e, entityKey e)) 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 :: (ToBackendKey SqlBackend b, Hashable a) => a -> Key b
toKey = toSqlKey . fromIntegral . hash toKey = toSqlKey . fromIntegral . hash
@ -306,6 +326,7 @@ getDBState
getDBState c = do getDBState c = do
am <- updateAccounts $ accounts c am <- updateAccounts $ accounts c
cm <- updateCurrencies $ currencies c cm <- updateCurrencies $ currencies c
ts <- updateTags $ tags c
hs <- updateHashes c hs <- updateHashes c
-- TODO not sure how I feel about this, probably will change this struct alot -- TODO not sure how I feel about this, probably will change this struct alot
-- in the future so whatever...for now -- in the future so whatever...for now
@ -317,6 +338,7 @@ getDBState c = do
, kmStatementInterval = s , kmStatementInterval = s
, kmNewCommits = hs , kmNewCommits = hs
, kmConfigDir = f , kmConfigDir = f
, kmTag = ts
} }
where where
bi = resolveBounds $ budgetInterval $ global c 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? -- TODO what does the amount do for each of the different types?
valRes <- valMatches smVal (btValue tx_) valRes <- valMatches smVal (btValue tx_)
return $ 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 && maybe True (`dateMatches` (btWhen tx_)) smDate
&& valRes && valRes
where where
@ -205,8 +205,8 @@ data BudgetMeta = BudgetMeta
data BudgetTx = BudgetTx data BudgetTx = BudgetTx
{ btMeta :: !BudgetMeta { btMeta :: !BudgetMeta
, btWhen :: !Day , btWhen :: !Day
, btFrom :: !AcntID , btFrom :: !TaggedAcnt
, btTo :: !AcntID , btTo :: !TaggedAcnt
, btValue :: !Rational , btValue :: !Rational
, btDesc :: !T.Text , btDesc :: !T.Text
} }
@ -223,17 +223,18 @@ insertIncome
whenHash CTIncome i (Right []) $ \c -> do whenHash CTIncome i (Right []) $ \c -> do
let meta = BudgetMeta c (NoX incCurrency) name let meta = BudgetMeta c (NoX incCurrency) name
let balRes = balanceIncome i let balRes = balanceIncome i
fromRes <- lift $ checkAcntType IncomeT incFrom fromRes <- lift $ checkAcntType IncomeT $ taAcnt incFrom
case concatEither2 balRes fromRes (,) of case concatEither2 balRes fromRes (,) of
Left es -> return $ Left es Left es -> return $ Left es
Right (balance, from) -> -- TODO this hole seems sloppy...
Right (balance, _) ->
fmap (fmap (concat . concat)) $ fmap (fmap (concat . concat)) $
withDates incWhen $ \day -> do 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 pre <- fromAllos incPretax
tax <- tax <-
concatEitherL concatEitherL
<$> mapM (lift . fromTax day meta from) incTaxes <$> mapM (lift . fromTax day meta (taAcnt incFrom)) incTaxes
post <- fromAllos incPosttax post <- fromAllos incPosttax
let bal = let bal =
BudgetTxType BudgetTxType
@ -241,7 +242,7 @@ insertIncome
BudgetTx BudgetTx
{ btMeta = meta { btMeta = meta
, btWhen = day , btWhen = day
, btFrom = from , btFrom = incFrom
, btTo = incToBal , btTo = incToBal
, btValue = balance , btValue = balance
, btDesc = "balance after deductions" , btDesc = "balance after deductions"
@ -254,10 +255,10 @@ fromAllo
:: MonadFinance m :: MonadFinance m
=> Day => Day
-> BudgetMeta -> BudgetMeta
-> AcntID -> TaggedAcnt
-> Allocation -> Allocation
-> m [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) -- TODO this is going to be repeated a zillion times (might matter)
-- res <- expandTarget alloPath -- res <- expandTarget alloPath
return $ fmap toBT alloAmts return $ fmap toBT alloAmts
@ -268,7 +269,7 @@ fromAllo day meta from Allocation {alloPath, alloAmts} = do
BudgetTx BudgetTx
{ btFrom = from { btFrom = from
, btWhen = day , btWhen = day
, btTo = alloPath , btTo = alloTo
, btValue = dec2Rat v , btValue = dec2Rat v
, btDesc = desc , btDesc = desc
, btMeta = meta , btMeta = meta
@ -276,6 +277,7 @@ fromAllo day meta from Allocation {alloPath, alloAmts} = do
, bttType = FixedAmt , bttType = FixedAmt
} }
-- TODO maybe allow tags here?
fromTax fromTax
:: MonadFinance m :: MonadFinance m
=> Day => Day
@ -291,9 +293,9 @@ fromTax day meta from Tax {taxAcnt = to, taxValue = v} = do
BudgetTxType BudgetTxType
{ bttTx = { bttTx =
BudgetTx BudgetTx
{ btFrom = from { btFrom = TaggedAcnt from []
, btWhen = day , btWhen = day
, btTo = to_ , btTo = TaggedAcnt to_ []
, btValue = dec2Rat v , btValue = dec2Rat v
, btDesc = "" , btDesc = ""
, btMeta = meta , btMeta = meta
@ -376,29 +378,31 @@ type SplitPair = (KeySplit, KeySplit)
splitPair splitPair
:: MonadFinance m :: MonadFinance m
=> AcntID => TaggedAcnt
-> AcntID -> TaggedAcnt
-> BudgetCurrency -> BudgetCurrency
-> Rational -> Rational
-> m (EitherErrs (SplitPair, Maybe SplitPair)) -> m (EitherErrs (SplitPair, Maybe SplitPair))
splitPair from to cur val = case cur of splitPair from to cur val = case cur of
NoX curid -> fmap (fmap (,Nothing)) $ pair curid from to val NoX curid -> fmap (fmap (,Nothing)) $ pair curid from to val
X (Exchange {xFromCur, xToCur, xAcnt, xRate}) -> do 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) return $ concatEithers2 res1 res2 $ \a b -> (a, Just b)
where where
pair curid from_ to_ v = do pair curid from_ to_ v = do
s1 <- split curid from_ (-v) s1 <- split curid from_ (-v)
s2 <- split curid to_ v s2 <- split curid to_ v
return $ concatEithers2 s1 s2 (,) return $ concatEithers2 s1 s2 (,)
split c a v = split c TaggedAcnt {taAcnt, taTags} v =
resolveSplit $ resolveSplit $
Split Split
{ sAcnt = a { sAcnt = taAcnt
, sValue = v , sValue = v
, sComment = "" , sComment = ""
, sCurrency = c , sCurrency = c
, sTags = taTags
} }
checkAcntType checkAcntType
@ -469,6 +473,7 @@ insertImport i = whenHash CTImport i [] $ \c -> do
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- low-level transaction stuff -- low-level transaction stuff
-- TODO tags here?
txPair txPair
:: MonadFinance m :: MonadFinance m
=> Day => Day
@ -480,7 +485,7 @@ txPair
-> m (EitherErrs KeyTx) -> m (EitherErrs KeyTx)
txPair day from to cur val desc = resolveTx tx txPair day from to cur val desc = resolveTx tx
where 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 =
Tx Tx
{ txDescr = desc { txDescr = desc
@ -495,18 +500,22 @@ resolveTx t@Tx {txSplits = ss} = do
return $ fmap (\kss -> t {txSplits = kss}) res return $ fmap (\kss -> t {txSplits = kss}) res
resolveSplit :: MonadFinance m => BalSplit -> m (EitherErrs KeySplit) 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 correct sign here?
-- TODO lenses would be nice 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 :: MonadUnliftIO m => Key CommitR -> KeyTx -> SqlPersistT m ()
insertTx c Tx {txDate = d, txDescr = e, txSplits = ss} = do 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 mapM_ (insertSplit k) ss
insertSplit :: MonadUnliftIO m => Key TransactionR -> KeySplit -> SqlPersistT m (Key SplitR) 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 :: MonadFinance m => AcntID -> m (EitherErr (Key AccountR, AcntSign, AcntType))
lookupAccount p = lookupErr (DBKey AcntField) p <$> (askDBState kmAccount) 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 :: MonadFinance m => T.Text -> m (EitherErr (Key CurrencyR))
lookupCurrency c = lookupErr (DBKey CurField) c <$> (askDBState kmCurrency) 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) -- TODO this hashes twice (not that it really matters)
whenHash whenHash
:: (Hashable a, MonadFinance m) :: (Hashable a, MonadFinance m)

View File

@ -38,6 +38,7 @@ makeHaskellTypesWith
, MultipleConstructors "AmountType" "(./dhall/Types.dhall).AmountType" , MultipleConstructors "AmountType" "(./dhall/Types.dhall).AmountType"
, MultipleConstructors "BudgetCurrency" "(./dhall/Types.dhall).BudgetCurrency" , MultipleConstructors "BudgetCurrency" "(./dhall/Types.dhall).BudgetCurrency"
, SingleConstructor "Currency" "Currency" "(./dhall/Types.dhall).Currency" , SingleConstructor "Currency" "Currency" "(./dhall/Types.dhall).Currency"
, SingleConstructor "Tag" "Tag" "(./dhall/Types.dhall).Tag"
, SingleConstructor "Gregorian" "Gregorian" "(./dhall/Types.dhall).Gregorian" , SingleConstructor "Gregorian" "Gregorian" "(./dhall/Types.dhall).Gregorian"
, SingleConstructor "GregorianM" "GregorianM" "(./dhall/Types.dhall).GregorianM" , SingleConstructor "GregorianM" "GregorianM" "(./dhall/Types.dhall).GregorianM"
, SingleConstructor "Interval" "Interval" "(./dhall/Types.dhall).Interval" , SingleConstructor "Interval" "Interval" "(./dhall/Types.dhall).Interval"
@ -56,6 +57,7 @@ makeHaskellTypesWith
, SingleConstructor "Budget" "Budget" "(./dhall/Types.dhall).Budget" , SingleConstructor "Budget" "Budget" "(./dhall/Types.dhall).Budget"
, SingleConstructor "Transfer" "Transfer" "(./dhall/Types.dhall).Transfer" , SingleConstructor "Transfer" "Transfer" "(./dhall/Types.dhall).Transfer"
, SingleConstructor "Exchange" "Exchange" "(./dhall/Types.dhall).Exchange" , SingleConstructor "Exchange" "Exchange" "(./dhall/Types.dhall).Exchange"
, SingleConstructor "TaggedAcnt" "TaggedAcnt" "(./dhall/Types.dhall).TaggedAcnt"
, SingleConstructor "AcntSet" "AcntSet" "(./dhall/Types.dhall).AcntSet.Type" , SingleConstructor "AcntSet" "AcntSet" "(./dhall/Types.dhall).AcntSet.Type"
, SingleConstructor "ShadowMatch" "ShadowMatch" "(./dhall/Types.dhall).ShadowMatch.Type" , SingleConstructor "ShadowMatch" "ShadowMatch" "(./dhall/Types.dhall).ShadowMatch.Type"
, SingleConstructor "ShadowTransfer" "ShadowTransfer" "(./dhall/Types.dhall).ShadowTransfer" , SingleConstructor "ShadowTransfer" "ShadowTransfer" "(./dhall/Types.dhall).ShadowTransfer"
@ -70,6 +72,12 @@ deriving instance Lift Currency
deriving instance Hashable Currency deriving instance Hashable Currency
deriving instance Eq Tag
deriving instance Lift Tag
deriving instance Hashable Tag
deriving instance Eq TimeUnit deriving instance Eq TimeUnit
deriving instance Ord TimeUnit deriving instance Ord TimeUnit
@ -166,6 +174,12 @@ deriving instance Eq Budget
deriving instance Hashable Budget deriving instance Hashable Budget
deriving instance Eq TaggedAcnt
deriving instance Hashable TaggedAcnt
deriving instance Ord TaggedAcnt
deriving instance Eq Income deriving instance Eq Income
deriving instance Hashable Income deriving instance Hashable Income
@ -316,6 +330,7 @@ data Config_ a = Config_
, currencies :: ![Currency] , currencies :: ![Currency]
, statements :: ![Statement] , statements :: ![Statement]
, accounts :: !a , accounts :: !a
, tags :: ![Tag]
, sqlConfig :: !SqlConfig , sqlConfig :: !SqlConfig
} }
deriving (Generic) deriving (Generic)
@ -342,24 +357,30 @@ instance FromDhall a => FromDhall (Config_ a)
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- dhall type overrides (since dhall can't import types with parameters...yet) -- dhall type overrides (since dhall can't import types with parameters...yet)
-- TODO newtypes for these?
type AcntID = T.Text type AcntID = T.Text
type CurID = T.Text type CurID = T.Text
type TagID = T.Text
data Statement data Statement
= StmtManual !Manual = StmtManual !Manual
| StmtImport !Import | StmtImport !Import
deriving (Eq, Hashable, Generic, FromDhall) deriving (Eq, Hashable, Generic, FromDhall)
data Split a v c = Split data Split a v c t = Split
{ sAcnt :: !a { sAcnt :: !a
, sValue :: !v , sValue :: !v
, sCurrency :: !c , sCurrency :: !c
, sComment :: !T.Text , 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 data Tx s = Tx
{ txDescr :: !T.Text { txDescr :: !T.Text
@ -459,6 +480,10 @@ CurrencyR sql=currencies
symbol T.Text symbol T.Text
fullname T.Text fullname T.Text
deriving Show Eq deriving Show Eq
TagR sql=tags
symbol T.Text
fullname T.Text
deriving Show Eq
AccountR sql=accounts AccountR sql=accounts
name T.Text name T.Text
fullpath T.Text fullpath T.Text
@ -481,6 +506,9 @@ SplitR sql=splits
memo T.Text memo T.Text
value Rational value Rational
deriving Show Eq deriving Show Eq
TagRelationR sql=tag_relations
split SplitRId OnDeleteCascade
tag TagRId OnDeleteCascade
BudgetLabelR sql=budget_labels BudgetLabelR sql=budget_labels
split SplitRId OnDeleteCascade split SplitRId OnDeleteCascade
budgetName T.Text budgetName T.Text
@ -515,9 +543,12 @@ type AccountMap = M.Map AcntID (AccountRId, AcntSign, AcntType)
type CurrencyMap = M.Map CurID CurrencyRId type CurrencyMap = M.Map CurID CurrencyRId
type TagMap = M.Map TagID TagRId
data DBState = DBState data DBState = DBState
{ kmCurrency :: !CurrencyMap { kmCurrency :: !CurrencyMap
, kmAccount :: !AccountMap , kmAccount :: !AccountMap
, kmTag :: !TagMap
, kmBudgetInterval :: !Bounds , kmBudgetInterval :: !Bounds
, kmStatementInterval :: !Bounds , kmStatementInterval :: !Bounds
, kmNewCommits :: ![Int] , kmNewCommits :: ![Int]
@ -526,7 +557,7 @@ data DBState = DBState
type MappingT m = ReaderT DBState (SqlPersistT m) type MappingT m = ReaderT DBState (SqlPersistT m)
type KeySplit = Split AccountRId Rational CurrencyRId type KeySplit = Split AccountRId Rational CurrencyRId TagRId
type KeyTx = Tx KeySplit type KeyTx = Tx KeySplit
@ -619,9 +650,9 @@ accountSign IncomeT = Credit
accountSign LiabilityT = Credit accountSign LiabilityT = Credit
accountSign EquityT = 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 type RawTx = Tx RawSplit
@ -636,7 +667,7 @@ data BalanceType = TooFewSplits | NotOneBlank deriving (Show)
data MatchType = MatchNumeric | MatchText deriving (Show) data MatchType = MatchNumeric | MatchText deriving (Show)
data SplitIDType = AcntField | CurField deriving (Show) data SplitIDType = AcntField | CurField | TagField deriving (Show)
data LookupSuberr data LookupSuberr
= SplitIDField !SplitIDType = SplitIDField !SplitIDType

View File

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