WIP use newtypes to keep update balancer sane

lib/Internal/Database.hs

@@ -516,12 +516,7 @@ readUpdates hashes = do
 
 splitFrom
   :: [(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
   -- 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 ()
+      ( UEBlank
-      , [UpdateEntry () Rational]
+      , [UE_RO]
-      , [UpdateEntry EntryRId Rational]
+      , [UEBalance]
-      , [UpdateEntry EntryRId ()]
+      , [UELink]
-      , [(UpdateEntry EntryRId Rational, [UpdateEntry EntryRId Rational])]
+      , [(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) =
+  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
   --    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
+splitDeferredValue :: (EntryRId, EntryR) -> Either UE_RO UEBalance
-  :: (EntryRId, EntryR)
-  -> Either (UpdateEntry () Rational) (UpdateEntry EntryRId Rational)
 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 :: EntryR -> UpdateEntry () EntryValue
-makeRoUE e = makeUE () e (entryRValue e)
+makeRoUE e = makeUE () e $ EntryValue (entryRValue e)
 
 makeUnkUE :: EntryRId -> EntryR -> UpdateEntry EntryRId ()
 makeUnkUE k e = makeUE k e ()

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)
+  = 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
   UpdateEntrySet
     { utFrom0
@@ -367,53 +367,73 @@ rebalanceEntrySet
     , utFromRO
     , utToRO
     , utCurrency
+    , utToUnkLink0
     , utTotalValue
     } =
     do
       let fs =
             L.sortOn index $
-              (UEReadOnly <$> utFromRO)
+              (UET_ReadOnly <$> utFromRO)
-                ++ (UEBlank <$> utFromUnk)
+                ++ (UET_Balance <$> utFromUnk)
-                ++ (UEPaired <$> utPairs)
+                ++ (UET_Linked <$> utPairs)
       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
-      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
-      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)
-      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
-      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)
         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}
+        return $ UET_Balance $ e {ueValue = BalanceTarget newVal}
-      goFrom (UEPaired (e0, e1)) = do
+      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})
+        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
-      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)

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 ())
+  { 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
   , utDate :: !Day
   , utTotalValue :: !Rational