REF clean up useless types

This commit is contained in:
Nathan Dwarshuis 2023-07-16 12:51:39 -04:00
parent ad5e4a0748
commit cafc066881
6 changed files with 56 additions and 104 deletions

View File

@ -231,11 +231,11 @@ runSync threads c bs hs = do
-- the database, don't read it but record the commit so we can update it. -- the database, don't read it but record the commit so we can update it.
toIns <- toIns <-
flip runReaderT state $ do flip runReaderT state $ do
(CRUDOps hSs _ _ _) <- askDBState csHistStmts (CRUDOps hSs _ _ _) <- asks csHistStmts
hSs' <- mapErrorsIO (readHistStmt root) hSs hSs' <- mapErrorsIO (readHistStmt root) hSs
(CRUDOps hTs _ _ _) <- askDBState csHistTrans (CRUDOps hTs _ _ _) <- asks csHistTrans
hTs' <- liftIOExceptT $ mapErrors readHistTransfer hTs hTs' <- liftIOExceptT $ mapErrors readHistTransfer hTs
(CRUDOps bTs _ _ _) <- askDBState csBudgets (CRUDOps bTs _ _ _) <- asks csBudgets
bTs' <- liftIOExceptT $ mapErrors readBudget bTs bTs' <- liftIOExceptT $ mapErrors readBudget bTs
return $ concat $ hSs' ++ hTs' ++ bTs' return $ concat $ hSs' ++ hTs' ++ bTs'
@ -244,9 +244,9 @@ runSync threads c bs hs = do
-- NOTE this must come first (unless we defer foreign keys) -- NOTE this must come first (unless we defer foreign keys)
updateDBState updateDBState
res <- runExceptT $ do res <- runExceptT $ do
(CRUDOps _ bRs bUs _) <- askDBState csBudgets (CRUDOps _ bRs bUs _) <- asks csBudgets
(CRUDOps _ tRs tUs _) <- askDBState csHistTrans (CRUDOps _ tRs tUs _) <- asks csHistTrans
(CRUDOps _ sRs sUs _) <- askDBState csHistStmts (CRUDOps _ sRs sUs _) <- asks csHistStmts
let ebs = fmap ToUpdate (bUs ++ tUs ++ sUs) ++ fmap ToRead (bRs ++ tRs ++ sRs) ++ fmap ToInsert toIns let ebs = fmap ToUpdate (bUs ++ tUs ++ sUs) ++ fmap ToRead (bRs ++ tRs ++ sRs) ++ fmap ToInsert toIns
insertAll ebs insertAll ebs
-- NOTE this rerunnable thing is a bit misleading; fromEither will throw -- NOTE this rerunnable thing is a bit misleading; fromEither will throw
@ -259,8 +259,6 @@ runSync threads c bs hs = do
liftIO $ mapM_ TI.putStrLn $ concatMap showError es liftIO $ mapM_ TI.putStrLn $ concatMap showError es
exitFailure exitFailure
-- showBalances
readConfig :: MonadUnliftIO m => FilePath -> m Config readConfig :: MonadUnliftIO m => FilePath -> m Config
readConfig = fmap unfix . readDhall readConfig = fmap unfix . readDhall

View File

