REF use newtypes for ids and commits

This commit is contained in:
Nathan Dwarshuis 2023-07-16 00:10:49 -04:00
parent cd89597b1f
commit 81f09d1280
8 changed files with 55 additions and 87 deletions

View File

@ -203,7 +203,7 @@ runDumpAccountKeys c = do
mapM_ (uncurry printPair) ks mapM_ (uncurry printPair) ks
where where
printPair i p = do printPair i p = do
liftIO $ putStrLn $ T.unpack $ T.concat [acntPath2Text p, ": ", i] liftIO $ putStrLn $ T.unpack $ T.concat [acntPath2Text p, ": ", unAcntID i]
double x = (x, x) double x = (x, x)
runSync :: Int -> FilePath -> [FilePath] -> [FilePath] -> IO () runSync :: Int -> FilePath -> [FilePath] -> [FilePath] -> IO ()

View File

@ -37,7 +37,7 @@ readBudget
shadow <- addShadowTransfers bgtShadowTransfers txs shadow <- addShadowTransfers bgtShadowTransfers txs
return $ txs ++ shadow return $ txs ++ shadow
where where
c = CommitR (hash b) CTBudget c = CommitR (CommitHash $ hash b) CTBudget
acntRes = mapErrors isNotIncomeAcnt alloAcnts acntRes = mapErrors isNotIncomeAcnt alloAcnts
intAlloRes = combineError3 pre_ tax_ post_ (,,) intAlloRes = combineError3 pre_ tax_ post_ (,,)
pre_ = sortAllos bgtPretax pre_ = sortAllos bgtPretax
@ -107,10 +107,12 @@ readIncome
let gross = realFracToDecimal (cpPrec cp) incGross let gross = realFracToDecimal (cpPrec cp) incGross
foldDays (allocate cp gross) start days foldDays (allocate cp gross) start days
where where
incRes = isIncomeAcnt srcAcnt srcAcnt' = AcntID srcAcnt
destAcnt' = AcntID destAcnt
incRes = isIncomeAcnt srcAcnt'
nonIncRes = nonIncRes =
mapErrors isNotIncomeAcnt $ mapErrors isNotIncomeAcnt $
destAcnt destAcnt'
: (alloAcnt <$> incPretax) : (alloAcnt <$> incPretax)
++ (alloAcnt <$> incTaxes) ++ (alloAcnt <$> incTaxes)
++ (alloAcnt <$> incPosttax) ++ (alloAcnt <$> incPosttax)
@ -136,8 +138,8 @@ readIncome
let post = let post =
allocatePost precision aftertaxGross $ allocatePost precision aftertaxGross $
flatPost ++ concatMap (selectAllos day) intPost flatPost ++ concatMap (selectAllos day) intPost
let src = entry0 srcAcnt "gross income" srcTags let src = entry0 srcAcnt' "gross income" (TagID <$> srcTags)
let dest = entry0 destAcnt "balance after deductions" destTags let dest = entry0 destAcnt' "balance after deductions" (TagID <$> destTags)
let allos = allo2Trans <$> (pre ++ tax ++ post) let allos = allo2Trans <$> (pre ++ tax ++ post)
let primary = let primary =
EntrySet EntrySet
@ -256,8 +258,8 @@ allo2Trans FlatAllocation {faValue, faTo = TaggedAcnt {taAcnt, taTags}, faDesc}
Entry Entry
{ eValue = LinkDeferred (EntryFixed faValue) { eValue = LinkDeferred (EntryFixed faValue)
, eComment = faDesc , eComment = faDesc
, eAcnt = taAcnt , eAcnt = AcntID taAcnt
, eTags = taTags , eTags = TagID <$> taTags
} }
allocatePre allocatePre
@ -347,7 +349,7 @@ fromShadow tx ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stMatch
let es = entryPair stFrom stTo cur stDesc stRatio () let es = entryPair stFrom stTo cur stDesc stRatio ()
return $ if not sha then Nothing else Just es return $ if not sha then Nothing else Just es
where where
curRes = lookupCurrencyKey stCurrency curRes = lookupCurrencyKey (CurID stCurrency)
shaRes = liftExcept $ shadowMatches stMatch tx shaRes = liftExcept $ shadowMatches stMatch tx
shadowMatches :: TransferMatcher -> Tx CommitR -> InsertExcept Bool shadowMatches :: TransferMatcher -> Tx CommitR -> InsertExcept Bool
@ -369,13 +371,13 @@ shadowMatches TransferMatcher {tmFrom, tmTo, tmDate, tmVal} Tx {txPrimary, txDat
getAcntTo = getAcnt esTo getAcntTo = getAcnt esTo
getAcnt f = eAcnt . hesPrimary . f getAcnt f = eAcnt . hesPrimary . f
memberMaybe x AcntSet {asList, asInclude} = memberMaybe x AcntSet {asList, asInclude} =
(if asInclude then id else not) $ x `elem` asList (if asInclude then id else not) $ x `elem` (AcntID <$> asList)
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- random -- random
alloAcnt :: Allocation w v -> AcntID alloAcnt :: Allocation w v -> AcntID
alloAcnt = taAcnt . alloTo alloAcnt = AcntID . taAcnt . alloTo
type IntAllocations = type IntAllocations =
( [DaySpanAllocation PretaxValue] ( [DaySpanAllocation PretaxValue]

View File

@ -2,7 +2,6 @@ module Internal.Database
( runDB ( runDB
, readConfigState , readConfigState
, nukeTables , nukeTables
, updateHashes
, updateDBState , updateDBState
, tree2Records , tree2Records
, flattenAcntRoot , flattenAcntRoot
@ -179,7 +178,7 @@ makeTxCRUD
:: (MonadInsertError m, MonadSqlQuery m, Hashable a) :: (MonadInsertError m, MonadSqlQuery m, Hashable a)
=> ExistingConfig => ExistingConfig
-> [a] -> [a]
-> [Int] -> [CommitHash]
-> Bool -> Bool
-> m -> m
( CRUDOps ( CRUDOps
@ -190,7 +189,7 @@ makeTxCRUD
) )
makeTxCRUD existing newThings curThings scopeChanged = do makeTxCRUD existing newThings curThings scopeChanged = do
let (toDelHashes, overlap, toIns) = let (toDelHashes, overlap, toIns) =
setDiffWith (\a b -> hash b == a) curThings newThings setDiffWith (\a b -> hash b == unCommitHash a) curThings newThings
-- Check the overlap for rows with accounts/tags/currencies that -- Check the overlap for rows with accounts/tags/currencies that
-- won't exist on the next update. Those with invalid IDs will be set aside -- won't exist on the next update. Those with invalid IDs will be set aside
-- to delete and reinsert (which may also fail) later -- to delete and reinsert (which may also fail) later
@ -206,7 +205,7 @@ makeTxCRUD existing newThings curThings scopeChanged = do
toDelAll <- readTxIds toDelAllHashes toDelAll <- readTxIds toDelAllHashes
return $ CRUDOps toInsAll toRead toUpdate toDelAll return $ CRUDOps toInsAll toRead toUpdate toDelAll
readTxIds :: MonadSqlQuery m => [Int] -> m DeleteTxs readTxIds :: MonadSqlQuery m => [CommitHash] -> m DeleteTxs
readTxIds cs = do readTxIds cs = do
xs <- selectE $ do xs <- selectE $ do
(commits :& txs :& ess :& es :& ts) <- (commits :& txs :& ess :& es :& ts) <-
@ -249,18 +248,18 @@ makeTagMap :: [Entity TagR] -> TagMap
makeTagMap = M.fromList . fmap (\e -> (tagRSymbol $ entityVal e, entityKey e)) makeTagMap = M.fromList . fmap (\e -> (tagRSymbol $ entityVal e, entityKey e))
tag2Record :: Tag -> Entity TagR tag2Record :: Tag -> Entity TagR
tag2Record t@Tag {tagID, tagDesc} = Entity (toKey t) $ TagR tagID tagDesc tag2Record t@Tag {tagID, tagDesc} = Entity (toKey t) $ TagR (TagID tagID) tagDesc
currency2Record :: Currency -> Entity CurrencyR currency2Record :: Currency -> Entity CurrencyR
currency2Record c@Currency {curSymbol, curFullname, curPrecision} = currency2Record c@Currency {curSymbol, curFullname, curPrecision} =
Entity (toKey c) $ CurrencyR curSymbol curFullname (fromIntegral curPrecision) Entity (toKey c) $ CurrencyR (CurID curSymbol) curFullname (fromIntegral curPrecision)
readCurrentIds :: PersistEntity a => MonadSqlQuery m => m [Key a] readCurrentIds :: PersistEntity a => MonadSqlQuery m => m [Key a]
readCurrentIds = fmap (E.unValue <$>) $ selectE $ do readCurrentIds = fmap (E.unValue <$>) $ selectE $ do
rs <- E.from E.table rs <- E.from E.table
return (rs ^. E.persistIdField) return (rs ^. E.persistIdField)
readCurrentCommits :: MonadSqlQuery m => m ([Int], [Int], [Int]) readCurrentCommits :: MonadSqlQuery m => m ([CommitHash], [CommitHash], [CommitHash])
readCurrentCommits = do readCurrentCommits = do
xs <- selectE $ do xs <- selectE $ do
rs <- E.from E.table rs <- E.from E.table
@ -290,14 +289,6 @@ findDelete f xs = case break f xs of
(ys, []) -> (Nothing, ys) (ys, []) -> (Nothing, ys)
(ys, z : zs) -> (Just z, ys ++ zs) (ys, z : zs) -> (Just z, ys ++ zs)
nukeDBHash :: MonadSqlQuery m => Int -> m ()
nukeDBHash h = deleteE $ do
c <- E.from E.table
E.where_ (c ^. CommitRHash ==. E.val h)
nukeDBHashes :: MonadSqlQuery m => [Int] -> m ()
nukeDBHashes = mapM_ nukeDBHash
dumpTbl :: (MonadSqlQuery m, PersistEntity r) => m [Entity r] dumpTbl :: (MonadSqlQuery m, PersistEntity r) => m [Entity r]
dumpTbl = selectE $ E.from E.table dumpTbl = selectE $ E.from E.table
@ -355,7 +346,7 @@ paths2IDs =
-- none of these errors should fire assuming that input is sorted and unique -- none of these errors should fire assuming that input is sorted and unique
trimNames :: [NonEmpty T.Text] -> [AcntID] trimNames :: [NonEmpty T.Text] -> [AcntID]
trimNames = fmap (T.intercalate "_") . go [] trimNames = fmap (AcntID . T.intercalate "_") . go []
where where
go :: [T.Text] -> [NonEmpty T.Text] -> [[T.Text]] go :: [T.Text] -> [NonEmpty T.Text] -> [[T.Text]]
go prev = concatMap (go' prev) . groupNonEmpty go prev = concatMap (go' prev) . groupNonEmpty
@ -391,9 +382,6 @@ makeAcntMap =
indexAcntRoot :: AccountRoot -> ([Entity AccountR], [Entity AccountPathR]) indexAcntRoot :: AccountRoot -> ([Entity AccountR], [Entity AccountPathR])
indexAcntRoot = bimap concat concat . L.unzip . fmap (uncurry tree2Records) . flattenAcntRoot indexAcntRoot = bimap concat concat . L.unzip . fmap (uncurry tree2Records) . flattenAcntRoot
updateHashes :: (MonadSqlQuery m) => DBUpdates -> m ()
updateHashes DBUpdates {duOldCommits} = nukeDBHashes duOldCommits
updateCD updateCD
:: ( MonadSqlQuery m :: ( MonadSqlQuery m
, PersistRecordBackend a SqlBackend , PersistRecordBackend a SqlBackend
@ -425,7 +413,11 @@ updateDBState = do
h <- asks csHistoryScope h <- asks csHistoryScope
repsertE (E.toSqlKey 1) $ ConfigStateR h b repsertE (E.toSqlKey 1) $ ConfigStateR h b
readInvalidIds :: MonadSqlQuery m => ExistingConfig -> [(Int, a)] -> m ([Int], [(Int, a)]) readInvalidIds
:: MonadSqlQuery m
=> ExistingConfig
-> [(CommitHash, a)]
-> m ([CommitHash], [(CommitHash, a)])
readInvalidIds ExistingConfig {ecAccounts, ecCurrencies, ecTags} xs = do readInvalidIds ExistingConfig {ecAccounts, ecCurrencies, ecTags} xs = do
rs <- selectE $ do rs <- selectE $ do
(commits :& _ :& entrysets :& entries :& tags) <- (commits :& _ :& entrysets :& entries :& tags) <-
@ -462,7 +454,7 @@ readInvalidIds ExistingConfig {ecAccounts, ecCurrencies, ecTags} xs = do
readUpdates readUpdates
:: (MonadInsertError m, MonadSqlQuery m) :: (MonadInsertError m, MonadSqlQuery m)
=> [Int] => [CommitHash]
-> m ([ReadEntry], [Either TotalUpdateEntrySet FullUpdateEntrySet]) -> m ([ReadEntry], [Either TotalUpdateEntrySet FullUpdateEntrySet])
readUpdates hashes = do readUpdates hashes = do
xs <- selectE $ do xs <- selectE $ do
@ -729,9 +721,6 @@ updateTx UpdateEntry {ueID, ueValue} = update ueID [EntryRValue =. v]
where where
v = toRational $ unStaticValue ueValue v = toRational $ unStaticValue ueValue
deleteE :: (MonadSqlQuery m) => E.SqlQuery () -> m ()
deleteE q = unsafeLiftSql "esqueleto-delete" (E.delete q)
repsertE :: (MonadSqlQuery m, PersistRecordBackend r SqlBackend) => Key r -> r -> m () repsertE :: (MonadSqlQuery m, PersistRecordBackend r SqlBackend) => Key r -> r -> m ()
repsertE k r = unsafeLiftSql "esqueleto-repsert" (E.repsert k r) repsertE k r = unsafeLiftSql "esqueleto-repsert" (E.repsert k r)

View File

@ -44,7 +44,7 @@ readHistTransfer ht = do
bounds <- askDBState (unHSpan . csHistoryScope) bounds <- askDBState (unHSpan . csHistoryScope)
expandTransfer c historyName bounds ht expandTransfer c historyName bounds ht
where where
c = CommitR (hash ht) CTHistoryTransfer c = CommitR (CommitHash $ hash ht) CTHistoryTransfer
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Statements -- Statements
@ -59,7 +59,7 @@ readHistStmt root i = do
bounds <- askDBState (unHSpan . csHistoryScope) bounds <- askDBState (unHSpan . csHistoryScope)
return $ filter (inDaySpan bounds . txDate) $ fmap (\t -> t {txCommit = c}) bs return $ filter (inDaySpan bounds . txDate) $ fmap (\t -> t {txCommit = c}) bs
where where
c = CommitR (hash i) CTHistoryStatement c = CommitR (CommitHash $ hash i) CTHistoryStatement
-- TODO this probably won't scale well (pipes?) -- TODO this probably won't scale well (pipes?)
readImport :: (MonadUnliftIO m, MonadFinance m) => FilePath -> Statement -> m [Tx ()] readImport :: (MonadUnliftIO m, MonadFinance m) => FilePath -> Statement -> m [Tx ()]
@ -405,18 +405,18 @@ resolveValue prec TxRecord {trOther, trAmount} s = case s of
where where
go = realFracToDecimal prec go = realFracToDecimal prec
resolveAcnt :: TxRecord -> EntryAcnt -> InsertExcept T.Text resolveAcnt :: TxRecord -> EntryAcnt -> InsertExcept AcntID
resolveAcnt = resolveEntryField AcntField resolveAcnt r e = AcntID <$> resolveEntryField AcntField r (unAcntID <$> e)
resolveCurrency :: CurrencyMap -> TxRecord -> EntryCur -> InsertExcept CurrencyPrec resolveCurrency :: CurrencyMap -> TxRecord -> EntryCur -> InsertExcept CurrencyPrec
resolveCurrency m r c = do resolveCurrency m r c = do
i <- resolveEntryField CurField r c i <- resolveEntryField CurField r (unCurID <$> c)
case M.lookup i m of case M.lookup (CurID i) m of
Just k -> return k Just k -> return k
-- TODO this should be its own error (I think) -- TODO this should be its own error (I think)
Nothing -> throwError $ InsertException [LookupError (EntryIDField CurField) undefined] Nothing -> throwError $ InsertException [LookupError (EntryIDField CurField) undefined]
resolveEntryField :: EntryIDType -> TxRecord -> EntryAcnt -> InsertExcept T.Text resolveEntryField :: EntryIDType -> TxRecord -> EntryTextGetter T.Text -> InsertExcept T.Text
resolveEntryField t TxRecord {trOther = o} s = case s of resolveEntryField t TxRecord {trOther = o} s = case s of
ConstT p -> return p ConstT p -> return p
LookupT f -> lookup_ f o LookupT f -> lookup_ f o

View File

@ -15,12 +15,11 @@ import qualified RIO.NonEmpty as NE
import qualified RIO.Text as T import qualified RIO.Text as T
import RIO.Time import RIO.Time
-- TODO use newtypes for all the different numbers so they don't get mixed up
share share
[mkPersist sqlSettings, mkMigrate "migrateAll"] [mkPersist sqlSettings, mkMigrate "migrateAll"]
[persistLowerCase| [persistLowerCase|
CommitR sql=commits CommitR sql=commits
hash Int hash CommitHash
type ConfigType type ConfigType
UniqueCommitHash hash UniqueCommitHash hash
deriving Show Eq Ord deriving Show Eq Ord
@ -85,6 +84,9 @@ TagRelationR sql=tag_relations
type DaySpan = (Day, Int) type DaySpan = (Day, Int)
newtype CommitHash = CommitHash {unCommitHash :: Int}
deriving newtype (Show, Eq, Num, Ord, PersistField, PersistFieldSql)
newtype BudgetSpan = BudgetSpan {unBSpan :: DaySpan} newtype BudgetSpan = BudgetSpan {unBSpan :: DaySpan}
deriving newtype (Show, Eq, PersistField, PersistFieldSql) deriving newtype (Show, Eq, PersistField, PersistFieldSql)

View File

@ -21,6 +21,7 @@ import qualified RIO.Map as M
import qualified RIO.Text as T import qualified RIO.Text as T
import Text.Regex.TDFA import Text.Regex.TDFA
-- TODO find a way to conventiently make TaggedAcnt use my newtypes
makeHaskellTypesWith makeHaskellTypesWith
(defaultGenerateOptions {generateToDhallInstance = False, generateFromDhallInstance = False}) (defaultGenerateOptions {generateToDhallInstance = False, generateFromDhallInstance = False})
[ MultipleConstructors "SqlConfig" "(./dhall/Types.dhall).SqlConfig" [ MultipleConstructors "SqlConfig" "(./dhall/Types.dhall).SqlConfig"
@ -231,7 +232,8 @@ deriving instance Hashable TaggedAcnt
deriving instance Ord TaggedAcnt deriving instance Ord TaggedAcnt
type CurID = T.Text newtype CurID = CurID {unCurID :: T.Text}
deriving newtype (Eq, Show, Ord, Hashable, FromDhall, PersistField, PersistFieldSql)
data Income = Income data Income = Income
{ incGross :: Double { incGross :: Double
@ -411,9 +413,11 @@ 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? -- TODO newtypes for these?
type AcntID = T.Text newtype AcntID = AcntID {unAcntID :: T.Text}
deriving newtype (Eq, Show, Ord, Hashable, FromDhall, PersistField, PersistFieldSql)
type TagID = T.Text newtype TagID = TagID {unTagID :: T.Text}
deriving newtype (Eq, Show, Ord, Hashable, FromDhall, PersistField, PersistFieldSql)
data History data History
= HistTransfer !PairedTransfer = HistTransfer !PairedTransfer
@ -465,7 +469,7 @@ data EntryTextGetter t
| LookupT !T.Text | LookupT !T.Text
| MapT !(FieldMap T.Text t) | MapT !(FieldMap T.Text t)
| Map2T !(FieldMap (T.Text, T.Text) t) | Map2T !(FieldMap (T.Text, T.Text) t)
deriving (Eq, Generic, Hashable, Show, FromDhall) deriving (Eq, Generic, Hashable, Show, FromDhall, Functor)
type EntryCur = EntryTextGetter CurID type EntryCur = EntryTextGetter CurID

View File

@ -82,35 +82,6 @@ data CRUDOps c r u d = CRUDOps
} }
deriving (Show) deriving (Show)
data DBState_ = DBState_
{ dbsCurrencyMap :: !CurrencyMap
, dbsAccountMap :: !AccountMap
, dbsTagMap :: !TagMap
, dbsBudgetInterval :: !DaySpan
, dbsHistoryInterval :: !DaySpan
, dbsNewCommits :: ![Int]
}
deriving (Show)
data DBState = DBState
{ kmCurrency :: !CurrencyMap
, kmAccount :: !AccountMap
, kmTag :: !TagMap
, kmBudgetInterval :: !DaySpan
, kmStatementInterval :: !DaySpan
, kmNewCommits :: ![Int]
}
deriving (Show)
data DBUpdates = DBUpdates
{ duOldCommits :: ![Int]
, duNewTagIds :: ![Entity TagR]
, duNewAcntPaths :: ![AccountPathR]
, duNewAcntIds :: ![Entity AccountR]
, duNewCurrencyIds :: ![Entity CurrencyR]
}
deriving (Show)
data DBDeferred data DBDeferred
= DBEntryLinked Natural Double = DBEntryLinked Natural Double
| DBEntryBalance Decimal | DBEntryBalance Decimal

View File

@ -432,7 +432,7 @@ showError other = case other of
(AccountError a ts) -> (AccountError a ts) ->
[ T.unwords [ T.unwords
[ "account type of key" [ "account type of key"
, singleQuote a , singleQuote $ unAcntID a
, "is not one of:" , "is not one of:"
, ts_ , ts_
] ]
@ -496,7 +496,7 @@ showError other = case other of
[ "No credit entry for index" [ "No credit entry for index"
, singleQuote $ tshow lngIndex , singleQuote $ tshow lngIndex
, "for entry with account" , "for entry with account"
, singleQuote eAcnt , singleQuote $ unAcntID eAcnt
, "on" , "on"
, tshow day , tshow day
] ]
@ -504,7 +504,7 @@ showError other = case other of
(RoundError cur) -> (RoundError cur) ->
[ T.unwords [ T.unwords
[ "Could not look up precision for currency" [ "Could not look up precision for currency"
, singleQuote cur , singleQuote $ unCurID cur
] ]
] ]
@ -637,20 +637,20 @@ lookupAccountType = fmap snd . lookupAccount
lookupCurrency :: (MonadInsertError m, MonadFinance m) => CurID -> m CurrencyPrec lookupCurrency :: (MonadInsertError m, MonadFinance m) => CurID -> m CurrencyPrec
lookupCurrency = lookupFinance CurField csCurrencyMap lookupCurrency = lookupFinance CurField csCurrencyMap
lookupCurrencyKey :: (MonadInsertError m, MonadFinance m) => AcntID -> m CurrencyRId lookupCurrencyKey :: (MonadInsertError m, MonadFinance m) => CurID -> m CurrencyRId
lookupCurrencyKey = fmap cpID . lookupCurrency lookupCurrencyKey = fmap cpID . lookupCurrency
lookupCurrencyPrec :: (MonadInsertError m, MonadFinance m) => AcntID -> m Precision lookupCurrencyPrec :: (MonadInsertError m, MonadFinance m) => CurID -> m Precision
lookupCurrencyPrec = fmap cpPrec . lookupCurrency lookupCurrencyPrec = fmap cpPrec . lookupCurrency
lookupTag :: (MonadInsertError m, MonadFinance m) => TagID -> m TagRId lookupTag :: (MonadInsertError m, MonadFinance m) => TagID -> m TagRId
lookupTag = lookupFinance TagField csTagMap lookupTag = lookupFinance TagField csTagMap
lookupFinance lookupFinance
:: (MonadInsertError m, MonadFinance m) :: (MonadInsertError m, MonadFinance m, Ord k, Show k)
=> EntryIDType => EntryIDType
-> (ConfigState -> M.Map T.Text a) -> (ConfigState -> M.Map k a)
-> T.Text -> k
-> m a -> m a
lookupFinance t f c = (liftExcept . lookupErr (DBKey t) c) =<< askDBState f lookupFinance t f c = (liftExcept . lookupErr (DBKey t) c) =<< askDBState f
@ -1045,8 +1045,8 @@ entryPair (TaggedAcnt fa fts) (TaggedAcnt ta tts) curid com totval val1 =
EntrySet EntrySet
{ esCurrency = curid { esCurrency = curid
, esTotalValue = totval , esTotalValue = totval
, esFrom = halfEntry fa fts val1 , esFrom = halfEntry (AcntID fa) (TagID <$> fts) val1
, esTo = halfEntry ta tts () , esTo = halfEntry (AcntID ta) (TagID <$> tts) ()
} }
where where
halfEntry :: AcntID -> [TagID] -> v -> HalfEntrySet v v0 halfEntry :: AcntID -> [TagID] -> v -> HalfEntrySet v v0