REF clean code
This commit is contained in:
parent
f8669e5a15
commit
d617fa52cc
|
@ -339,21 +339,21 @@ balanceTxs
|
||||||
=> [EntryBin]
|
=> [EntryBin]
|
||||||
-> m ([UEBalanced], [KeyTx CommitR])
|
-> m ([UEBalanced], [KeyTx CommitR])
|
||||||
balanceTxs es =
|
balanceTxs es =
|
||||||
(first concat . partitionEithers . catMaybes)
|
first concat . partitionEithers . catMaybes
|
||||||
<$> evalStateT (mapErrors go $ L.sortOn binDate es) M.empty
|
<$> evalStateT (mapErrors go $ L.sortOn binDate es) M.empty
|
||||||
where
|
where
|
||||||
go (ToUpdate utx) = fmap (Just . Left) $ liftInnerS $ rebalanceEntrySet utx
|
go (ToUpdate utx) = fmap (Just . Left) $ liftInnerS $ rebalanceEntrySet utx
|
||||||
go (ToRead ReadEntry {reCurrency, reAcnt, reValue}) = do
|
go (ToRead ReadEntry {reCurrency, reAcnt, reValue}) = do
|
||||||
modify $ mapAdd_ (reAcnt, reCurrency) reValue
|
modify $ mapAdd_ (reAcnt, reCurrency) reValue
|
||||||
return Nothing
|
return Nothing
|
||||||
go (ToInsert (t@Tx {txEntries, txDate})) =
|
go (ToInsert t@Tx {txEntries}) =
|
||||||
(\es' -> Just $ Right $ t {txEntries = concat es'})
|
(\es' -> Just $ Right $ t {txEntries = concat es'})
|
||||||
<$> mapM (balanceEntrySet txDate) txEntries
|
<$> mapErrors balanceEntrySet txEntries
|
||||||
|
|
||||||
binDate :: EntryBin -> Day
|
binDate :: EntryBin -> Day
|
||||||
binDate (ToUpdate (UpdateEntrySet {utDate})) = utDate
|
binDate (ToUpdate UpdateEntrySet {utDate}) = utDate
|
||||||
binDate (ToRead ReadEntry {reDate}) = reDate
|
binDate (ToRead ReadEntry {reDate}) = reDate
|
||||||
binDate (ToInsert (Tx {txDate})) = txDate
|
binDate (ToInsert Tx {txDate}) = txDate
|
||||||
|
|
||||||
type EntryBals = M.Map (AccountRId, CurrencyRId) Rational
|
type EntryBals = M.Map (AccountRId, CurrencyRId) Rational
|
||||||
|
|
||||||
|
@ -383,10 +383,10 @@ rebalanceEntrySet
|
||||||
++ (UET_Balance <$> utFromUnk)
|
++ (UET_Balance <$> utFromUnk)
|
||||||
++ (UET_Linked <$> utPairs)
|
++ (UET_Linked <$> utPairs)
|
||||||
fs' <- mapM goFrom fs
|
fs' <- mapM goFrom fs
|
||||||
let f0val = utTotalValue - (sum $ fmap value fs')
|
let f0val = utTotalValue - sum (fmap value fs')
|
||||||
let f0 = utFrom0 {ueValue = EntryValue f0val}
|
let f0 = utFrom0 {ueValue = EntryValue f0val}
|
||||||
let (tpairs, fs'') = partitionEithers $ concatMap flatten fs'
|
let (tpairs, fs'') = partitionEithers $ concatMap flatten fs'
|
||||||
let tsLink0 = fmap (\e -> e {ueValue = EntryValue $ -f0val * (unLinkScale $ ueValue e)}) utToUnkLink0
|
let tsLink0 = fmap (\e -> e {ueValue = EntryValue $ -f0val * unLinkScale (ueValue e)}) utToUnkLink0
|
||||||
let ts =
|
let ts =
|
||||||
L.sortOn idx2 $
|
L.sortOn idx2 $
|
||||||
(UET_Linked <$> (tpairs ++ tsLink0))
|
(UET_Linked <$> (tpairs ++ tsLink0))
|
||||||
|
@ -394,10 +394,10 @@ rebalanceEntrySet
|
||||||
++ (UET_ReadOnly <$> utToRO)
|
++ (UET_ReadOnly <$> utToRO)
|
||||||
(tsRO, tsUnk) <- partitionEithers <$> mapM goTo ts
|
(tsRO, tsUnk) <- partitionEithers <$> mapM goTo ts
|
||||||
let t0val =
|
let t0val =
|
||||||
(EntryValue utTotalValue)
|
EntryValue utTotalValue
|
||||||
- (sum $ (fmap ueValue tsRO) ++ (fmap ueValue tsUnk))
|
- sum (fmap ueValue tsRO ++ fmap ueValue tsUnk)
|
||||||
let t0 = utTo0 {ueValue = t0val}
|
let t0 = utTo0 {ueValue = t0val}
|
||||||
return $ (f0 : (fmap (fmap (EntryValue . unBalanceTarget)) fs'')) ++ (t0 : tsUnk)
|
return $ (f0 : fmap (fmap (EntryValue . unBalanceTarget)) fs'') ++ (t0 : tsUnk)
|
||||||
where
|
where
|
||||||
project f _ _ (UET_ReadOnly e) = f e
|
project f _ _ (UET_ReadOnly e) = f e
|
||||||
project _ f _ (UET_Balance e) = f e
|
project _ f _ (UET_Balance e) = f e
|
||||||
|
@ -409,7 +409,7 @@ rebalanceEntrySet
|
||||||
(unEntryValue . ueValue)
|
(unEntryValue . ueValue)
|
||||||
(unBalanceTarget . ueValue)
|
(unBalanceTarget . ueValue)
|
||||||
(unBalanceTarget . ueValue . fst)
|
(unBalanceTarget . ueValue . fst)
|
||||||
flatten = project (const []) ((: []) . Right) (\(a, bs) -> (Right a) : (Left <$> bs))
|
flatten = project (const []) ((: []) . Right) (\(a, bs) -> Right a : (Left <$> bs))
|
||||||
-- TODO the following is wetter than the average groupie
|
-- TODO the following is wetter than the average groupie
|
||||||
goFrom (UET_ReadOnly e) = do
|
goFrom (UET_ReadOnly e) = do
|
||||||
modify $ mapAdd_ (ueAcnt e, utCurrency) (unEntryValue $ ueValue e)
|
modify $ mapAdd_ (ueAcnt e, utCurrency) (unEntryValue $ ueValue e)
|
||||||
|
@ -426,7 +426,7 @@ rebalanceEntrySet
|
||||||
let newVal = unBalanceTarget (ueValue e0) - curBal
|
let newVal = unBalanceTarget (ueValue e0) - curBal
|
||||||
modify $ mapAdd_ key newVal
|
modify $ mapAdd_ key newVal
|
||||||
return $
|
return $
|
||||||
UET_Linked $
|
UET_Linked
|
||||||
( e0 {ueValue = BalanceTarget newVal}
|
( e0 {ueValue = BalanceTarget newVal}
|
||||||
, fmap (\e -> e {ueValue = EntryValue $ (-newVal) * unLinkScale (ueValue e)}) es
|
, fmap (\e -> e {ueValue = EntryValue $ (-newVal) * unLinkScale (ueValue e)}) es
|
||||||
)
|
)
|
||||||
|
@ -445,11 +445,9 @@ rebalanceEntrySet
|
||||||
|
|
||||||
balanceEntrySet
|
balanceEntrySet
|
||||||
:: (MonadInsertError m, MonadFinance m)
|
:: (MonadInsertError m, MonadFinance m)
|
||||||
=> Day
|
=> DeferredEntrySet
|
||||||
-> DeferredEntrySet
|
|
||||||
-> StateT EntryBals m [KeyEntry]
|
-> StateT EntryBals m [KeyEntry]
|
||||||
balanceEntrySet
|
balanceEntrySet
|
||||||
day
|
|
||||||
EntrySet
|
EntrySet
|
||||||
{ esFrom = HalfEntrySet {hesPrimary = f0, hesOther = fs}
|
{ esFrom = HalfEntrySet {hesPrimary = f0, hesOther = fs}
|
||||||
, esTo = HalfEntrySet {hesPrimary = t0, hesOther = ts}
|
, esTo = HalfEntrySet {hesPrimary = t0, hesOther = ts}
|
||||||
|
@ -482,7 +480,7 @@ doEntries
|
||||||
-> NonEmpty Int
|
-> NonEmpty Int
|
||||||
-> StateT EntryBals m [FullEntry AccountRId CurrencyRId TagRId]
|
-> StateT EntryBals m [FullEntry AccountRId CurrencyRId TagRId]
|
||||||
doEntries f curID tot e es (i0 :| iN) = do
|
doEntries f curID tot e es (i0 :| iN) = do
|
||||||
es' <- mapM (uncurry f) $ zip iN es
|
es' <- mapErrors (uncurry f) $ zip iN es
|
||||||
let val0 = tot - entrySum es'
|
let val0 = tot - entrySum es'
|
||||||
e' <- balanceEntry (\_ _ -> return (val0, Nothing)) curID i0 e
|
e' <- balanceEntry (\_ _ -> return (val0, Nothing)) curID i0 e
|
||||||
return $ e' : es'
|
return $ e' : es'
|
||||||
|
@ -505,6 +503,8 @@ balanceLinked from curID precision acntID lg = case lg of
|
||||||
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 $ EntryLinked lngIndex $ toRational lngScale)
|
Just v -> return $ (v, Just $ EntryLinked lngIndex $ toRational lngScale)
|
||||||
|
-- TODO this error would be much more informative if I had access to the
|
||||||
|
-- file from which it came
|
||||||
Nothing -> throwError undefined
|
Nothing -> throwError undefined
|
||||||
(LinkDeferred d) -> liftInnerS $ balanceDeferred curID acntID d
|
(LinkDeferred d) -> liftInnerS $ balanceDeferred curID acntID d
|
||||||
where
|
where
|
||||||
|
|
Loading…
Reference in New Issue