@ -49,7 +49,7 @@ readBudget
++ (alloAcnt <$> bgtTax) ++ (alloAcnt <$> bgtTax)
++ (alloAcnt <$> bgtPosttax) ++ (alloAcnt <$> bgtPosttax)
getSpan = do getSpan = do
globalSpan <- askDBState (unBSpan . csBudgetScope) globalSpan <- asks (unBSpan . csBudgetScope)
case bgtInterval of case bgtInterval of
Nothing -> return $ Just globalSpan Nothing -> return $ Just globalSpan
Just bi -> do Just bi -> do
@ -253,20 +253,22 @@ selectAllos day Allocation {alloAmts, alloTo} =
, faDesc = amtDesc , faDesc = amtDesc
} }
allo2Trans :: FlatAllocation Decimal -> Entry AcntID LinkDeferred TagID allo2Trans :: FlatAllocation Decimal -> Entry AcntID EntryLink TagID
allo2Trans FlatAllocation {faValue, faTo = TaggedAcnt {taAcnt, taTags}, faDesc} = allo2Trans FlatAllocation {faValue, faTo = TaggedAcnt {taAcnt, taTags}, faDesc} =
Entry Entry
{ eValue = LinkDeferred (EntryFixed faValue) { eValue = LinkValue (EntryFixed faValue)
, eComment = faDesc , eComment = faDesc
, eAcnt = AcntID taAcnt , eAcnt = AcntID taAcnt
, eTags = TagID <$> taTags , eTags = TagID <$> taTags
} }
type PreDeductions = M.Map T.Text Decimal
allocatePre allocatePre
:: Precision :: Precision
-> Decimal -> Decimal
-> [FlatAllocation PretaxValue] -> [FlatAllocation PretaxValue]
-> (M.Map T.Text Decimal, [FlatAllocation Decimal]) -> (PreDeductions, [FlatAllocation Decimal])
allocatePre precision gross = L.mapAccumR go M.empty allocatePre precision gross = L.mapAccumR go M.empty
where where
go m f@FlatAllocation {faValue = PretaxValue {preCategory, preValue, prePercent}} = go m f@FlatAllocation {faValue = PretaxValue {preCategory, preValue, prePercent}} =
@ -279,7 +281,7 @@ allocatePre precision gross = L.mapAccumR go M.empty
allocateTax allocateTax
:: Precision :: Precision
-> Decimal -> Decimal
-> M.Map T.Text Decimal -> PreDeductions
-> PeriodScaler -> PeriodScaler
-> [FlatAllocation TaxValue] -> [FlatAllocation TaxValue]
-> [FlatAllocation Decimal] -> [FlatAllocation Decimal]

View File

@ -674,7 +674,7 @@ makeUnkUE k e = makeUE k e ()
insertAll insertAll
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m) :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
=> [EntryBin] => [EntryCRU]
-> m () -> m ()
insertAll ebs = do insertAll ebs = do
(toUpdate, toInsert) <- balanceTxs ebs (toUpdate, toInsert) <- balanceTxs ebs
@ -692,7 +692,7 @@ insertTx c InsertTx {itxDate, itxDescr, itxEntrySets, itxBudget, itxPriority} =
insertEntrySet tk i InsertEntrySet {iesCurrency, iesFromEntries, iesToEntries} = do insertEntrySet tk i InsertEntrySet {iesCurrency, iesFromEntries, iesToEntries} = do
let fs = NE.toList iesFromEntries let fs = NE.toList iesFromEntries
let ts = NE.toList iesToEntries let ts = NE.toList iesToEntries
let rebalance = any (isJust . ieDeferred) (fs ++ ts) let rebalance = any (isJust . ieCached) (fs ++ ts)
esk <- insert $ EntrySetR tk iesCurrency i rebalance esk <- insert $ EntrySetR tk iesCurrency i rebalance
mapM_ (uncurry (go esk)) $ zip [0 ..] ts ++ zip (negate <$> [1 ..]) fs mapM_ (uncurry (go esk)) $ zip [0 ..] ts ++ zip (negate <$> [1 ..]) fs
go k i e = void $ insertEntry k i e go k i e = void $ insertEntry k i e
@ -703,17 +703,17 @@ insertEntry
i i
InsertEntry InsertEntry
{ ieEntry = Entry {eValue, eTags, eAcnt, eComment} { ieEntry = Entry {eValue, eTags, eAcnt, eComment}
, ieDeferred , ieCached
} = } =
do do
ek <- insert $ EntryR k eAcnt eComment (toRational eValue) i cval ctype deflink ek <- insert $ EntryR k eAcnt eComment (toRational eValue) i cval ctype deflink
mapM_ (insert_ . TagRelationR ek) eTags mapM_ (insert_ . TagRelationR ek) eTags
return ek return ek
where where
(cval, ctype, deflink) = case ieDeferred of (cval, ctype, deflink) = case ieCached of
(Just (DBEntryLinked x s)) -> (Just (toRational s), Nothing, Just $ fromIntegral x) (Just (CachedLink x s)) -> (Just (toRational s), Nothing, Just x)
(Just (DBEntryBalance b)) -> (Just (toRational b), Just TBalance, Nothing) (Just (CachedBalance b)) -> (Just (toRational b), Just TBalance, Nothing)
(Just (DBEntryPercent p)) -> (Just (toRational p), Just TPercent, Nothing) (Just (CachedPercent p)) -> (Just (toRational p), Just TPercent, Nothing)
Nothing -> (Nothing, Just TFixed, Nothing) Nothing -> (Nothing, Just TFixed, Nothing)
updateTx :: MonadSqlQuery m => UEBalanced -> m () updateTx :: MonadSqlQuery m => UEBalanced -> m ()

