WIP use newtypes to keep update balancer sane
This commit is contained in:
parent
fc4da967be
commit
7a44aeb5db
|
@ -516,12 +516,7 @@ readUpdates hashes = do
|
||||||
|
|
||||||
splitFrom
|
splitFrom
|
||||||
:: [(EntryRId, EntryR)]
|
:: [(EntryRId, EntryR)]
|
||||||
-> InsertExcept
|
-> InsertExcept (UEBlank, [UE_RO], [UEBalance], Vector (Maybe UEBalance))
|
||||||
( UpdateEntry EntryRId ()
|
|
||||||
, [UpdateEntry () Rational]
|
|
||||||
, [UpdateEntry EntryRId Rational]
|
|
||||||
, Vector (Maybe (UpdateEntry EntryRId Rational))
|
|
||||||
)
|
|
||||||
splitFrom from = do
|
splitFrom from = do
|
||||||
-- ASSUME entries are sorted by index
|
-- ASSUME entries are sorted by index
|
||||||
(primary, rest) <- case from of
|
(primary, rest) <- case from of
|
||||||
|
@ -533,14 +528,14 @@ splitFrom from = do
|
||||||
return (primary, ro, toBal, idxVec)
|
return (primary, ro, toBal, idxVec)
|
||||||
|
|
||||||
splitTo
|
splitTo
|
||||||
:: Vector (Maybe (UpdateEntry EntryRId Rational))
|
:: Vector (Maybe UEBalance)
|
||||||
-> [(EntryRId, EntryR)]
|
-> [(EntryRId, EntryR)]
|
||||||
-> InsertExcept
|
-> InsertExcept
|
||||||
( UpdateEntry EntryRId ()
|
( UEBlank
|
||||||
, [UpdateEntry () Rational]
|
, [UE_RO]
|
||||||
, [UpdateEntry EntryRId Rational]
|
, [UEBalance]
|
||||||
, [UpdateEntry EntryRId ()]
|
, [UELink]
|
||||||
, [(UpdateEntry EntryRId Rational, [UpdateEntry EntryRId Rational])]
|
, [(UEBalance, [UELink])]
|
||||||
)
|
)
|
||||||
splitTo froms tos = do
|
splitTo froms tos = do
|
||||||
-- How to split the credit side of the database transaction in 1024 easy
|
-- How to split the credit side of the database transaction in 1024 easy
|
||||||
|
@ -560,18 +555,18 @@ splitTo froms tos = do
|
||||||
let (ro, toBal) = partitionEithers $ fmap splitDeferredValue unlinked
|
let (ro, toBal) = partitionEithers $ fmap splitDeferredValue unlinked
|
||||||
|
|
||||||
-- 3. Split paired entries by link == 0 (which are special) or link > 0
|
-- 3. Split paired entries by link == 0 (which are special) or link > 0
|
||||||
let (paired0, pairedN) =
|
let (paired0, pairedN) = second (groupKey id) $ L.partition ((== 0) . fst) linked
|
||||||
bimap (fmap (uncurry makeUnkUE . snd)) (groupKey id) $
|
let paired0Res = mapErrors (makeLinkUnk . snd) paired0
|
||||||
L.partition ((== 0) . fst) linked
|
|
||||||
|
|
||||||
-- 4. Group linked entries (which now have links > 0) according to the debit
|
-- 4. Group linked entries (which now have links > 0) according to the debit
|
||||||
-- entry to which they are linked. If the debit entry cannot be found or
|
-- entry to which they are linked. If the debit entry cannot be found or
|
||||||
-- if the linked entry has no scale, blow up in user's face. If the
|
-- if the linked entry has no scale, blow up in user's face. If the
|
||||||
-- debit entry is read-only (signified by Nothing in the 'from' array)
|
-- debit entry is read-only (signified by Nothing in the 'from' array)
|
||||||
-- then consider the linked entry as another credit read-only entry
|
-- then consider the linked entry as another credit read-only entry
|
||||||
(pairedUnk, pairedRO) <- partitionEithers <$> mapErrors splitPaired pairedN
|
let pairedRes = partitionEithers <$> mapErrors splitPaired pairedN
|
||||||
|
|
||||||
return (primary, ro ++ concat pairedRO, toBal, paired0, pairedUnk)
|
combineError paired0Res pairedRes $ \paired0' (pairedUnk, pairedRO) ->
|
||||||
|
(primary, ro ++ concat pairedRO, toBal, paired0', pairedUnk)
|
||||||
where
|
where
|
||||||
splitLinked t@(_, e) = maybe (Left t) (Right . (,t)) $ entryRDeferred_link e
|
splitLinked t@(_, e) = maybe (Left t) (Right . (,t)) $ entryRDeferred_link e
|
||||||
splitPaired (lnk, ts) = case froms V.!? (lnk - 1) of
|
splitPaired (lnk, ts) = case froms V.!? (lnk - 1) of
|
||||||
|
@ -581,20 +576,19 @@ splitTo froms tos = do
|
||||||
makeLinkUnk (k, e) =
|
makeLinkUnk (k, e) =
|
||||||
maybe
|
maybe
|
||||||
(throwError $ InsertException undefined)
|
(throwError $ InsertException undefined)
|
||||||
(return . makeUE k e)
|
(return . makeUE k e . LinkScale)
|
||||||
$ entryRDeferred_value e
|
$ entryRDeferred_value e
|
||||||
|
|
||||||
splitDeferredValue
|
splitDeferredValue :: (EntryRId, EntryR) -> Either UE_RO UEBalance
|
||||||
:: (EntryRId, EntryR)
|
|
||||||
-> Either (UpdateEntry () Rational) (UpdateEntry EntryRId Rational)
|
|
||||||
splitDeferredValue (k, e) =
|
splitDeferredValue (k, e) =
|
||||||
maybe (Left $ makeRoUE e) (Right . makeUE k e) $ entryRDeferred_value e
|
maybe (Left $ makeRoUE e) (Right . fmap BalanceTarget . makeUE k e) $
|
||||||
|
entryRDeferred_value e
|
||||||
|
|
||||||
makeUE :: i -> EntryR -> v -> UpdateEntry i v
|
makeUE :: i -> EntryR -> v -> UpdateEntry i v
|
||||||
makeUE k e v = UpdateEntry k (entryRAccount e) v (entryRIndex e)
|
makeUE k e v = UpdateEntry k (entryRAccount e) v (entryRIndex e)
|
||||||
|
|
||||||
makeRoUE :: EntryR -> UpdateEntry () Rational
|
makeRoUE :: EntryR -> UpdateEntry () EntryValue
|
||||||
makeRoUE e = makeUE () e (entryRValue e)
|
makeRoUE e = makeUE () e $ EntryValue (entryRValue e)
|
||||||
|
|
||||||
makeUnkUE :: EntryRId -> EntryR -> UpdateEntry EntryRId ()
|
makeUnkUE :: EntryRId -> EntryR -> UpdateEntry EntryRId ()
|
||||||
makeUnkUE k e = makeUE k e ()
|
makeUnkUE k e = makeUE k e ()
|
||||||
|
|
|
@ -331,7 +331,7 @@ matchNonDates ms = go ([], [], initZipper ms)
|
||||||
balanceTxs
|
balanceTxs
|
||||||
:: (MonadInsertError m, MonadFinance m)
|
:: (MonadInsertError m, MonadFinance m)
|
||||||
=> [EntryBin]
|
=> [EntryBin]
|
||||||
-> m ([UpdateEntry EntryRId Rational], [KeyTx CommitR])
|
-> m ([UEBalanced], [KeyTx CommitR])
|
||||||
balanceTxs es =
|
balanceTxs es =
|
||||||
(first concat . partitionEithers . catMaybes)
|
(first concat . partitionEithers . catMaybes)
|
||||||
<$> evalStateT (mapM go $ L.sortOn binDate es) M.empty
|
<$> evalStateT (mapM go $ L.sortOn binDate es) M.empty
|
||||||
|
@ -352,11 +352,11 @@ binDate (ToInsert (Tx {txDate})) = txDate
|
||||||
type EntryBals = M.Map (AccountRId, CurrencyRId) Rational
|
type EntryBals = M.Map (AccountRId, CurrencyRId) Rational
|
||||||
|
|
||||||
data UpdateEntryType a
|
data UpdateEntryType a
|
||||||
= UEReadOnly (UpdateEntry () Rational)
|
= UET_ReadOnly UE_RO
|
||||||
| UEBlank (UpdateEntry EntryRId Rational)
|
| UET_Balance UEBalance
|
||||||
| UEPaired (UpdateEntry EntryRId Rational, UpdateEntry EntryRId a)
|
| UET_Linked a
|
||||||
|
|
||||||
rebalanceEntrySet :: UpdateEntrySet -> State EntryBals [UpdateEntry EntryRId Rational]
|
rebalanceEntrySet :: UpdateEntrySet -> State EntryBals [UEBalanced]
|
||||||
rebalanceEntrySet
|
rebalanceEntrySet
|
||||||
UpdateEntrySet
|
UpdateEntrySet
|
||||||
{ utFrom0
|
{ utFrom0
|
||||||
|
@ -367,53 +367,73 @@ rebalanceEntrySet
|
||||||
, utFromRO
|
, utFromRO
|
||||||
, utToRO
|
, utToRO
|
||||||
, utCurrency
|
, utCurrency
|
||||||
|
, utToUnkLink0
|
||||||
, utTotalValue
|
, utTotalValue
|
||||||
} =
|
} =
|
||||||
do
|
do
|
||||||
let fs =
|
let fs =
|
||||||
L.sortOn index $
|
L.sortOn index $
|
||||||
(UEReadOnly <$> utFromRO)
|
(UET_ReadOnly <$> utFromRO)
|
||||||
++ (UEBlank <$> utFromUnk)
|
++ (UET_Balance <$> utFromUnk)
|
||||||
++ (UEPaired <$> utPairs)
|
++ (UET_Linked <$> utPairs)
|
||||||
fs' <- mapM goFrom fs
|
fs' <- mapM goFrom fs
|
||||||
let f0 = utFrom0 {ueValue = utTotalValue - (sum $ fmap value fs')}
|
let f0val = utTotalValue - (sum $ fmap value fs')
|
||||||
let (fs'', tpairs) = partitionEithers $ concatMap flatten fs'
|
let f0 = utFrom0 {ueValue = EntryValue f0val}
|
||||||
let ts = (Right <$> tpairs) ++ (Right <$> utToUnk) ++ (Left <$> utToRO)
|
let (tpairs, fs'') = partitionEithers $ concatMap flatten fs'
|
||||||
|
let ts =
|
||||||
|
(UET_Linked <$> tpairs)
|
||||||
|
++ (UET_Balance <$> utToUnk)
|
||||||
|
++ (UET_ReadOnly <$> utToRO)
|
||||||
|
let tsLink0 = fmap (\e -> e {ueValue = -f0val * (unLinkScale $ ueValue e)}) utToUnkLink0
|
||||||
(tsRO, tsUnk) <- partitionEithers <$> mapM goTo ts
|
(tsRO, tsUnk) <- partitionEithers <$> mapM goTo ts
|
||||||
let t0 = utTo0 {ueValue = utTotalValue - (sum $ (fmap ueValue tsRO) ++ (fmap ueValue tsUnk))}
|
let t0val =
|
||||||
return $ f0 : fs'' ++ t0 : tsUnk
|
(EntryValue utTotalValue)
|
||||||
|
- (sum $ (fmap ueValue tsRO) ++ (fmap ueValue tsUnk))
|
||||||
|
let t0 = utTo0 {ueValue = t0val}
|
||||||
|
return $ (f0 : (fmap (fmap (EntryValue . unBalanceTarget)) fs'')) ++ (t0 : tsUnk)
|
||||||
where
|
where
|
||||||
project f _ _ (UEReadOnly e) = f e
|
project f _ _ (UET_ReadOnly e) = f e
|
||||||
project _ f _ (UEBlank e) = f e
|
project _ f _ (UET_Balance e) = f e
|
||||||
project _ _ f (UEPaired p) = f p
|
project _ _ f (UET_Linked p) = f p
|
||||||
index = project ueIndex ueIndex (ueIndex . fst)
|
index = project ueIndex ueIndex (ueIndex . fst)
|
||||||
value = project ueValue ueValue (ueValue . fst)
|
value =
|
||||||
flatten = project (const []) ((: []) . Right) (\(a, b) -> [Right a, Left b])
|
project
|
||||||
|
(unEntryValue . ueValue)
|
||||||
|
(unBalanceTarget . ueValue)
|
||||||
|
(unBalanceTarget . ueValue . fst)
|
||||||
|
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 (UEReadOnly e) = do
|
goFrom (UET_ReadOnly e) = do
|
||||||
modify $ mapAdd_ (ueAcnt e, utCurrency) (ueValue e)
|
modify $ mapAdd_ (ueAcnt e, utCurrency) (unEntryValue $ ueValue e)
|
||||||
return $ UEReadOnly e
|
return $ UET_ReadOnly e
|
||||||
goFrom (UEBlank e) = do
|
goFrom (UET_Balance e) = do
|
||||||
let key = (ueAcnt e, utCurrency)
|
let key = (ueAcnt e, utCurrency)
|
||||||
curBal <- gets (M.findWithDefault 0 key)
|
curBal <- gets (M.findWithDefault 0 key)
|
||||||
let newVal = ueValue e - curBal
|
let newVal = unBalanceTarget (ueValue e) - curBal
|
||||||
modify $ mapAdd_ key newVal
|
modify $ mapAdd_ key newVal
|
||||||
return $ UEBlank $ e {ueValue = newVal}
|
return $ UET_Balance $ e {ueValue = BalanceTarget newVal}
|
||||||
goFrom (UEPaired (e0, e1)) = do
|
goFrom (UET_Linked (e0, es)) = do
|
||||||
let key = (ueAcnt e0, utCurrency)
|
let key = (ueAcnt e0, utCurrency)
|
||||||
curBal <- gets (M.findWithDefault 0 key)
|
curBal <- gets (M.findWithDefault 0 key)
|
||||||
let newVal = ueValue e0 - curBal
|
let newVal = unBalanceTarget (ueValue e0) - curBal
|
||||||
modify $ mapAdd_ key newVal
|
modify $ mapAdd_ key newVal
|
||||||
return $ UEPaired $ (e0 {ueValue = newVal}, e1 {ueValue = -newVal})
|
return $
|
||||||
goTo (Left e) = do
|
UET_Linked $
|
||||||
modify $ mapAdd_ (ueAcnt e, utCurrency) (ueValue e)
|
( e0 {ueValue = BalanceTarget newVal}
|
||||||
|
, fmap (\e -> e {ueValue = EntryValue $ (-newVal) * unLinkScale (ueValue e)}) es
|
||||||
|
)
|
||||||
|
goTo (UET_ReadOnly e) = do
|
||||||
|
modify $ mapAdd_ (ueAcnt e, utCurrency) (unEntryValue $ ueValue e)
|
||||||
return $ Left e
|
return $ Left e
|
||||||
goTo (Right e) = do
|
goTo (UET_Linked e) = do
|
||||||
|
modify $ mapAdd_ (ueAcnt e, utCurrency) (unEntryValue $ ueValue e)
|
||||||
|
return $ Right e
|
||||||
|
goTo (UET_Balance e) = do
|
||||||
let key = (ueAcnt e, utCurrency)
|
let key = (ueAcnt e, utCurrency)
|
||||||
curBal <- gets (M.findWithDefault 0 key)
|
curBal <- gets (M.findWithDefault 0 key)
|
||||||
let newVal = ueValue e - curBal
|
let newVal = unBalanceTarget (ueValue e) - curBal
|
||||||
modify $ mapAdd_ key newVal
|
modify $ mapAdd_ key newVal
|
||||||
return $ Right $ e {ueValue = newVal}
|
return $ Right $ e {ueValue = EntryValue newVal}
|
||||||
|
|
||||||
balanceEntrySet
|
balanceEntrySet
|
||||||
:: (MonadInsertError m, MonadFinance m)
|
:: (MonadInsertError m, MonadFinance m)
|
||||||
|
|
|
@ -77,17 +77,36 @@ data UpdateEntry i v = UpdateEntry
|
||||||
, ueIndex :: !Int -- TODO this isn't needed for primary entries
|
, ueIndex :: !Int -- TODO this isn't needed for primary entries
|
||||||
}
|
}
|
||||||
|
|
||||||
|
deriving instance Functor (UpdateEntry i)
|
||||||
|
|
||||||
|
newtype LinkScale = LinkScale {unLinkScale :: Rational}
|
||||||
|
deriving newtype (Num)
|
||||||
|
|
||||||
|
newtype BalanceTarget = BalanceTarget {unBalanceTarget :: Rational}
|
||||||
|
deriving newtype (Num)
|
||||||
|
|
||||||
|
newtype EntryValue = EntryValue {unEntryValue :: Rational}
|
||||||
|
deriving newtype (Num)
|
||||||
|
|
||||||
|
type UEBalance = UpdateEntry EntryRId BalanceTarget
|
||||||
|
|
||||||
|
type UELink = UpdateEntry EntryRId LinkScale
|
||||||
|
|
||||||
|
type UEBlank = UpdateEntry EntryRId ()
|
||||||
|
|
||||||
|
type UE_RO = UpdateEntry () EntryValue
|
||||||
|
|
||||||
|
type UEBalanced = UpdateEntry EntryRId EntryValue
|
||||||
|
|
||||||
data UpdateEntrySet = UpdateEntrySet
|
data UpdateEntrySet = UpdateEntrySet
|
||||||
{ utFrom0 :: !(UpdateEntry EntryRId ())
|
{ utFrom0 :: !UEBlank
|
||||||
, utTo0 :: !(UpdateEntry EntryRId ())
|
, utTo0 :: !UEBlank
|
||||||
, -- for these next three, the Rational number is the balance target (not the
|
, utPairs :: ![(UEBalance, [UELink])]
|
||||||
-- value of the account)
|
, utFromUnk :: ![UEBalance]
|
||||||
utPairs :: ![(UpdateEntry EntryRId Rational, [UpdateEntry EntryRId Rational])]
|
, utToUnk :: ![UEBalance]
|
||||||
, utFromUnk :: ![UpdateEntry EntryRId Rational]
|
, utToUnkLink0 :: ![UELink]
|
||||||
, utToUnk :: ![UpdateEntry EntryRId Rational]
|
, utFromRO :: ![UE_RO]
|
||||||
, utToUnkLink0 :: ![UpdateEntry EntryRId ()]
|
, utToRO :: ![UE_RO]
|
||||||
, utFromRO :: ![UpdateEntry () Rational]
|
|
||||||
, utToRO :: ![UpdateEntry () Rational]
|
|
||||||
, utCurrency :: !CurrencyRId
|
, utCurrency :: !CurrencyRId
|
||||||
, utDate :: !Day
|
, utDate :: !Day
|
||||||
, utTotalValue :: !Rational
|
, utTotalValue :: !Rational
|
||||||
|
|
Loading…
Reference in New Issue