lib/Internal/Database.hs

@@ -516,7 +516,12 @@ readUpdates hashes = do
 
 splitFrom
   :: [(EntryRId, EntryR)]
-  -> InsertExcept (UEBlank, [UE_RO], [UEBalance], Vector (Maybe UEBalance))
+  -> InsertExcept
+      ( 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
@@ -528,14 +533,14 @@ splitFrom from = do
   return (primary, ro, toBal, idxVec)
 
 splitTo
-  :: Vector (Maybe UEBalance)
+  :: Vector (Maybe (UpdateEntry EntryRId Rational))
   -> [(EntryRId, EntryR)]
   -> InsertExcept
-      ( UEBlank
+      ( UpdateEntry EntryRId ()
-      , [UE_RO]
+      , [UpdateEntry () Rational]
-      , [UEBalance]
+      , [UpdateEntry EntryRId Rational]
-      , [UELink]
+      , [UpdateEntry EntryRId ()]
-      , [(UEBalance, [UELink])]
+      , [(UpdateEntry EntryRId Rational, [UpdateEntry EntryRId Rational])]
       )
 splitTo froms tos = do
   -- How to split the credit side of the database transaction in 1024 easy
@@ -555,18 +560,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) = second (groupKey id) $ L.partition ((== 0) . fst) linked
+  let (paired0, pairedN) =
-  let paired0Res = mapErrors (makeLinkUnk . snd) paired0
+        bimap (fmap (uncurry makeUnkUE . snd)) (groupKey id) $
+          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
-  let pairedRes = partitionEithers <$> mapErrors splitPaired pairedN
+  (pairedUnk, pairedRO) <- partitionEithers <$> mapErrors splitPaired pairedN
 
-  combineError paired0Res pairedRes $ \paired0' (pairedUnk, pairedRO) ->
+  return (primary, ro ++ concat pairedRO, toBal, paired0, pairedUnk)
-    (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
@@ -576,19 +581,20 @@ splitTo froms tos = do
     makeLinkUnk (k, e) =
       maybe
         (throwError $ InsertException undefined)
-        (return . makeUE k e . LinkScale)
+        (return . makeUE k e)
         $ entryRDeferred_value e
 
-splitDeferredValue :: (EntryRId, EntryR) -> Either UE_RO UEBalance
+splitDeferredValue
+  :: (EntryRId, EntryR)
+  -> Either (UpdateEntry () Rational) (UpdateEntry EntryRId Rational)
 splitDeferredValue (k, e) =
-  maybe (Left $ makeRoUE e) (Right . fmap BalanceTarget . makeUE k e) $
+  maybe (Left $ makeRoUE e) (Right . makeUE k e) $ entryRDeferred_value 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 () EntryValue
+makeRoUE :: EntryR -> UpdateEntry () Rational
-makeRoUE e = makeUE () e $ EntryValue (entryRValue e)
+makeRoUE e = makeUE () e (entryRValue e)
 
 makeUnkUE :: EntryRId -> EntryR -> UpdateEntry EntryRId ()
 makeUnkUE k e = makeUE k e ()

lib/Internal/History.hs

@@ -9,7 +9,6 @@ where
 import Control.Monad.Except
 import Data.Csv
 import Data.Foldable
-import Database.Persist ((=.))
 import Database.Persist.Monad hiding (get)
 import Internal.Database
 import Internal.Types.Main
@@ -79,11 +78,9 @@ insertHistory
   -> m ()
 insertHistory hs = do
   (toUpdate, toInsert) <- balanceTxs hs
-  mapM_ updateTx toUpdate
+  forM_ (groupWith txCommit toInsert) $ \(c, ts) -> do
-  forM_ (groupKey commitRHash $ (\x -> (txCommit x, x)) <$> toInsert) $
+    ck <- insert c
-    \(c, ts) -> do
+    mapM_ (insertTx ck) ts
-      ck <- insert $ c
-      mapM_ (insertTx ck) ts
 
 --------------------------------------------------------------------------------
 -- low-level transaction stuff
@@ -131,9 +128,6 @@ insertTx c Tx {txDate = d, txDescr = e, txEntries = ss} = do
   k <- insert $ TransactionR c d e anyDeferred
   mapM_ (insertEntry k) ss
 
-updateTx :: MonadSqlQuery m => UEBalanced -> m ()
-updateTx UpdateEntry {ueID, ueValue} = update ueID [EntryRValue =. (unEntryValue ueValue)]
-
 --------------------------------------------------------------------------------
 -- Statements
 
@@ -337,17 +331,17 @@ matchNonDates ms = go ([], [], initZipper ms)
 balanceTxs
   :: (MonadInsertError m, MonadFinance m)
   => [EntryBin]
-  -> m ([UEBalanced], [KeyTx CommitR])
+  -> m ([UpdateEntry EntryRId Rational], [KeyTx CommitR])
 balanceTxs es =
   (first concat . partitionEithers . catMaybes)
-    <$> evalStateT (mapErrors go $ L.sortOn binDate es) M.empty
+    <$> evalStateT (mapM go $ L.sortOn binDate es) M.empty
   where
-    go (ToUpdate utx) = fmap (Just . Left) $ liftInnerS $ rebalanceEntrySet utx
+    go (ToUpdate utx) = (Just . Left) <$> rebalanceEntrySet utx
     go (ToRead ReadEntry {reCurrency, reAcnt, reValue}) = do
       modify $ mapAdd_ (reAcnt, reCurrency) reValue
       return Nothing
     go (ToInsert (t@Tx {txEntries, txDate})) =
-      (\es' -> Just $ Right $ t {txEntries = concat es'})
+      (\es -> Just $ Right $ t {txEntries = concat es})
         <$> mapM (balanceEntrySet txDate) txEntries
 
 binDate :: EntryBin -> Day
@@ -358,11 +352,11 @@ binDate (ToInsert (Tx {txDate})) = txDate
 type EntryBals = M.Map (AccountRId, CurrencyRId) Rational
 
 data UpdateEntryType a
-  = UET_ReadOnly UE_RO
+  = UEReadOnly (UpdateEntry () Rational)
-  | UET_Balance UEBalance
+  | UEBlank (UpdateEntry EntryRId Rational)
-  | UET_Linked a
+  | UEPaired (UpdateEntry EntryRId Rational, UpdateEntry EntryRId a)
 
-rebalanceEntrySet :: UpdateEntrySet -> State EntryBals [UEBalanced]
+rebalanceEntrySet :: UpdateEntrySet -> State EntryBals [UpdateEntry EntryRId Rational]
 rebalanceEntrySet
   UpdateEntrySet
     { utFrom0
@@ -373,75 +367,53 @@ rebalanceEntrySet
     , utFromRO
     , utToRO
     , utCurrency
-    , utToUnkLink0
     , utTotalValue
     } =
     do
       let fs =
-            L.sortOn idx $
+            L.sortOn index $
-              (UET_ReadOnly <$> utFromRO)
+              (UEReadOnly <$> utFromRO)
-                ++ (UET_Balance <$> utFromUnk)
+                ++ (UEBlank <$> utFromUnk)
-                ++ (UET_Linked <$> utPairs)
+                ++ (UEPaired <$> utPairs)
       fs' <- mapM goFrom fs
-      let f0val = utTotalValue - (sum $ fmap value fs')
+      let f0 = utFrom0 {ueValue = utTotalValue - (sum $ fmap value fs')}
-      let f0 = utFrom0 {ueValue = EntryValue f0val}
+      let (fs'', tpairs) = partitionEithers $ concatMap flatten fs'
-      let (tpairs, fs'') = partitionEithers $ concatMap flatten fs'
+      let ts = (Right <$> tpairs) ++ (Right <$> utToUnk) ++ (Left <$> utToRO)
-      let tsLink0 = fmap (\e -> e {ueValue = EntryValue $ -f0val * (unLinkScale $ ueValue e)}) utToUnkLink0
-      let ts =
-            L.sortOn idx2 $
-              (UET_Linked <$> (tpairs ++ tsLink0))
-                ++ (UET_Balance <$> utToUnk)
-                ++ (UET_ReadOnly <$> utToRO)
       (tsRO, tsUnk) <- partitionEithers <$> mapM goTo ts
-      let t0val =
+      let t0 = utTo0 {ueValue = utTotalValue - (sum $ (fmap ueValue tsRO) ++ (fmap ueValue tsUnk))}
-            (EntryValue utTotalValue)
+      return $ f0 : fs'' ++ t0 : tsUnk
-              - (sum $ (fmap ueValue tsRO) ++ (fmap ueValue tsUnk))
-      let t0 = utTo0 {ueValue = t0val}
-      return $ (f0 : (fmap (fmap (EntryValue . unBalanceTarget)) fs'')) ++ (t0 : tsUnk)
     where
-      project f _ _ (UET_ReadOnly e) = f e
+      project f _ _ (UEReadOnly e) = f e
-      project _ f _ (UET_Balance e) = f e
+      project _ f _ (UEBlank e) = f e
-      project _ _ f (UET_Linked p) = f p
+      project _ _ f (UEPaired p) = f p
-      idx = project ueIndex ueIndex (ueIndex . fst)
+      index = project ueIndex ueIndex (ueIndex . fst)
-      idx2 = project ueIndex ueIndex ueIndex
+      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 (UET_ReadOnly e) = do
+      goFrom (UEReadOnly e) = do
-        modify $ mapAdd_ (ueAcnt e, utCurrency) (unEntryValue $ ueValue e)
+        modify $ mapAdd_ (ueAcnt e, utCurrency) (ueValue e)
-        return $ UET_ReadOnly e
+        return $ UEReadOnly e
-      goFrom (UET_Balance e) = do
+      goFrom (UEBlank e) = do
         let key = (ueAcnt e, utCurrency)
         curBal <- gets (M.findWithDefault 0 key)
-        let newVal = unBalanceTarget (ueValue e) - curBal
+        let newVal = ueValue e - curBal
         modify $ mapAdd_ key newVal
-        return $ UET_Balance $ e {ueValue = BalanceTarget newVal}
+        return $ UEBlank $ e {ueValue = newVal}
-      goFrom (UET_Linked (e0, es)) = do
+      goFrom (UEPaired (e0, e1)) = do
         let key = (ueAcnt e0, utCurrency)
         curBal <- gets (M.findWithDefault 0 key)
-        let newVal = unBalanceTarget (ueValue e0) - curBal
+        let newVal = ueValue e0 - curBal
         modify $ mapAdd_ key newVal
-        return $
+        return $ UEPaired $ (e0 {ueValue = newVal}, e1 {ueValue = -newVal})
-          UET_Linked $
+      goTo (Left e) = do
-            ( e0 {ueValue = BalanceTarget newVal}
+        modify $ mapAdd_ (ueAcnt e, utCurrency) (ueValue e)
-            , 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 (UET_Linked e) = do
+      goTo (Right 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 = unBalanceTarget (ueValue e) - curBal
+        let newVal = ueValue e - curBal
         modify $ mapAdd_ key newVal
-        return $ Right $ e {ueValue = EntryValue newVal}
+        return $ Right $ e {ueValue = newVal}
 
 balanceEntrySet
   :: (MonadInsertError m, MonadFinance m)
@@ -463,8 +435,8 @@ balanceEntrySet
 
       -- resolve accounts and balance debit entries since we need an array
       -- of debit entries for linked credit entries later
-      let balFromEntry = balanceEntry (\a -> liftInnerS . balanceDeferred curID a) curID
+      let balFromEntry = balanceEntry (balanceDeferred curID) curID
-      fs' <- doEntries balFromEntry curID esTotalValue f0 fs (NE.iterate (+ (-1)) (-1))
+      fs' <- doEntries balFromEntry curID esTotalValue f0 fs (NE.iterate (-1) (-1))
       let fv = V.fromList $ fmap (eValue . feEntry) fs'
 
       -- finally resolve credit entries
@@ -474,15 +446,15 @@ balanceEntrySet
 
 doEntries
   :: (MonadInsertError m, MonadFinance m)
-  => (Int -> Entry AcntID v TagID -> StateT EntryBals m (FullEntry AccountRId CurrencyRId TagRId))
+  => (Int -> Entry AcntID v t -> State EntryBals (FullEntry AccountRId CurrencyRId t))
   -> CurrencyRId
   -> Rational
-  -> Entry AcntID () TagID
+  -> Entry AcntID () t
-  -> [Entry AcntID v TagID]
+  -> [Entry AcntID v t]
   -> NonEmpty Int
-  -> StateT EntryBals m [FullEntry AccountRId CurrencyRId TagRId]
+  -> StateT EntryBals m [FullEntry AccountRId CurrencyRId t]
 doEntries f curID tot e es (i0 :| iN) = do
-  es' <- mapM (uncurry f) $ zip iN es
+  es' <- liftInnerS $ mapM (uncurry f) $ zip iN es
   let val0 = tot - entrySum es'
   e' <- balanceEntry (\_ _ -> return (val0, Nothing)) curID i0 e
   return $ e' : es'
@@ -493,20 +465,19 @@ liftInnerS :: Monad m => StateT e Identity a -> StateT e m a
 liftInnerS = mapStateT (return . runIdentity)
 
 balanceLinked
-  :: MonadInsertError m
+  :: Vector Rational
-  => Vector Rational
   -> CurrencyRId
   -> Natural
   -> AccountRId
   -> LinkDeferred Rational
-  -> StateT EntryBals m (Rational, Maybe DBDeferred)
+  -> StateT EntryBals Identity (Rational, Maybe DBDeferred)
 balanceLinked from curID precision acntID lg = case lg of
-  (LinkIndex LinkedNumGetter {lngIndex, lngScale}) -> do
+  (LinkIndex g@LinkedNumGetter {lngIndex, lngScale}) -> do
     let res = fmap (go lngScale) $ from V.!? fromIntegral lngIndex
     case res of
       Just v -> return $ (v, Just $ EntryLinked lngIndex $ toRational lngScale)
       Nothing -> throwError undefined
-  (LinkDeferred d) -> liftInnerS $ balanceDeferred curID acntID d
+  (LinkDeferred d) -> balanceDeferred curID acntID d
   where
     go s = roundPrecision precision . (* s) . fromRational
 
@@ -524,22 +495,22 @@ balanceEntry
   => (AccountRId -> v -> StateT EntryBals m (Rational, Maybe DBDeferred))
   -> CurrencyRId
   -> Int
-  -> Entry AcntID v TagID
+  -> Entry AcntID v t
-  -> StateT EntryBals m (FullEntry AccountRId CurrencyRId TagRId)
+  -> StateT EntryBals m (FullEntry AccountRId CurrencyRId t)
-balanceEntry f curID idx e@Entry {eValue, eAcnt, eTags} = do
+balanceEntry f curID index e@Entry {eValue, eAcnt} = do
-  let acntRes = lookupAccount eAcnt
+  (acntID, sign, _) <- lookupAccount eAcnt
-  let tagRes = mapErrors lookupTag eTags
+  let s = fromIntegral $ sign2Int sign
-  combineErrorM acntRes tagRes $ \(acntID, sign, _) tags -> do
+  (newVal, deferred) <- f acntID eValue
-    let s = fromIntegral $ sign2Int sign
+  modify (mapAdd_ (acntID, curID) newVal)
-    (newVal, deferred) <- f acntID eValue
+  return $
-    modify (mapAdd_ (acntID, curID) newVal)
+    FullEntry
-    return $
+      { feEntry = e {eValue = s * newVal, eAcnt = acntID}
-      FullEntry
+      , feCurrency = curID
-        { feEntry = e {eValue = s * newVal, eAcnt = acntID, eTags = tags}
+      , feDeferred = deferred
-        , feCurrency = curID
+      , feIndex = index
-        , feDeferred = deferred
+      }
-        , feIndex = idx
+  where
-        }
+    key = (eAcnt, curID)
 
 findBalance :: AccountRId -> CurrencyRId -> Bool -> Rational -> State EntryBals Rational
 findBalance acnt cur toBal v = do

lib/Internal/Types/Main.hs

@@ -77,36 +77,17 @@ 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 :: !UEBlank
+  { utFrom0 :: !(UpdateEntry EntryRId ())
-  , utTo0 :: !UEBlank
+  , utTo0 :: !(UpdateEntry EntryRId ())
-  , utPairs :: ![(UEBalance, [UELink])]
+  , -- for these next three, the Rational number is the balance target (not the
-  , utFromUnk :: ![UEBalance]
+    -- value of the account)
-  , utToUnk :: ![UEBalance]
+    utPairs :: ![(UpdateEntry EntryRId Rational, [UpdateEntry EntryRId Rational])]
-  , utToUnkLink0 :: ![UELink]
+  , utFromUnk :: ![UpdateEntry EntryRId Rational]
-  , utFromRO :: ![UE_RO]
+  , utToUnk :: ![UpdateEntry EntryRId Rational]
-  , utToRO :: ![UE_RO]
+  , utToUnkLink0 :: ![UpdateEntry EntryRId ()]
+  , utFromRO :: ![UpdateEntry () Rational]
+  , utToRO :: ![UpdateEntry () Rational]
   , utCurrency :: !CurrencyRId
   , utDate :: !Day
   , utTotalValue :: !Rational