diff --git a/lib/Internal/Database.hs b/lib/Internal/Database.hs index d19f207..889c081 100644 --- a/lib/Internal/Database.hs +++ b/lib/Internal/Database.hs @@ -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 () diff --git a/lib/Internal/History.hs b/lib/Internal/History.hs index 4f60d17..f1291ec 100644 --- a/lib/Internal/History.hs +++ b/lib/Internal/History.hs @@ -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) diff --git a/lib/Internal/Types/Main.hs b/lib/Internal/Types/Main.hs index 435a2b7..3981583 100644 --- a/lib/Internal/Types/Main.hs +++ b/lib/Internal/Types/Main.hs @@ -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