View File

@ -41,7 +41,7 @@ readHistTransfer
=> PairedTransfer => PairedTransfer
-> m [Tx CommitR] -> m [Tx CommitR]
readHistTransfer ht = do readHistTransfer ht = do
bounds <- askDBState (unHSpan . csHistoryScope) bounds <- asks (unHSpan . csHistoryScope)
expandTransfer c historyName bounds ht expandTransfer c historyName bounds ht
where where
c = CommitR (CommitHash $ hash ht) CTHistoryTransfer c = CommitR (CommitHash $ hash ht) CTHistoryTransfer
@ -56,7 +56,7 @@ readHistStmt
-> m [Tx CommitR] -> m [Tx CommitR]
readHistStmt root i = do readHistStmt root i = do
bs <- readImport root i bs <- readImport root i
bounds <- askDBState (unHSpan . csHistoryScope) bounds <- asks (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 (CommitHash $ hash i) CTHistoryStatement c = CommitR (CommitHash $ hash i) CTHistoryStatement
@ -317,7 +317,7 @@ toTx
} }
where where
curRes = do curRes = do
m <- askDBState csCurrencyMap m <- asks csCurrencyMap
cur <- liftInner $ resolveCurrency m r tgCurrency cur <- liftInner $ resolveCurrency m r tgCurrency
let prec = cpPrec cur let prec = cpPrec cur
let fromRes = liftInner $ resolveHalfEntry resolveFromValue prec r () tgFrom let fromRes = liftInner $ resolveHalfEntry resolveFromValue prec r () tgFrom
@ -331,7 +331,7 @@ resolveSubGetter
-> TxSubGetter -> TxSubGetter
-> InsertExceptT m SecondayEntrySet -> InsertExceptT m SecondayEntrySet
resolveSubGetter r TxSubGetter {tsgFrom, tsgTo, tsgValue, tsgCurrency} = do resolveSubGetter r TxSubGetter {tsgFrom, tsgTo, tsgValue, tsgCurrency} = do
m <- askDBState csCurrencyMap m <- asks csCurrencyMap
cur <- liftInner $ resolveCurrency m r tsgCurrency cur <- liftInner $ resolveCurrency m r tsgCurrency
let prec = cpPrec cur let prec = cpPrec cur
let toRes = resolveHalfEntry resolveToValue prec r () tsgTo let toRes = resolveHalfEntry resolveToValue prec r () tsgTo
@ -391,9 +391,9 @@ resolveEntry f prec r s@Entry {eAcnt, eValue} =
resolveFromValue :: Precision -> TxRecord -> EntryNumGetter -> InsertExcept EntryValue resolveFromValue :: Precision -> TxRecord -> EntryNumGetter -> InsertExcept EntryValue
resolveFromValue = resolveValue resolveFromValue = resolveValue
resolveToValue :: Precision -> TxRecord -> LinkedEntryNumGetter -> InsertExcept LinkDeferred resolveToValue :: Precision -> TxRecord -> LinkedEntryNumGetter -> InsertExcept EntryLink
resolveToValue _ _ (Linked l) = return $ LinkIndex l resolveToValue _ _ (Linked l) = return $ LinkIndex l
resolveToValue prec r (Getter g) = LinkDeferred <$> resolveValue prec r g resolveToValue prec r (Getter g) = LinkValue <$> resolveValue prec r g
resolveValue :: Precision -> TxRecord -> EntryNumGetter -> InsertExcept EntryValue resolveValue :: Precision -> TxRecord -> EntryNumGetter -> InsertExcept EntryValue
resolveValue prec TxRecord {trOther, trAmount} s = case s of resolveValue prec TxRecord {trOther, trAmount} s = case s of

