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
|
||||
:: [(EntryRId, EntryR)]
|
||||
-> InsertExcept
|
||||
( UpdateEntry EntryRId ()
|
||||
, [UpdateEntry () Rational]
|
||||
, [UpdateEntry EntryRId Rational]
|
||||
, Vector (Maybe (UpdateEntry EntryRId Rational))
|
||||
)
|
||||
-> InsertExcept (UEBlank, [UE_RO], [UEBalance], Vector (Maybe UEBalance))
|
||||
splitFrom from = do
|
||||
-- ASSUME entries are sorted by index
|
||||
(primary, rest) <- case from of
|
||||
|
|
@ -533,14 +528,14 @@ splitFrom from = do
|
|||
return (primary, ro, toBal, idxVec)
|
||||
|
||||
splitTo
|
||||
:: Vector (Maybe (UpdateEntry EntryRId Rational))
|
||||
:: Vector (Maybe UEBalance)
|
||||
-> [(EntryRId, EntryR)]
|
||||
-> InsertExcept
|
||||
( UpdateEntry EntryRId ()
|
||||
, [UpdateEntry () Rational]
|
||||
, [UpdateEntry EntryRId Rational]
|
||||
, [UpdateEntry EntryRId ()]
|
||||
, [(UpdateEntry EntryRId Rational, [UpdateEntry EntryRId Rational])]
|
||||
( UEBlank
|
||||
, [UE_RO]
|
||||
, [UEBalance]
|
||||
, [UELink]
|
||||
, [(UEBalance, [UELink])]
|
||||
)
|
||||
splitTo froms tos = do
|
||||
-- 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
|
||||
|
||||
-- 3. Split paired entries by link == 0 (which are special) or link > 0
|
||||
let (paired0, pairedN) =
|
||||
bimap (fmap (uncurry makeUnkUE . snd)) (groupKey id) $
|
||||
L.partition ((== 0) . fst) linked
|
||||
let (paired0, pairedN) = second (groupKey id) $ L.partition ((== 0) . fst) linked
|
||||
let paired0Res = mapErrors (makeLinkUnk . snd) paired0
|
||||
|
||||
-- 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
|
||||
-- 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)
|
||||
-- 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
|
||||
splitLinked t@(_, e) = maybe (Left t) (Right . (,t)) $ entryRDeferred_link e
|
||||
splitPaired (lnk, ts) = case froms V.!? (lnk - 1) of
|
||||
|
|
@ -581,20 +576,19 @@ splitTo froms tos = do
|
|||
makeLinkUnk (k, e) =
|
||||
maybe
|
||||
(throwError $ InsertException undefined)
|
||||
(return . makeUE k e)
|
||||
(return . makeUE k e . LinkScale)
|
||||
$ entryRDeferred_value e
|
||||
|
||||
splitDeferredValue
|
||||
:: (EntryRId, EntryR)
|
||||
-> Either (UpdateEntry () Rational) (UpdateEntry EntryRId Rational)
|
||||
splitDeferredValue :: (EntryRId, EntryR) -> Either UE_RO UEBalance
|
||||
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 k e v = UpdateEntry k (entryRAccount e) v (entryRIndex e)
|
||||
|
||||
makeRoUE :: EntryR -> UpdateEntry () Rational
|
||||
makeRoUE e = makeUE () e (entryRValue e)
|
||||
makeRoUE :: EntryR -> UpdateEntry () EntryValue
|
||||
makeRoUE e = makeUE () e $ EntryValue (entryRValue e)
|
||||
|
||||
makeUnkUE :: EntryRId -> EntryR -> UpdateEntry EntryRId ()
|
||||
makeUnkUE k e = makeUE k e ()
|
||||
|
|
|
|||
|
|
@ -331,7 +331,7 @@ matchNonDates ms = go ([], [], initZipper ms)
|
|||
balanceTxs
|
||||
:: (MonadInsertError m, MonadFinance m)
|
||||
=> [EntryBin]
|
||||
-> m ([UpdateEntry EntryRId Rational], [KeyTx CommitR])
|
||||
-> m ([UEBalanced], [KeyTx CommitR])
|
||||
balanceTxs es =
|
||||
(first concat . partitionEithers . catMaybes)
|
||||
<$> 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
|
||||
|
||||
data UpdateEntryType a
|
||||
= UEReadOnly (UpdateEntry () Rational)
|
||||
| UEBlank (UpdateEntry EntryRId Rational)
|
||||
| UEPaired (UpdateEntry EntryRId Rational, UpdateEntry EntryRId a)
|
||||
= UET_ReadOnly UE_RO
|
||||
| UET_Balance UEBalance
|
||||
| UET_Linked a
|
||||
|
||||
rebalanceEntrySet :: UpdateEntrySet -> State EntryBals [UpdateEntry EntryRId Rational]
|
||||
rebalanceEntrySet :: UpdateEntrySet -> State EntryBals [UEBalanced]
|
||||
rebalanceEntrySet
|
||||
UpdateEntrySet
|
||||
{ utFrom0
|
||||
|
|
@ -367,53 +367,73 @@ rebalanceEntrySet
|
|||
, utFromRO
|
||||
, utToRO
|
||||
, utCurrency
|
||||
, utToUnkLink0
|
||||
, utTotalValue
|
||||
} =
|
||||
do
|
||||
let fs =
|
||||
L.sortOn index $
|
||||
(UEReadOnly <$> utFromRO)
|
||||
++ (UEBlank <$> utFromUnk)
|
||||
++ (UEPaired <$> utPairs)
|
||||
(UET_ReadOnly <$> utFromRO)
|
||||
++ (UET_Balance <$> utFromUnk)
|
||||
++ (UET_Linked <$> utPairs)
|
||||
fs' <- mapM goFrom fs
|
||||
let f0 = utFrom0 {ueValue = utTotalValue - (sum $ fmap value fs')}
|
||||
let (fs'', tpairs) = partitionEithers $ concatMap flatten fs'
|
||||
let ts = (Right <$> tpairs) ++ (Right <$> utToUnk) ++ (Left <$> utToRO)
|
||||
let f0val = utTotalValue - (sum $ fmap value fs')
|
||||
let f0 = utFrom0 {ueValue = EntryValue f0val}
|
||||
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
|
||||
let t0 = utTo0 {ueValue = utTotalValue - (sum $ (fmap ueValue tsRO) ++ (fmap ueValue tsUnk))}
|
||||
return $ f0 : fs'' ++ t0 : tsUnk
|
||||
let t0val =
|
||||
(EntryValue utTotalValue)
|
||||
- (sum $ (fmap ueValue tsRO) ++ (fmap ueValue tsUnk))
|
||||
let t0 = utTo0 {ueValue = t0val}
|
||||
return $ (f0 : (fmap (fmap (EntryValue . unBalanceTarget)) fs'')) ++ (t0 : tsUnk)
|
||||
where
|
||||
project f _ _ (UEReadOnly e) = f e
|
||||
project _ f _ (UEBlank e) = f e
|
||||
project _ _ f (UEPaired p) = f p
|
||||
project f _ _ (UET_ReadOnly e) = f e
|
||||
project _ f _ (UET_Balance e) = f e
|
||||
project _ _ f (UET_Linked p) = f p
|
||||
index = project ueIndex ueIndex (ueIndex . fst)
|
||||
value = project ueValue ueValue (ueValue . fst)
|
||||
flatten = project (const []) ((: []) . Right) (\(a, b) -> [Right a, Left b])
|
||||
value =
|
||||
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
|
||||
goFrom (UEReadOnly e) = do
|
||||
modify $ mapAdd_ (ueAcnt e, utCurrency) (ueValue e)
|
||||
return $ UEReadOnly e
|
||||
goFrom (UEBlank e) = do
|
||||
goFrom (UET_ReadOnly e) = do
|
||||
modify $ mapAdd_ (ueAcnt e, utCurrency) (unEntryValue $ ueValue e)
|
||||
return $ UET_ReadOnly e
|
||||
goFrom (UET_Balance e) = do
|
||||
let key = (ueAcnt e, utCurrency)
|
||||
curBal <- gets (M.findWithDefault 0 key)
|
||||
let newVal = ueValue e - curBal
|
||||
let newVal = unBalanceTarget (ueValue e) - curBal
|
||||
modify $ mapAdd_ key newVal
|
||||
return $ UEBlank $ e {ueValue = newVal}
|
||||
goFrom (UEPaired (e0, e1)) = do
|
||||
return $ UET_Balance $ e {ueValue = BalanceTarget newVal}
|
||||
goFrom (UET_Linked (e0, es)) = do
|
||||
let key = (ueAcnt e0, utCurrency)
|
||||
curBal <- gets (M.findWithDefault 0 key)
|
||||
let newVal = ueValue e0 - curBal
|
||||
let newVal = unBalanceTarget (ueValue e0) - curBal
|
||||
modify $ mapAdd_ key newVal
|
||||
return $ UEPaired $ (e0 {ueValue = newVal}, e1 {ueValue = -newVal})
|
||||
goTo (Left e) = do
|
||||
modify $ mapAdd_ (ueAcnt e, utCurrency) (ueValue e)
|
||||
return $
|
||||
UET_Linked $
|
||||
( 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
|
||||
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)
|
||||
curBal <- gets (M.findWithDefault 0 key)
|
||||
let newVal = ueValue e - curBal
|
||||
let newVal = unBalanceTarget (ueValue e) - curBal
|
||||
modify $ mapAdd_ key newVal
|
||||
return $ Right $ e {ueValue = newVal}
|
||||
return $ Right $ e {ueValue = EntryValue newVal}
|
||||
|
||||
balanceEntrySet
|
||||
:: (MonadInsertError m, MonadFinance m)
|
||||
|
|
|
|||
|
|
@ -77,17 +77,36 @@ data UpdateEntry i v = UpdateEntry
|
|||
, 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
|
||||
{ utFrom0 :: !(UpdateEntry EntryRId ())
|
||||
, utTo0 :: !(UpdateEntry EntryRId ())
|
||||
, -- for these next three, the Rational number is the balance target (not the
|
||||
-- value of the account)
|
||||
utPairs :: ![(UpdateEntry EntryRId Rational, [UpdateEntry EntryRId Rational])]
|
||||
, utFromUnk :: ![UpdateEntry EntryRId Rational]
|
||||
, utToUnk :: ![UpdateEntry EntryRId Rational]
|
||||
, utToUnkLink0 :: ![UpdateEntry EntryRId ()]
|
||||
, utFromRO :: ![UpdateEntry () Rational]
|
||||
, utToRO :: ![UpdateEntry () Rational]
|
||||
{ utFrom0 :: !UEBlank
|
||||
, utTo0 :: !UEBlank
|
||||
, utPairs :: ![(UEBalance, [UELink])]
|
||||
, utFromUnk :: ![UEBalance]
|
||||
, utToUnk :: ![UEBalance]
|
||||
, utToUnkLink0 :: ![UELink]
|
||||
, utFromRO :: ![UE_RO]
|
||||
, utToRO :: ![UE_RO]
|
||||
, utCurrency :: !CurrencyRId
|
||||
, utDate :: !Day
|
||||
, utTotalValue :: !Rational
|
||||
|
|
|
|||
Loading…
Reference in New Issue