View File

@ -75,10 +75,10 @@ data CRUDOps c r u d = CRUDOps
} }
deriving (Show) deriving (Show)
data DBDeferred data CachedEntry
= DBEntryLinked Natural Double = CachedLink EntryIndex LinkScale
| DBEntryBalance Decimal | CachedBalance Decimal
| DBEntryPercent Double | CachedPercent Double
data ReadEntry = ReadEntry data ReadEntry = ReadEntry
{ reCurrency :: !CurrencyRId { reCurrency :: !CurrencyRId
@ -98,12 +98,10 @@ data UpdateEntry i v = UpdateEntry
} }
deriving (Show) deriving (Show)
data CurrencyRound = CurrencyRound CurID Natural
deriving instance Functor (UpdateEntry i) deriving instance Functor (UpdateEntry i)
newtype LinkScale = LinkScale {unLinkScale :: Decimal} newtype LinkScale = LinkScale {unLinkScale :: Double}
deriving newtype (Num, Show) deriving newtype (Num, Show, Eq, Ord, Real, Fractional)
newtype StaticValue = StaticValue {unStaticValue :: Decimal} newtype StaticValue = StaticValue {unStaticValue :: Decimal}
deriving newtype (Num, Show) deriving newtype (Num, Show)
@ -139,18 +137,13 @@ type TotalUpdateEntrySet = UpdateEntrySet (UEBlank, [UELink]) Decimal
type FullUpdateEntrySet = UpdateEntrySet (Either UE_RO (UEUnk, [UELink])) () type FullUpdateEntrySet = UpdateEntrySet (Either UE_RO (UEUnk, [UELink])) ()
data EntryBin data EntryCRU
= ToUpdate (Either TotalUpdateEntrySet FullUpdateEntrySet) = ToUpdate (Either TotalUpdateEntrySet FullUpdateEntrySet)
| ToRead ReadEntry | ToRead ReadEntry
| ToInsert (Tx CommitR) | ToInsert (Tx CommitR)
type TreeR = Tree ([T.Text], AccountRId)
type MonadFinance = MonadReader ConfigState type MonadFinance = MonadReader ConfigState
askDBState :: MonadFinance m => (ConfigState -> a) -> m a
askDBState = asks
------------------------------------------------------------------------------- -------------------------------------------------------------------------------
-- misc -- misc
@ -190,13 +183,13 @@ type TotalEntrySet v0 vpN vtN = EntrySet v0 () vpN vtN
type FullEntrySet vp0 vpN vtN = EntrySet () vp0 vpN vtN type FullEntrySet vp0 vpN vtN = EntrySet () vp0 vpN vtN
type PrimaryEntrySet = TotalEntrySet Decimal EntryValue LinkDeferred type PrimaryEntrySet = TotalEntrySet Decimal EntryValue EntryLink
type SecondayEntrySet = FullEntrySet EntryValue EntryValue LinkDeferred type SecondayEntrySet = FullEntrySet EntryValue EntryValue EntryLink
type TransferEntrySet = SecondayEntrySet type TransferEntrySet = SecondayEntrySet
type ShadowEntrySet = TotalEntrySet Double EntryValue LinkDeferred type ShadowEntrySet = TotalEntrySet Double EntryValue EntryLink
data TxCommit = HistoryCommit CommitR | BudgetCommit CommitR T.Text data TxCommit = HistoryCommit CommitR | BudgetCommit CommitR T.Text
deriving (Eq, Ord, Show) deriving (Eq, Ord, Show)
@ -213,7 +206,7 @@ data Tx k = Tx
deriving (Generic, Show) deriving (Generic, Show)
data InsertEntry = InsertEntry data InsertEntry = InsertEntry
{ ieDeferred :: !(Maybe DBDeferred) { ieCached :: !(Maybe CachedEntry)
, ieEntry :: !(Entry AccountRId Decimal TagRId) , ieEntry :: !(Entry AccountRId Decimal TagRId)
} }
@ -233,18 +226,13 @@ data InsertTx = InsertTx
} }
deriving (Generic) deriving (Generic)
data Deferred a = Deferred Bool a
deriving (Show, Functor, Foldable, Traversable)
data EntryValue_ a = EntryValue_ TransferType a data EntryValue_ a = EntryValue_ TransferType a
deriving (Show, Functor, Foldable, Traversable) deriving (Show, Functor, Foldable, Traversable)
data EntryValue = EntryFixed Decimal | EntryPercent Double | EntryBalance Decimal data EntryValue = EntryFixed Decimal | EntryPercent Double | EntryBalance Decimal
deriving (Show, Eq, Ord) deriving (Show, Eq, Ord)
data LinkDeferred data EntryLink = LinkValue EntryValue | LinkIndex LinkedNumGetter
= LinkDeferred EntryValue
| LinkIndex LinkedNumGetter
deriving (Show) deriving (Show)
data MatchRes a = MatchPass !a | MatchFail | MatchSkip data MatchRes a = MatchPass !a | MatchFail | MatchSkip
@ -302,13 +290,6 @@ type InsertExceptT = ExceptT InsertException
type InsertExcept = InsertExceptT Identity type InsertExcept = InsertExceptT Identity
data XGregorian = XGregorian
{ xgYear :: !Int
, xgMonth :: !Int
, xgDay :: !Int
, xgDayOfWeek :: !Int
}
type MatchRe = StatementParser (T.Text, Regex) type MatchRe = StatementParser (T.Text, Regex)
type TxOptsRe = TxOpts (T.Text, Regex) type TxOptsRe = TxOpts (T.Text, Regex)

View File

@ -30,9 +30,7 @@ module Internal.Utils
, showError , showError
, tshow , tshow
, lookupErr , lookupErr
, gregorians
, uncurry3 , uncurry3
, xGregToDay
, dateMatches , dateMatches
, valMatches , valMatches
, lookupAccount , lookupAccount
@ -152,7 +150,7 @@ askDays
-> Maybe Interval -> Maybe Interval
-> m [Day] -> m [Day]
askDays dp i = do askDays dp i = do
globalSpan <- askDBState (unBSpan . csBudgetScope) globalSpan <- asks (unBSpan . csBudgetScope)
case i of case i of
Just i' -> do Just i' -> do
localSpan <- liftExcept $ resolveDaySpan i' localSpan <- liftExcept $ resolveDaySpan i'
@ -174,33 +172,6 @@ fromWeekday Fri = Friday
fromWeekday Sat = Saturday fromWeekday Sat = Saturday
fromWeekday Sun = Sunday fromWeekday Sun = Sunday
-- | find the next date
-- this is meant to go in a very tight loop and be very fast (hence no
-- complex date functions, most of which heavily use 'mod' and friends)
nextXGreg :: XGregorian -> XGregorian
nextXGreg XGregorian {xgYear = y, xgMonth = m, xgDay = d, xgDayOfWeek = w}
| m == 12 && d == 31 = XGregorian (y + 1) 1 1 w_
| (m == 2 && (not leap && d == 28 || (leap && d == 29)))
|| (m `elem` [4, 6, 9, 11] && d == 30)
|| (d == 31) =
XGregorian y (m + 1) 1 w_
| otherwise = XGregorian y m (d + 1) w_
where
-- don't use DayOfWeek from Data.Time since this uses mod (which uses a
-- division opcode) and thus will be slower than just checking for equality
-- and adding
w_ = if w == 6 then 0 else w + 1
leap = isLeapYear $ fromIntegral y
gregorians :: Day -> [XGregorian]
gregorians x = L.iterate nextXGreg $ XGregorian (fromIntegral y) m d w
where
(y, m, d) = toGregorian x
w = fromEnum $ dayOfWeek x
xGregToDay :: XGregorian -> Day
xGregToDay XGregorian {xgYear = y, xgMonth = m, xgDay = d} = fromGregorian (fromIntegral y) m d
gregTup :: Gregorian -> (Integer, Int, Int) gregTup :: Gregorian -> (Integer, Int, Int)
gregTup Gregorian {gYear, gMonth, gDay} = gregTup Gregorian {gYear, gMonth, gDay} =
( fromIntegral gYear ( fromIntegral gYear
@ -645,11 +616,11 @@ lookupFinance
-> (ConfigState -> M.Map k a) -> (ConfigState -> M.Map k a)
-> k -> 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) =<< asks f
balanceTxs balanceTxs
:: (MonadInsertError m, MonadFinance m) :: (MonadInsertError m, MonadFinance m)
=> [EntryBin] => [EntryCRU]
-> m ([UEBalanced], [InsertTx]) -> m ([UEBalanced], [InsertTx])
balanceTxs ebs = balanceTxs ebs =
first concat . partitionEithers . catMaybes first concat . partitionEithers . catMaybes
@ -684,7 +655,7 @@ balanceTxs ebs =
(balancePrimaryEntrySet txBudget . fromShadow tot) (balancePrimaryEntrySet txBudget . fromShadow tot)
fromShadow tot e@EntrySet {esTotalValue} = e {esTotalValue = tot *. esTotalValue} fromShadow tot e@EntrySet {esTotalValue} = e {esTotalValue = tot *. esTotalValue}
binDate :: EntryBin -> (Day, Int) binDate :: EntryCRU -> (Day, Int)
binDate (ToRead ReadEntry {reDate, rePriority}) = (reDate, rePriority) binDate (ToRead ReadEntry {reDate, rePriority}) = (reDate, rePriority)
binDate (ToInsert Tx {txDate, txPriority}) = (txDate, txPriority) binDate (ToInsert Tx {txDate, txPriority}) = (txDate, txPriority)
binDate (ToUpdate u) = either go go u binDate (ToUpdate u) = either go go u
@ -768,7 +739,7 @@ rebalanceDebit k ro linked = do
return (v, e0' : es') return (v, e0' : es')
unlink :: Decimal -> UELink -> UEBalanced unlink :: Decimal -> UELink -> UEBalanced
unlink v e = e {ueValue = StaticValue $ (-v) * unLinkScale (ueValue e)} unlink v e = e {ueValue = StaticValue $ (-v) *. unLinkScale (ueValue e)}
rebalanceCredit rebalanceCredit
:: BCKey :: BCKey
@ -880,7 +851,7 @@ balanceFinal
-> Decimal -> Decimal
-> NonEmpty InsertEntry -> NonEmpty InsertEntry
-> Entry AccountRId () TagRId -> Entry AccountRId () TagRId
-> [Entry AccountRId LinkDeferred TagRId] -> [Entry AccountRId EntryLink TagRId]
-> StateT EntryBals m InsertEntrySet -> StateT EntryBals m InsertEntrySet
balanceFinal k@(curID, _) tot fs t0 ts = do balanceFinal k@(curID, _) tot fs t0 ts = do
let fv = V.fromList $ NE.toList $ fmap (eValue . ieEntry) fs let fv = V.fromList $ NE.toList $ fmap (eValue . ieEntry) fs
@ -895,7 +866,7 @@ balanceFinal k@(curID, _) tot fs t0 ts = do
balanceTotalEntrySet balanceTotalEntrySet
:: (MonadInsertError m) :: (MonadInsertError m)
=> (ABCKey -> v -> StateT EntryBals m (Decimal, Maybe DBDeferred)) => (ABCKey -> v -> StateT EntryBals m (Decimal, Maybe CachedEntry))
-> BCKey -> BCKey
-> Decimal -> Decimal
-> Entry AccountRId () TagRId -> Entry AccountRId () TagRId
@ -909,7 +880,7 @@ balanceTotalEntrySet f k tot e@Entry {eAcnt = acntID} es = do
let e' = let e' =
InsertEntry InsertEntry
{ ieEntry = e {eValue = e0val, eAcnt = acntID} { ieEntry = e {eValue = e0val, eAcnt = acntID}
, ieDeferred = Nothing , ieCached = Nothing
} }
return $ e' :| es' return $ e' :| es'
where where
@ -922,42 +893,42 @@ balanceLinked
:: MonadInsertError m :: MonadInsertError m
=> Vector Decimal => Vector Decimal
-> ABCKey -> ABCKey
-> LinkDeferred -> EntryLink
-> StateT EntryBals m (Decimal, Maybe DBDeferred) -> StateT EntryBals m (Decimal, Maybe CachedEntry)
balanceLinked from k lg = case lg of balanceLinked from k lg = case lg of
(LinkIndex LinkedNumGetter {lngIndex, lngScale}) -> do (LinkIndex LinkedNumGetter {lngIndex, lngScale}) -> do
let res = fmap (go lngScale) $ from V.!? fromIntegral lngIndex let res = fmap (go lngScale) $ from V.!? fromIntegral lngIndex
case res of case res of
Just v -> return (v, Just $ DBEntryLinked lngIndex lngScale) Just v -> return (v, Just $ CachedLink (EntryIndex $ fromIntegral lngIndex) (LinkScale lngScale))
-- TODO this error would be much more informative if I had access to the -- TODO this error would be much more informative if I had access to the
-- file from which it came -- file from which it came
Nothing -> throwError undefined Nothing -> throwError undefined
(LinkDeferred d) -> liftInnerS $ balanceDeferred k d (LinkValue d) -> liftInnerS $ balanceDeferred k d
where where
go s = negate . (*. s) go s = negate . (*. s)
balanceDeferred :: ABCKey -> EntryValue -> State EntryBals (Decimal, Maybe DBDeferred) balanceDeferred :: ABCKey -> EntryValue -> State EntryBals (Decimal, Maybe CachedEntry)
balanceDeferred k e = do balanceDeferred k e = do
newval <- findBalance k e newval <- findBalance k e
let d = case e of let d = case e of
EntryFixed _ -> Nothing EntryFixed _ -> Nothing
EntryBalance v -> Just $ DBEntryBalance v EntryBalance v -> Just $ CachedBalance v
EntryPercent v -> Just $ DBEntryPercent v EntryPercent v -> Just $ CachedPercent v
return (newval, d) return (newval, d)
balanceEntry balanceEntry
:: (MonadInsertError m) :: (MonadInsertError m)
=> (ABCKey -> v -> StateT EntryBals m (Decimal, Maybe DBDeferred)) => (ABCKey -> v -> StateT EntryBals m (Decimal, Maybe CachedEntry))
-> BCKey -> BCKey
-> Entry AccountRId v TagRId -> Entry AccountRId v TagRId
-> StateT EntryBals m InsertEntry -> StateT EntryBals m InsertEntry
balanceEntry f k e@Entry {eValue, eAcnt = acntID} = do balanceEntry f k e@Entry {eValue, eAcnt = acntID} = do
(newVal, deferred) <- f (acntID, k) eValue (newVal, cached) <- f (acntID, k) eValue
modify (mapAdd_ (acntID, k) newVal) modify (mapAdd_ (acntID, k) newVal)
return $ return $
InsertEntry InsertEntry
{ ieEntry = e {eValue = newVal, eAcnt = acntID} { ieEntry = e {eValue = newVal, eAcnt = acntID}
, ieDeferred = deferred , ieCached = cached
} }
resolveAcntAndTags resolveAcntAndTags