WIP make budget and statement paths use same machinery

dhall/Types.dhall

@@ -402,13 +402,15 @@ let EntryNumGetter =
 
     LookupN: lookup the value from a field
     ConstN: a constant value
-    AmountN: the value of the 'Amount' column
+    AmountN: the value of the 'Amount' column times a scaling factor
     BalanceN: the amount required to make the target account reach a balance
+    PercentN: the amount required to make an account reach a given percentage
     -}
       < LookupN : Text
       | ConstN : Double
       | AmountN : Double
       | BalanceN : Double
+      | PercentN : Double
       >
 
 let LinkedNumGetter =
@@ -679,6 +681,58 @@ let Amount =
       \(v : Type) ->
         { amtWhen : w, amtValue : v, amtDesc : Text }
 
+let Exchange =
+    {-
+    A currency exchange.
+    -}
+      { xFromCur :
+          {-
+          Starting currency of the exchange.
+          -}
+          CurID
+      , xToCur :
+          {-
+          Ending currency of the exchange.
+          -}
+          CurID
+      , xAcnt :
+          {-
+          account in which the exchange will be documented.
+          -}
+          AcntID
+      , xRate :
+          {-
+          The exchange rate between the currencies.
+          -}
+          Double
+      }
+
+let TransferCurrency =
+    {-
+    Means to represent currency in a transcaction; either single fixed currency
+    or two currencies with an exchange rate.
+    -}
+      < NoX : CurID | X : Exchange >
+
+let TransferType =
+    {-
+    The type of a budget transfer.
+
+    BTFixed: Tranfer a fixed amount
+    BTPercent: Transfer a percent of the source account to destination
+    BTTarget: Transfer an amount such that the destination has a given target
+              value
+    -}
+      < TPercent | TBalance | TFixed >
+
+let TransferValue =
+    {-
+    Means to determine the value of a budget transfer.
+    -}
+      { Type = { tvVal : Double, tvType : TransferType }
+      , default.tvType = TransferType.TFixed
+      }
+
 let Transfer =
     {-
     1-1 transaction(s) between two accounts.
@@ -697,7 +751,7 @@ let HistTransfer =
     {-
     A manually specified historical transfer
     -}
-      Transfer AcntID CurID DatePat Double
+      Transfer AcntID CurID DatePat TransferValue.Type
 
 let Statement =
     {-
@@ -734,38 +788,6 @@ let History =
     -}
       < HistTransfer : HistTransfer | HistStatement : Statement >
 
-let Exchange =
-    {-
-    A currency exchange.
-    -}
-      { xFromCur :
-          {-
-          Starting currency of the exchange.
-          -}
-          CurID
-      , xToCur :
-          {-
-          Ending currency of the exchange.
-          -}
-          CurID
-      , xAcnt :
-          {-
-          account in which the exchange will be documented.
-          -}
-          AcntID
-      , xRate :
-          {-
-          The exchange rate between the currencies.
-          -}
-          Double
-      }
-
-let BudgetCurrency =
-    {-
-    A 'currency' in the budget; either a fixed currency or an exchange
-    -}
-      < NoX : CurID | X : Exchange >
-
 let TaggedAcnt =
     {-
     An account with a tag
@@ -1037,17 +1059,6 @@ let TransferMatcher =
         }
       }
 
-let BudgetTransferType =
-    {-
-    The type of a budget transfer.
-
-    BTFixed: Tranfer a fixed amount
-    BTPercent: Transfer a percent of the source account to destination
-    BTTarget: Transfer an amount such that the destination has a given target
-              value
-    -}
-      < BTPercent | BTTarget | BTFixed >
-
 let ShadowTransfer =
     {-
     A transaction analogous to another transfer with given properties.
@@ -1066,7 +1077,7 @@ let ShadowTransfer =
           {-
           Currency of this transfer.
           -}
-          BudgetCurrency
+          TransferCurrency
       , stDesc :
           {-
           Description of this transfer.
@@ -1080,7 +1091,7 @@ let ShadowTransfer =
           specified in other fields of this type.
           -}
           TransferMatcher.Type
-      , stType : BudgetTransferType
+      , stType : TransferType
       , stRatio :
           {-
           Fixed multipler to translate value of matched transfer to this one.
@@ -1088,17 +1099,11 @@ let ShadowTransfer =
           Double
       }
 
-let BudgetTransferValue =
-    {-
-    Means to determine the value of a budget transfer.
-    -}
-      { btVal : Double, btType : BudgetTransferType }
-
 let BudgetTransfer =
     {-
     A manually specified transaction for a budget
     -}
-      Transfer TaggedAcnt BudgetCurrency DatePat BudgetTransferValue
+      Transfer TaggedAcnt TransferCurrency DatePat TransferValue.Type
 
 let Budget =
     {-
@@ -1168,7 +1173,7 @@ in  { CurID
     , TransferMatcher
     , ShadowTransfer
     , AcntSet
-    , BudgetCurrency
+    , TransferCurrency
     , Exchange
     , TaggedAcnt
     , AccountTree
@@ -1180,8 +1185,8 @@ in  { CurID
     , TaxProgression
     , TaxMethod
     , TaxValue
-    , BudgetTransferValue
+    , TransferValue
-    , BudgetTransferType
+    , TransferType
     , TxGetter
     , TxSubGetter
     , TxHalfGetter

lib/Internal/Budget.hs

@@ -59,6 +59,8 @@ insertBudget
           ++ (alloAcnt <$> bgtTax)
           ++ (alloAcnt <$> bgtPosttax)
 
+-- TODO need to systematically make this function match the history version,
+-- which will allow me to use the same balancing algorithm for both
 balanceTransfers :: [UnbalancedTransfer] -> [BalancedTransfer]
 balanceTransfers = snd . L.mapAccumR go M.empty . reverse . L.sortOn ftWhen
   where
@@ -527,8 +529,64 @@ data UnbalancedValue = UnbalancedValue
   }
   deriving (Show)
 
+-- TODO need to make this into the same ish thing as the Tx/EntrySet structs
+-- in the history algorithm, which will entail resolving the budget currency
+-- stuff earlier in the chain, and preloading multiple entries into this thing
+-- before balancing.
 type UnbalancedTransfer = FlatTransfer UnbalancedValue
 
+ubt2tx :: UnbalancedTransfer -> Tx [EntrySet AcntID CurID TagID Rational] BudgetMeta
+ubt2tx
+  FlatTransfer
+    { ftFrom
+    , ftTo
+    , ftValue
+    , ftWhen
+    , ftDesc
+    , ftMeta
+    , ftCur
+    } =
+    Tx
+      { txDescr = ftDesc
+      , txDate = ftWhen
+      , txEntries = entries ftCur
+      , txCommit = ftMeta
+      }
+    where
+      entries (NoX curid) = [pair curid ftFrom ftTo ftValue]
+      entries (X Exchange {xFromCur, xToCur, xAcnt, xRate}) =
+        let middle = TaggedAcnt xAcnt []
+            p1 = pair xFromCur ftFrom middle ftValue
+            p2 = pair xToCur middle ftTo (ftValue * roundPrecision 3 xRate)
+         in [p1, p2]
+      pair c (TaggedAcnt fa fts) (TaggedAcnt ta tts) v =
+        EntrySet
+          { esTotalValue = v
+          , esCurrency = c
+          , esFrom =
+              HalfEntrySet
+                { hesPrimary =
+                    Entry
+                      { eValue = ()
+                      , eComment = ""
+                      , eAcnt = fa
+                      , eTags = fts
+                      }
+                , hesOther = []
+                }
+          , esTo =
+              HalfEntrySet
+                { hesPrimary =
+                    Entry
+                      { eValue = ()
+                      , eComment = ""
+                      , eAcnt = ta
+                      , eTags = tts
+                      }
+                , hesOther = []
+                }
+          }
+
 type BalancedTransfer = FlatTransfer Rational
 
 data FlatTransfer v = FlatTransfer

lib/Internal/Database.hs

@@ -193,7 +193,7 @@ currencyMap =
     . fmap
       ( \e ->
           ( currencyRSymbol $ entityVal e
-          , (entityKey e, fromIntegral $ currencyRPrecision $ entityVal e)
+          , CurrencyPrec (entityKey e) $ fromIntegral $ currencyRPrecision $ entityVal e
           )
       )
 
@@ -424,24 +424,25 @@ whenHash_ t o f = do
 insertEntry :: MonadSqlQuery m => TransactionRId -> KeyEntry -> m EntryRId
 insertEntry
   t
-  FullEntry
+  InsertEntry
     { feEntry = Entry {eValue, eTags, eAcnt, eComment}
     , feCurrency
     , feIndex
     , feDeferred
     } =
     do
-      k <- insert $ EntryR t feCurrency eAcnt eComment eValue feIndex defval deflink
+      k <- insert $ EntryR t feCurrency eAcnt eComment eValue feIndex cval ctype deflink
       mapM_ (insert_ . TagRelationR k) eTags
       return k
     where
-      (defval, deflink) = case feDeferred of
+      (cval, ctype, deflink) = case feDeferred of
-        (Just (EntryLinked index scale)) -> (Just scale, Just $ fromIntegral index)
+        (Just (EntryLinked index scale)) -> (Just scale, Nothing, Just $ fromIntegral index)
-        (Just (EntryBalance target)) -> (Just target, Nothing)
+        (Just (EntryBalance target)) -> (Just target, Just TBalance, Nothing)
-        Nothing -> (Nothing, Nothing)
+        (Just (EntryPercent target)) -> (Just target, Just TPercent, Nothing)
+        Nothing -> (Nothing, Just TFixed, Nothing)
 
 resolveEntry :: (MonadInsertError m, MonadFinance m) => BalEntry -> m KeyEntry
-resolveEntry s@FullEntry {feEntry = e@Entry {eValue, eTags, eAcnt}, feCurrency} = do
+resolveEntry s@InsertEntry {feEntry = e@Entry {eValue, eTags, eAcnt}, feCurrency} = do
   let aRes = lookupAccountKey eAcnt
   let cRes = lookupCurrencyKey feCurrency
   let sRes = lookupAccountSign eAcnt
@@ -516,26 +517,26 @@ readUpdates hashes = do
 
 splitFrom
   :: [(EntryRId, EntryR)]
-  -> InsertExcept (UEBlank, [UE_RO], [UEBalance], Vector (Maybe UEBalance))
+  -> InsertExcept (UEBlank, [UE_RO], [UEUnk], Vector (Maybe UEUnk))
 splitFrom from = do
   -- ASSUME entries are sorted by index
   (primary, rest) <- case from of
     ((i, e) : xs) -> return (makeUnkUE i e, xs)
     _ -> throwError $ InsertException undefined
-  let rest' = fmap splitDeferredValue rest
+  rest' <- mapErrors splitDeferredValue rest
   let idxVec = V.fromList $ fmap (either (const Nothing) Just) rest'
   let (ro, toBal) = partitionEithers rest'
   return (primary, ro, toBal, idxVec)
 
 splitTo
-  :: Vector (Maybe UEBalance)
+  :: Vector (Maybe UEUnk)
   -> [(EntryRId, EntryR)]
   -> InsertExcept
       ( UEBlank
       , [UE_RO]
-      , [UEBalance]
+      , [UEUnk]
       , [UELink]
-      , [(UEBalance, [UELink])]
+      , [(UEUnk, [UELink])]
       )
 splitTo froms tos = do
   -- How to split the credit side of the database transaction in 1024 easy
@@ -552,7 +553,7 @@ splitTo froms tos = do
   let (unlinked, linked) = partitionEithers $ fmap splitLinked rest
 
   -- 2. Split unlinked based on if they have a balance target
-  let (ro, toBal) = partitionEithers $ fmap splitDeferredValue unlinked
+  let unlinkedRes = partitionEithers <$> mapErrors 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
@@ -565,10 +566,11 @@ splitTo froms tos = do
   --    then consider the linked entry as another credit read-only entry
   let pairedRes = partitionEithers <$> mapErrors splitPaired pairedN
 
-  combineError paired0Res pairedRes $ \paired0' (pairedUnk, pairedRO) ->
+  combineError3 unlinkedRes paired0Res pairedRes $
+    \(ro, toBal) paired0' (pairedUnk, pairedRO) ->
       (primary, ro ++ concat pairedRO, toBal, paired0', pairedUnk)
   where
-    splitLinked t@(_, e) = maybe (Left t) (Right . (,t)) $ entryRDeferred_link e
+    splitLinked t@(_, e) = maybe (Left t) (Right . (,t)) $ entryRCachedLink e
     splitPaired (lnk, ts) = case froms V.!? (lnk - 1) of
       Just (Just f) -> Left . (f,) <$> mapErrors makeLinkUnk ts
       Just Nothing -> return $ Right $ makeRoUE . snd <$> ts
@@ -577,18 +579,22 @@ splitTo froms tos = do
       maybe
         (throwError $ InsertException undefined)
         (return . makeUE k e . LinkScale)
-        $ entryRDeferred_value e
+        $ entryRCachedValue e
 
-splitDeferredValue :: (EntryRId, EntryR) -> Either UE_RO UEBalance
+splitDeferredValue :: (EntryRId, EntryR) -> InsertExcept (Either UE_RO UEUnk)
-splitDeferredValue (k, e) =
+splitDeferredValue (k, e) = case (entryRCachedValue e, entryRCachedType e) of
-  maybe (Left $ makeRoUE e) (Right . fmap BalanceTarget . makeUE k e) $
+  (Nothing, Just TFixed) -> return $ Left $ makeRoUE e
-    entryRDeferred_value e
+  (Just v, Just TBalance) -> go EVBalance v
+  (Just v, Just TPercent) -> go EVPercent v
+  _ -> throwError $ InsertException undefined
+  where
+    go c = return . Right . fmap c . makeUE k 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 () StaticValue
-makeRoUE e = makeUE () e $ EntryValue (entryRValue e)
+makeRoUE e = makeUE () e $ StaticValue (entryRValue e)
 
 makeUnkUE :: EntryRId -> EntryR -> UpdateEntry EntryRId ()
 makeUnkUE k e = makeUE k e ()

lib/Internal/History.hs

@@ -39,7 +39,7 @@ import qualified RIO.Vector as V
 readHistTransfer
   :: (MonadInsertError m, MonadFinance m)
   => HistTransfer
-  -> m [DeferredTx CommitR]
+  -> m [Tx CommitR]
 readHistTransfer
   m@Transfer
     { transFrom = from
@@ -49,11 +49,11 @@ readHistTransfer
     } =
     whenHash0 CTManual m [] $ \c -> do
       bounds <- askDBState kmStatementInterval
-      let precRes = lookupCurrencyPrec u
+      let curRes = lookupCurrency u
       let go Amount {amtWhen, amtValue, amtDesc} = do
             let dayRes = liftExcept $ expandDatePat bounds amtWhen
-            (days, precision) <- combineError dayRes precRes (,)
+            (days, cur) <- combineError dayRes curRes (,)
-            let tx day = txPair c day from to u (roundPrecision precision amtValue) amtDesc
+            let tx day = txPair c day from to cur amtValue amtDesc
             return $ fmap tx days
       concat <$> mapErrors go amts
 
@@ -61,7 +61,7 @@ readHistStmt
   :: (MonadUnliftIO m, MonadFinance m)
   => FilePath
   -> Statement
-  -> m (Either CommitR [DeferredTx CommitR])
+  -> m (Either CommitR [Tx CommitR])
 readHistStmt root i = eitherHash CTImport i return $ \c -> do
   bs <- readImport root i
   bounds <- askDBState kmStatementInterval
@@ -80,9 +80,9 @@ insertHistory
 insertHistory hs = do
   (toUpdate, toInsert) <- balanceTxs hs
   mapM_ updateTx toUpdate
-  forM_ (groupKey commitRHash $ (\x -> (txCommit x, x)) <$> toInsert) $
+  forM_ (groupKey commitRHash $ (\x -> (itxCommit x, x)) <$> toInsert) $
     \(c, ts) -> do
-      ck <- insert $ c
+      ck <- insert c
       mapM_ (insertTx ck) ts
 
 --------------------------------------------------------------------------------
@@ -94,23 +94,23 @@ txPair
   -> Day
   -> AcntID
   -> AcntID
-  -> CurID
+  -> CurrencyPrec
-  -> Rational
+  -> Double
   -> T.Text
-  -> DeferredTx CommitR
+  -> Tx CommitR
 txPair commit day from to cur val desc =
   Tx
     { txDescr = desc
     , txDate = day
     , txCommit = commit
-    , txEntries =
+    , txPrimary =
-        [ EntrySet
+        EntrySet
-            { esTotalValue = -val
+          { esTotalValue = -(roundPrecisionCur cur val)
           , esCurrency = cur
           , esFrom = HalfEntrySet {hesPrimary = entry from, hesOther = []}
           , esTo = HalfEntrySet {hesPrimary = entry to, hesOther = []}
           }
-        ]
+    , txOther = []
     }
   where
     entry a =
@@ -125,31 +125,27 @@ txPair commit day from to cur val desc =
 -- resolveTx t@Tx {txEntries = ss} =
 --   (\kss -> t {txEntries = kss}) <$> mapErrors resolveEntry ss
 
-insertTx :: MonadSqlQuery m => CommitRId -> (KeyTx CommitR) -> m ()
+insertTx :: MonadSqlQuery m => CommitRId -> InsertTx -> m ()
-insertTx c Tx {txDate = d, txDescr = e, txEntries = ss} = do
+insertTx c InsertTx {itxDate = d, itxDescr = e, itxEntries = ss} = do
   let anyDeferred = any (isJust . feDeferred) ss
   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)]
+updateTx UpdateEntry {ueID, ueValue} = update ueID [EntryRValue =. unStaticValue ueValue]
 
 --------------------------------------------------------------------------------
 -- Statements
 
 -- TODO this probably won't scale well (pipes?)
-readImport :: (MonadUnliftIO m, MonadFinance m) => FilePath -> Statement -> m [DeferredTx ()]
+readImport :: (MonadUnliftIO m, MonadFinance m) => FilePath -> Statement -> m [Tx ()]
 readImport root Statement {stmtTxOpts, stmtParsers, stmtSkipLines, stmtDelim, stmtPaths} = do
   let ores = compileOptions stmtTxOpts
   let cres = combineErrors $ compileMatch <$> stmtParsers
   (compiledOptions, compiledMatches) <- liftIOExcept $ combineError ores cres (,)
   let readStmt = readImport_ stmtSkipLines stmtDelim compiledOptions
   records <- L.sort . concat <$> mapErrorsIO readStmt paths
-  m <- askDBState kmCurrency
+  fromEither =<< runExceptT (matchRecords compiledMatches records)
-  fromEither $
-    flip runReader m $
-      runExceptT $
-        matchRecords compiledMatches records
   where
     paths = (root </>) <$> stmtPaths
 
@@ -184,13 +180,11 @@ parseTxRecord p TxOpts {toDate, toAmountFmt, toDesc, toAmount, toOther, toDateFm
       d' <- parseTimeM True defaultTimeLocale (T.unpack toDateFmt) d
       return $ Just $ TxRecord d' a e os p
 
--- TODO need to somehow balance temporally here (like I do in the budget for
+matchRecords :: MonadFinance m => [MatchRe] -> [TxRecord] -> InsertExceptT m [Tx ()]
--- directives that "pay off" a balance)
-matchRecords :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM [DeferredTx ()]
 matchRecords ms rs = do
   (matched, unmatched, notfound) <- matchAll (matchPriorities ms) rs
   case (matched, unmatched, notfound) of
-    (ms_, [], []) -> return ms_ -- liftInner $ combineErrors $ fmap balanceTx ms_
+    (ms_, [], []) -> return ms_
     (_, us, ns) -> throwError $ InsertException [StatementError us ns]
 
 matchPriorities :: [MatchRe] -> [MatchGroup]
@@ -245,9 +239,10 @@ zipperSlice f x = go
         LT -> z
 
 zipperMatch
-  :: Unzipped MatchRe
+  :: MonadFinance m
+  => Unzipped MatchRe
   -> TxRecord
-  -> InsertExceptT CurrencyM (Zipped MatchRe, MatchRes (DeferredTx ()))
+  -> InsertExceptT m (Zipped MatchRe, MatchRes (Tx ()))
 zipperMatch (Unzipped bs cs as) x = go [] cs
   where
     go _ [] = return (Zipped bs $ cs ++ as, MatchFail)
@@ -261,9 +256,10 @@ zipperMatch (Unzipped bs cs as) x = go [] cs
            in return (Zipped bs $ ps ++ ms' ++ as, skipOrPass)
 
 zipperMatch'
-  :: Zipped MatchRe
+  :: MonadFinance m
+  => Zipped MatchRe
   -> TxRecord
-  -> InsertExceptT CurrencyM (Zipped MatchRe, MatchRes (DeferredTx ()))
+  -> InsertExceptT m (Zipped MatchRe, MatchRes (Tx ()))
 zipperMatch' z x = go z
   where
     go (Zipped bs (a : as)) = do
@@ -280,7 +276,11 @@ matchDec m = case spTimes m of
   Just n -> Just $ m {spTimes = Just $ n - 1}
   Nothing -> Just m
 
-matchAll :: [MatchGroup] -> [TxRecord] -> InsertExceptT CurrencyM ([DeferredTx ()], [TxRecord], [MatchRe])
+matchAll
+  :: MonadFinance m
+  => [MatchGroup]
+  -> [TxRecord]
+  -> InsertExceptT m ([Tx ()], [TxRecord], [MatchRe])
 matchAll = go ([], [])
   where
     go (matched, unused) gs rs = case (gs, rs) of
@@ -290,13 +290,21 @@ matchAll = go ([], [])
         (ts, unmatched, us) <- matchGroup g rs
         go (ts ++ matched, us ++ unused) gs' unmatched
 
-matchGroup :: MatchGroup -> [TxRecord] -> InsertExceptT CurrencyM ([DeferredTx ()], [TxRecord], [MatchRe])
+matchGroup
+  :: MonadFinance m
+  => MatchGroup
+  -> [TxRecord]
+  -> InsertExceptT m ([Tx ()], [TxRecord], [MatchRe])
 matchGroup MatchGroup {mgDate = ds, mgNoDate = ns} rs = do
   (md, rest, ud) <- matchDates ds rs
   (mn, unmatched, un) <- matchNonDates ns rest
   return (md ++ mn, unmatched, filter ((/= Nothing) . spTimes) $ ud ++ un)
 
-matchDates :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM ([DeferredTx ()], [TxRecord], [MatchRe])
+matchDates
+  :: MonadFinance m
+  => [MatchRe]
+  -> [TxRecord]
+  -> InsertExceptT m ([Tx ()], [TxRecord], [MatchRe])
 matchDates ms = go ([], [], initZipper ms)
   where
     go (matched, unmatched, z) [] =
@@ -317,7 +325,11 @@ matchDates ms = go ([], [], initZipper ms)
           go (m, u, z') rs
     findDate m r = maybe EQ (`compareDate` trDate r) $ spDate m
 
-matchNonDates :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM ([DeferredTx ()], [TxRecord], [MatchRe])
+matchNonDates
+  :: MonadFinance m
+  => [MatchRe]
+  -> [TxRecord]
+  -> InsertExceptT m ([Tx ()], [TxRecord], [MatchRe])
 matchNonDates ms = go ([], [], initZipper ms)
   where
     go (matched, unmatched, z) [] =
@@ -337,18 +349,29 @@ matchNonDates ms = go ([], [], initZipper ms)
 balanceTxs
   :: (MonadInsertError m, MonadFinance m)
   => [EntryBin]
-  -> m ([UEBalanced], [KeyTx CommitR])
+  -> m ([UEBalanced], [InsertTx])
-balanceTxs es =
+balanceTxs ebs =
   first concat . partitionEithers . catMaybes
-    <$> evalStateT (mapErrors go $ L.sortOn binDate es) M.empty
+    <$> evalStateT (mapErrors go $ L.sortOn binDate ebs) M.empty
   where
     go (ToUpdate utx) = fmap (Just . Left) $ liftInnerS $ rebalanceEntrySet utx
     go (ToRead ReadEntry {reCurrency, reAcnt, reValue}) = do
       modify $ mapAdd_ (reAcnt, reCurrency) reValue
       return Nothing
-    go (ToInsert t@Tx {txEntries}) =
+    go (ToInsert Tx {txPrimary, txOther, txDescr, txCommit, txDate}) =
-      (\es' -> Just $ Right $ t {txEntries = concat es'})
+      let res0 = balanceEntrySet (\_ _ v -> return v) txPrimary
-        <$> mapErrors balanceEntrySet txEntries
+          resN = mapErrors (balanceEntrySet primaryBalance) txOther
+       in combineError res0 resN $ \e es ->
+            -- TODO repacking a Tx into almost the same record seems stupid
+            Just $
+              Right $
+                InsertTx
+                  { itxDescr = txDescr
+                  , itxDate = txDate
+                  , itxEntries = concat $ e : es
+                  , itxCommit = txCommit
+                  }
+    primaryBalance Entry {eAcnt} c (EntryValue t v) = findBalance eAcnt c t v
 
 binDate :: EntryBin -> Day
 binDate (ToUpdate UpdateEntrySet {utDate}) = utDate
@@ -359,9 +382,10 @@ type EntryBals = M.Map (AccountRId, CurrencyRId) Rational
 
 data UpdateEntryType a
   = UET_ReadOnly UE_RO
-  | UET_Balance UEBalance
+  | UET_Unk UEUnk
   | UET_Linked a
 
+-- TODO make sure new values are rounded properly here
 rebalanceEntrySet :: UpdateEntrySet -> State EntryBals [UEBalanced]
 rebalanceEntrySet
   UpdateEntrySet
@@ -377,112 +401,124 @@ rebalanceEntrySet
     , utTotalValue
     } =
     do
-      let fs =
+      (f0val, (tpairs, fs)) <-
+        fmap (second partitionEithers) $
+          foldM goFrom (utTotalValue, []) $
             L.sortOn idx $
               (UET_ReadOnly <$> utFromRO)
-                ++ (UET_Balance <$> utFromUnk)
+                ++ (UET_Unk <$> utFromUnk)
                 ++ (UET_Linked <$> utPairs)
-      fs' <- mapM goFrom fs
+      let f0 = utFrom0 {ueValue = StaticValue f0val}
-      let f0val = utTotalValue - sum (fmap value fs')
+      let tsLink0 = fmap (unlink (-f0val)) utToUnkLink0
-      let f0 = utFrom0 {ueValue = EntryValue f0val}
+      (t0val, tsUnk) <-
-      let (tpairs, fs'') = partitionEithers $ concatMap flatten fs'
+        fmap (second catMaybes) $
-      let tsLink0 = fmap (\e -> e {ueValue = EntryValue $ -f0val * unLinkScale (ueValue e)}) utToUnkLink0
+          foldM goTo (-utTotalValue, []) $
-      let ts =
             L.sortOn idx2 $
               (UET_Linked <$> (tpairs ++ tsLink0))
-                ++ (UET_Balance <$> utToUnk)
+                ++ (UET_Unk <$> utToUnk)
                 ++ (UET_ReadOnly <$> utToRO)
-      (tsRO, tsUnk) <- partitionEithers <$> mapM goTo ts
+      let t0 = utTo0 {ueValue = StaticValue t0val}
-      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 _ _ (UET_ReadOnly e) = f e
-      project _ f _ (UET_Balance e) = f e
+      project _ f _ (UET_Unk e) = f e
       project _ _ f (UET_Linked p) = f p
       idx = project ueIndex ueIndex (ueIndex . fst)
       idx2 = project ueIndex ueIndex ueIndex
-      value =
+      -- TODO the sum accumulator thing is kinda awkward
-        project
+      goFrom (tot, es) (UET_ReadOnly e) = do
-          (unEntryValue . ueValue)
+        v <- updateFixed e
-          (unBalanceTarget . ueValue)
+        return (tot - v, es)
-          (unBalanceTarget . ueValue . fst)
+      goFrom (tot, esPrev) (UET_Unk e) = do
-      flatten = project (const []) ((: []) . Right) (\(a, bs) -> Right a : (Left <$> bs))
+        v <- updateUnknown e
-      -- TODO the following is wetter than the average groupie
+        return (tot - v, Right e {ueValue = StaticValue v} : esPrev)
-      goFrom (UET_ReadOnly e) = do
+      goFrom (tot, esPrev) (UET_Linked (e0, es)) = do
-        modify $ mapAdd_ (ueAcnt e, utCurrency) (unEntryValue $ ueValue e)
+        v <- updateUnknown e0
-        return $ UET_ReadOnly e
+        let e0' = Right $ e0 {ueValue = StaticValue v}
-      goFrom (UET_Balance e) = do
+        let es' = fmap (Left . unlink (-v)) es
+        return (tot - v, (e0' : es') ++ esPrev)
+      goTo (tot, esPrev) (UET_ReadOnly e) = do
+        v <- updateFixed e
+        return (tot - v, esPrev)
+      goTo (tot, esPrev) (UET_Linked e) = do
+        v <- updateFixed e
+        return (tot - v, Just e : esPrev)
+      goTo (tot, esPrev) (UET_Unk e) = do
+        v <- updateUnknown e
+        return (tot - v, Just e {ueValue = StaticValue v} : esPrev)
+      updateFixed :: UpdateEntry i StaticValue -> State EntryBals Rational
+      updateFixed e = do
+        let v = unStaticValue $ ueValue e
+        modify $ mapAdd_ (ueAcnt e, utCurrency) v
+        return v
+      updateUnknown e = do
         let key = (ueAcnt e, utCurrency)
         curBal <- gets (M.findWithDefault 0 key)
-        let newVal = unBalanceTarget (ueValue e) - curBal
+        let v = case ueValue e of
-        modify $ mapAdd_ key newVal
+              EVPercent p -> p * curBal
-        return $ UET_Balance $ e {ueValue = BalanceTarget newVal}
+              EVBalance p -> p - curBal
-      goFrom (UET_Linked (e0, es)) = do
+        modify $ mapAdd_ key v
-        let key = (ueAcnt e0, utCurrency)
+        return v
-        curBal <- gets (M.findWithDefault 0 key)
+      unlink v e = e {ueValue = StaticValue $ v * unLinkScale (ueValue e)}
-        let newVal = unBalanceTarget (ueValue e0) - curBal
-        modify $ mapAdd_ key newVal
-        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 (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 = unBalanceTarget (ueValue e) - curBal
-        modify $ mapAdd_ key newVal
-        return $ Right $ e {ueValue = EntryValue newVal}
 
 balanceEntrySet
   :: (MonadInsertError m, MonadFinance m)
-  => DeferredEntrySet
+  => (Entry AccountRId AcntSign TagRId -> CurrencyRId -> v -> State EntryBals Rational)
+  -> DeferredEntrySet v
   -> StateT EntryBals m [KeyEntry]
 balanceEntrySet
+  findTot
   EntrySet
     { esFrom = HalfEntrySet {hesPrimary = f0, hesOther = fs}
     , esTo = HalfEntrySet {hesPrimary = t0, hesOther = ts}
-    , esCurrency
+    , esCurrency = CurrencyPrec {cpID = curID, cpPrec = precision}
     , esTotalValue
     } =
     do
-      -- get currency first and quit immediately on exception since everything
+      -- 1. Resolve tag and accout ids in primary entries since we (might) need
-      -- downstream depends on this
+      --    them later to calculate the total value of the transaction.
-      (curID, precision) <- lookupCurrency esCurrency
+      let f0res = resolveAcntAndTags f0
+      let t0res = resolveAcntAndTags t0
+      combineErrorM f0res t0res $ \f0' t0' -> do
+        -- 2. Compute total value of transaction using the primary debit entry
+        tot <- liftInnerS $ findTot f0' curID esTotalValue
 
-      -- resolve accounts and balance debit entries since we need an array
+        -- 3. Balance all debit entries (including primary). Note the negative
-      -- of debit entries for linked credit entries later
+        --    indices, which will signify them to be debit entries when updated
+        --    later.
         let balFromEntry = balanceEntry (\a -> liftInnerS . balanceDeferred curID a) curID
-      fs' <- doEntries balFromEntry curID esTotalValue f0 fs (NE.iterate (+ (-1)) (-1))
+        fs' <- doEntries balFromEntry curID tot f0' fs (NE.iterate (+ (-1)) (-1))
+
+        -- 4. Build an array of debit values be linked as desired in credit entries
         let fv = V.fromList $ fmap (eValue . feEntry) fs'
 
-      -- finally resolve credit entries
+        -- 4. Balance credit entries (including primary) analogously.
         let balToEntry = balanceEntry (balanceLinked fv curID precision) curID
-      ts' <- doEntries balToEntry curID (-esTotalValue) t0 ts (NE.iterate (+ 1) 0)
+        ts' <- doEntries balToEntry curID (-tot) t0' ts (NE.iterate (+ 1) 0)
         return $ fs' ++ ts'
 
 doEntries
-  :: (MonadInsertError m, MonadFinance m)
+  :: (MonadInsertError m)
-  => (Int -> Entry AcntID v TagID -> StateT EntryBals m (FullEntry AccountRId CurrencyRId TagRId))
+  => (Int -> Entry AcntID v TagID -> StateT EntryBals m (InsertEntry AccountRId CurrencyRId TagRId))
   -> CurrencyRId
   -> Rational
-  -> Entry AcntID () TagID
+  -> Entry AccountRId AcntSign TagRId
   -> [Entry AcntID v TagID]
   -> NonEmpty Int
-  -> StateT EntryBals m [FullEntry AccountRId CurrencyRId TagRId]
+  -> StateT EntryBals m [InsertEntry AccountRId CurrencyRId TagRId]
 doEntries f curID tot e es (i0 :| iN) = do
   es' <- mapErrors (uncurry f) $ zip iN es
-  let val0 = tot - entrySum es'
+  let e0val = tot - entrySum es'
-  e' <- balanceEntry (\_ _ -> return (val0, Nothing)) curID i0 e
+  -- TODO not dry
+  let s = fromIntegral $ sign2Int (eValue e) -- NOTE hack
+  modify (mapAdd_ (eAcnt e, curID) tot)
+  let e' =
+        InsertEntry
+          { feEntry = e {eValue = s * e0val}
+          , feCurrency = curID
+          , feDeferred = Nothing
+          , feIndex = i0
+          }
   return $ e' : es'
   where
     entrySum = sum . fmap (eValue . feEntry)
@@ -502,7 +538,7 @@ balanceLinked from curID precision acntID lg = case lg of
   (LinkIndex 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)
+      Just v -> return (v, Just $ EntryLinked lngIndex $ toRational lngScale)
       -- TODO this error would be much more informative if I had access to the
       -- file from which it came
       Nothing -> throwError undefined
@@ -513,11 +549,15 @@ balanceLinked from curID precision acntID lg = case lg of
 balanceDeferred
   :: CurrencyRId
   -> AccountRId
-  -> Deferred Rational
+  -> EntryValue Rational
   -> State EntryBals (Rational, Maybe DBDeferred)
-balanceDeferred curID acntID (Deferred toBal v) = do
+balanceDeferred curID acntID (EntryValue t v) = do
-  newval <- findBalance acntID curID toBal v
+  newval <- findBalance acntID curID t v
-  return $ (newval, if toBal then Just (EntryBalance v) else Nothing)
+  let d = case t of
+        TFixed -> Nothing
+        TBalance -> Just $ EntryBalance v
+        TPercent -> Just $ EntryPercent v
+  return (newval, d)
 
 balanceEntry
   :: (MonadInsertError m, MonadFinance m)
@@ -525,7 +565,7 @@ balanceEntry
   -> CurrencyRId
   -> Int
   -> Entry AcntID v TagID
-  -> StateT EntryBals m (FullEntry AccountRId CurrencyRId TagRId)
+  -> StateT EntryBals m (InsertEntry AccountRId CurrencyRId TagRId)
 balanceEntry f curID idx e@Entry {eValue, eAcnt, eTags} = do
   let acntRes = lookupAccount eAcnt
   let tagRes = mapErrors lookupTag eTags
@@ -534,17 +574,37 @@ balanceEntry f curID idx e@Entry {eValue, eAcnt, eTags} = do
     (newVal, deferred) <- f acntID eValue
     modify (mapAdd_ (acntID, curID) newVal)
     return $
-      FullEntry
+      InsertEntry
         { feEntry = e {eValue = s * newVal, eAcnt = acntID, eTags = tags}
         , feCurrency = curID
         , feDeferred = deferred
         , feIndex = idx
         }
 
-findBalance :: AccountRId -> CurrencyRId -> Bool -> Rational -> State EntryBals Rational
+resolveAcntAndTags
-findBalance acnt cur toBal v = do
+  :: (MonadInsertError m, MonadFinance m)
+  => Entry AcntID v TagID
+  -> m (Entry AccountRId AcntSign TagRId)
+resolveAcntAndTags e@Entry {eAcnt, eTags} = do
+  let acntRes = lookupAccount eAcnt
+  let tagRes = mapErrors lookupTag eTags
+  -- TODO total hack, store account sign in the value field so I don't need to
+  -- make seperate tuple pair thing to haul it around. Weird, but it works.
+  combineError acntRes tagRes $
+    \(acntID, sign, _) tags -> e {eAcnt = acntID, eTags = tags, eValue = sign}
+
+findBalance
+  :: AccountRId
+  -> CurrencyRId
+  -> TransferType
+  -> Rational
+  -> State EntryBals Rational
+findBalance acnt cur t v = do
   curBal <- gets (M.findWithDefault 0 (acnt, cur))
-  return $ if toBal then v - curBal else v
+  return $ case t of
+    TBalance -> v - curBal
+    TPercent -> v * curBal
+    TFixed -> v
 
 -- -- reimplementation from future version :/
 -- mapAccumM

lib/Internal/Types/Database.hs

@@ -9,6 +9,7 @@ module Internal.Types.Database where
 
 import Database.Persist.Sql hiding (Desc, In, Statement)
 import Database.Persist.TH
+import Internal.Types.Dhall
 import RIO
 import qualified RIO.Text as T
 import RIO.Time
@@ -52,8 +53,9 @@ EntryR sql=entries
     memo T.Text
     value Rational
     index Int
-    deferred_value (Maybe Rational)
+    cachedValue (Maybe Rational)
-    deferred_link (Maybe Int)
+    cachedType (Maybe TransferType)
+    cachedLink (Maybe Int)
     deriving Show Eq
 TagRelationR sql=tag_relations
     entry EntryRId OnDeleteCascade

lib/Internal/Types/Dhall.hs

@@ -34,8 +34,8 @@ makeHaskellTypesWith
   , MultipleConstructors "DateMatcher" "(./dhall/Types.dhall).DateMatcher"
   , MultipleConstructors "EntryNumGetter" "(./dhall/Types.dhall).EntryNumGetter"
   , MultipleConstructors "LinkedEntryNumGetter" "(./dhall/Types.dhall).LinkedEntryNumGetter"
-  , MultipleConstructors "BudgetCurrency" "(./dhall/Types.dhall).BudgetCurrency"
+  , MultipleConstructors "TransferCurrency" "(./dhall/Types.dhall).TransferCurrency"
-  , MultipleConstructors "BudgetTransferType" "(./dhall/Types.dhall).BudgetTransferType"
+  , MultipleConstructors "TransferType" "(./dhall/Types.dhall).TransferType"
   , MultipleConstructors "TaxMethod" "(./dhall/Types.dhall).TaxMethod"
   , MultipleConstructors "PeriodType" "(./dhall/Types.dhall).PeriodType"
   , SingleConstructor "LinkedNumGetter" "LinkedNumGetter" "(./dhall/Types.dhall).LinkedNumGetter.Type"
@@ -63,7 +63,7 @@ makeHaskellTypesWith
   , SingleConstructor "TaxProgression" "TaxProgression" "(./dhall/Types.dhall).TaxProgression"
   , SingleConstructor "TaxValue" "TaxValue" "(./dhall/Types.dhall).TaxValue"
   , SingleConstructor "PosttaxValue" "PosttaxValue" "(./dhall/Types.dhall).PosttaxValue"
-  , SingleConstructor "BudgetTransferValue" "BudgetTransferValue" "(./dhall/Types.dhall).BudgetTransferValue"
+  , SingleConstructor "TransferValue" "TransferValue" "(./dhall/Types.dhall).TransferValue.Type"
   , SingleConstructor "Period" "Period" "(./dhall/Types.dhall).Period"
   , SingleConstructor "HourlyPeriod" "HourlyPeriod" "(./dhall/Types.dhall).HourlyPeriod"
   -- , SingleConstructor "ToTx" "ToTx" "(./dhall/Types.dhall).ToTx"
@@ -97,7 +97,7 @@ deriveProduct
   , "DateMatcher"
   , "ValMatcher"
   , "YMDMatcher"
-  , "BudgetCurrency"
+  , "TransferCurrency"
   , "Exchange"
   , "EntryNumGetter"
   , "LinkedNumGetter"
@@ -110,8 +110,8 @@ deriveProduct
   , "TaxProgression"
   , "TaxMethod"
   , "PosttaxValue"
-  , "BudgetTransferValue"
+  , "TransferValue"
-  , "BudgetTransferType"
+  , "TransferType"
   , "Period"
   , "PeriodType"
   , "HourlyPeriod"
@@ -183,7 +183,7 @@ deriving instance Ord DatePat
 deriving instance Hashable DatePat
 
 type BudgetTransfer =
-  Transfer TaggedAcnt BudgetCurrency DatePat BudgetTransferValue
+  Transfer TaggedAcnt TransferCurrency DatePat TransferValue
 
 deriving instance Hashable BudgetTransfer
 
@@ -216,9 +216,21 @@ deriving instance Hashable PosttaxValue
 
 deriving instance Hashable Budget
 
-deriving instance Hashable BudgetTransferValue
+deriving instance Hashable TransferValue
 
-deriving instance Hashable BudgetTransferType
+deriving instance Hashable TransferType
+
+deriving instance Read TransferType
+
+instance PersistFieldSql TransferType where
+  sqlType _ = SqlString
+
+instance PersistField TransferType where
+  toPersistValue = PersistText . T.pack . show
+
+  fromPersistValue (PersistText v) =
+    maybe (Left $ "could not parse: " <> v) Right $ readMaybe $ T.unpack v
+  fromPersistValue _ = Left "wrong type"
 
 deriving instance Hashable TaggedAcnt
 
@@ -262,7 +274,7 @@ deriving instance (Eq w, Eq v) => Eq (Amount w v)
 
 deriving instance Hashable Exchange
 
-deriving instance Hashable BudgetCurrency
+deriving instance Hashable TransferCurrency
 
 data Allocation w v = Allocation
   { alloTo :: TaggedAcnt

lib/Internal/Types/Main.hs

@@ -36,7 +36,9 @@ data ConfigHashes = ConfigHashes
 
 type AccountMap = M.Map AcntID (AccountRId, AcntSign, AcntType)
 
-type CurrencyMap = M.Map CurID (CurrencyRId, Natural)
+data CurrencyPrec = CurrencyPrec {cpID :: !CurrencyRId, cpPrec :: !Natural}
+
+type CurrencyMap = M.Map CurID CurrencyPrec
 
 type TagMap = M.Map TagID TagRId
 
@@ -61,7 +63,10 @@ type CurrencyM = Reader CurrencyMap
 
 -- type DeferredKeyEntry = Entry AccountRId (Deferred Rational) CurrencyRId TagRId
 
-data DBDeferred = EntryLinked Natural Rational | EntryBalance Rational
+data DBDeferred
+  = EntryLinked Natural Rational
+  | EntryBalance Rational
+  | EntryPercent Rational
 
 data ReadEntry = ReadEntry
   { reCurrency :: !CurrencyRId
@@ -77,33 +82,37 @@ data UpdateEntry i v = UpdateEntry
   , ueIndex :: !Int -- TODO this isn't needed for primary entries
   }
 
+data CurrencyRound = CurrencyRound CurID Natural
+
 deriving instance Functor (UpdateEntry i)
 
 newtype LinkScale = LinkScale {unLinkScale :: Rational}
   deriving newtype (Num)
 
-newtype BalanceTarget = BalanceTarget {unBalanceTarget :: Rational}
+-- newtype BalanceTarget = BalanceTarget {unBalanceTarget :: Rational}
+--   deriving newtype (Num)
+
+newtype StaticValue = StaticValue {unStaticValue :: Rational}
   deriving newtype (Num)
 
-newtype EntryValue = EntryValue {unEntryValue :: Rational}
+data EntryValueUnk = EVBalance Rational | EVPercent Rational
-  deriving newtype (Num)
 
-type UEBalance = UpdateEntry EntryRId BalanceTarget
+type UEUnk = UpdateEntry EntryRId EntryValueUnk
 
 type UELink = UpdateEntry EntryRId LinkScale
 
 type UEBlank = UpdateEntry EntryRId ()
 
-type UE_RO = UpdateEntry () EntryValue
+type UE_RO = UpdateEntry () StaticValue
 
-type UEBalanced = UpdateEntry EntryRId EntryValue
+type UEBalanced = UpdateEntry EntryRId StaticValue
 
 data UpdateEntrySet = UpdateEntrySet
   { utFrom0 :: !UEBlank
   , utTo0 :: !UEBlank
-  , utPairs :: ![(UEBalance, [UELink])]
+  , utPairs :: ![(UEUnk, [UELink])]
-  , utFromUnk :: ![UEBalance]
+  , utFromUnk :: ![UEUnk]
-  , utToUnk :: ![UEBalance]
+  , utToUnk :: ![UEUnk]
   , utToUnkLink0 :: ![UELink]
   , utFromRO :: ![UE_RO]
   , utToRO :: ![UE_RO]
@@ -115,18 +124,18 @@ data UpdateEntrySet = UpdateEntrySet
 data EntryBin
   = ToUpdate UpdateEntrySet
   | ToRead ReadEntry
-  | ToInsert (DeferredTx CommitR)
+  | ToInsert (Tx CommitR)
 
-data FullEntry a c t = FullEntry
+data InsertEntry a c t = InsertEntry
   { feCurrency :: !c
   , feIndex :: !Int
   , feDeferred :: !(Maybe DBDeferred)
   , feEntry :: !(Entry a Rational t)
   }
 
-type KeyEntry = FullEntry AccountRId CurrencyRId TagRId
+type KeyEntry = InsertEntry AccountRId CurrencyRId TagRId
 
-type BalEntry = FullEntry AcntID CurID TagID
+type BalEntry = InsertEntry AcntID CurID TagID
 
 -- type DeferredKeyTx = Tx DeferredKeyEntry
 
@@ -202,50 +211,58 @@ data HalfEntrySet a c t v = HalfEntrySet
   , hesOther :: ![Entry a v t]
   }
 
-data EntrySet a c t v = EntrySet
+data EntrySet a c t v v' = EntrySet
-  { esTotalValue :: !Rational
+  { esTotalValue :: !v'
   , esCurrency :: !c
-  , esFrom :: !(HalfEntrySet a c t (Deferred v))
+  , esFrom :: !(HalfEntrySet a c t (EntryValue v))
   , esTo :: !(HalfEntrySet a c t (LinkDeferred v))
   }
 
-data Tx e c = Tx
+data Tx k = Tx
   { txDescr :: !T.Text
   , txDate :: !Day
-  , txEntries :: !e
+  , txPrimary :: !(EntrySet AcntID CurrencyPrec TagID Rational Rational)
-  , txCommit :: !c
+  , txOther :: ![EntrySet AcntID CurrencyPrec TagID Rational (EntryValue Rational)]
+  , txCommit :: !k
   }
   deriving (Generic)
 
-type DeferredEntrySet = EntrySet AcntID CurID TagID Rational
+data InsertTx = InsertTx
+  { itxDescr :: !T.Text
+  , itxDate :: !Day
+  , itxEntries :: ![InsertEntry AccountRId CurrencyRId TagRId]
+  , itxCommit :: !CommitR
+  }
+  deriving (Generic)
+
+type DeferredEntrySet = EntrySet AcntID CurrencyPrec TagID Rational
 
 type BalEntrySet = EntrySet AcntID CurID TagID Rational
 
 type KeyEntrySet = EntrySet AccountRId CurrencyRId TagRId Rational
 
-type DeferredTx = Tx [DeferredEntrySet]
+-- type DeferredTx = Tx [DeferredEntrySet]
 
-type BalTx = Tx [BalEntry]
+-- type BalTx = InsertTx [BalEntry]
 
-type KeyTx = Tx [KeyEntry]
+-- type KeyTx = InsertTx [KeyEntry]
 
 data Deferred a = Deferred Bool a
   deriving (Show, Functor, Foldable, Traversable)
 
-data LinkDeferred a
+data EntryValue a = EntryValue TransferType a
-  = LinkDeferred (Deferred a)
-  | LinkIndex LinkedNumGetter
   deriving (Show, Functor, Foldable, Traversable)
 
+data LinkDeferred a
+  = LinkDeferred (EntryValue a)
+  | LinkIndex LinkedNumGetter
+  deriving (Show, Functor, Traversable, Foldable)
+
 -- type RawEntry = Entry AcntID (Deferred Rational) CurID TagID
 
 -- type RawFromEntry = Entry AcntID (Deferred Rational) CurID TagID
 
--- type BalEntry = Entry AcntID Rational CurID TagID
+-- type BalEntry = InsertEntry AcntID CurID TagID
-
--- type RawTx = Tx RawEntry
-
--- type BalTx = Tx BalEntry
 
 data MatchRes a = MatchPass !a | MatchFail | MatchSkip
 

lib/Internal/Utils.hs

@@ -65,7 +65,6 @@ where
 
 import Control.Monad.Error.Class
 import Control.Monad.Except
-import Control.Monad.Reader
 import Data.Time.Format.ISO8601
 import GHC.Real
 import Internal.Types.Main
@@ -294,7 +293,7 @@ toDaySpan (a, b) = (a, fromIntegral $ diffDays b a - 1)
 --------------------------------------------------------------------------------
 -- matching
 
-matches :: MatchRe -> TxRecord -> InsertExceptT CurrencyM (MatchRes (DeferredTx ()))
+matches :: MonadFinance m => MatchRe -> TxRecord -> InsertExceptT m (MatchRes (Tx ()))
 matches
   StatementParser {spTx, spOther, spVal, spDate, spDesc}
   r@TxRecord {trDate, trAmount, trDesc, trOther} = do
@@ -311,7 +310,7 @@ matches
       desc = maybe (return True) (matchMaybe trDesc . snd) spDesc
       convert tg = MatchPass <$> toTx tg r
 
-toTx :: TxGetter -> TxRecord -> InsertExceptT CurrencyM (DeferredTx ())
+toTx :: MonadFinance m => TxGetter -> TxRecord -> InsertExceptT m (Tx ())
 toTx
   TxGetter
     { tgFrom
@@ -321,59 +320,43 @@ toTx
     , tgScale
     }
   r@TxRecord {trAmount, trDate, trDesc} = do
-    combineError curRes subRes $ \(cur, f, t, v) ss ->
+    combineError curRes subRes $ \(cur, f, t) ss ->
-      -- TODO might be more efficient to set rebalance flag when balancing
       Tx
         { txDate = trDate
         , txDescr = trDesc
         , txCommit = ()
-        , txEntries =
+        , txPrimary =
             EntrySet
-              { esTotalValue = v
+              { esTotalValue = roundPrecisionCur cur $ tgScale * fromRational trAmount
               , esCurrency = cur
               , esFrom = f
               , esTo = t
               }
-              : ss
+        , txOther = ss
         }
     where
       curRes = do
-        m <- ask
+        m <- askDBState kmCurrency
-        cur <- liftInner $ resolveCurrency r tgCurrency
+        cur <- liftInner $ resolveCurrency m r tgCurrency
-        let fromRes = resolveHalfEntry resolveFromValue cur r tgFrom
+        let fromRes = liftInner $ resolveHalfEntry resolveFromValue cur r tgFrom
-        let toRes = resolveHalfEntry resolveToValue cur r tgTo
+        let toRes = liftInner $ resolveHalfEntry resolveToValue cur r tgTo
-        let totRes =
+        combineError fromRes toRes (cur,,)
-              liftExcept $
-                roundPrecisionCur cur m $
-                  tgScale * fromRational trAmount
-        combineError3 fromRes toRes totRes (cur,,,)
       subRes = mapErrors (resolveSubGetter r) tgOtherEntries
 
--- anyDeferred :: DeferredEntrySet -> Bool
--- anyDeferred
---   EntrySet
---     { esFrom = HalfEntrySet {hesOther = fs}
---     , esTo = HalfEntrySet {hesOther = ts}
---     } =
---     any checkFrom fs || any checkTo ts
---     where
---       checkFrom Entry {eValue = (Deferred True _)} = True
---       checkFrom _ = False
---       checkTo = undefined
-
 resolveSubGetter
-  :: TxRecord
+  :: MonadFinance m
+  => TxRecord
   -> TxSubGetter
-  -> InsertExceptT CurrencyM (EntrySet AcntID CurID TagID Rational)
+  -> InsertExceptT m (EntrySet AcntID CurrencyPrec TagID Rational (EntryValue Rational))
 resolveSubGetter r TxSubGetter {tsgFrom, tsgTo, tsgValue, tsgCurrency} = do
-  m <- ask
+  m <- askDBState kmCurrency
-  cur <- liftInner $ resolveCurrency r tsgCurrency
+  cur <- liftInner $ resolveCurrency m r tsgCurrency
-  (_, val) <- liftInner $ mapM (roundPrecisionCur cur m) =<< resolveValue r tsgValue
   let fromRes = resolveHalfEntry resolveFromValue cur r tsgFrom
   let toRes = resolveHalfEntry resolveToValue cur r tsgTo
-  combineError fromRes toRes $ \f t ->
+  let valRes = liftInner $ fmap (roundPrecisionCur cur) <$> resolveValue r tsgValue
+  liftInner $ combineError3 fromRes toRes valRes $ \f t v ->
     EntrySet
-      { esTotalValue = val
+      { esTotalValue = v
       , esCurrency = cur
       , esFrom = f
       , esTo = t
@@ -382,10 +365,10 @@ resolveSubGetter r TxSubGetter {tsgFrom, tsgTo, tsgValue, tsgCurrency} = do
 resolveHalfEntry
   :: Traversable f
   => (TxRecord -> n -> InsertExcept (f Double))
-  -> CurID
+  -> CurrencyPrec
   -> TxRecord
   -> TxHalfGetter (EntryGetter n)
-  -> InsertExceptT CurrencyM (HalfEntrySet AcntID CurID TagID (f Rational))
+  -> InsertExcept (HalfEntrySet AcntID CurrencyPrec TagID (f Rational))
 resolveHalfEntry f cur r TxHalfGetter {thgAcnt, thgComment, thgTags, thgEntries} =
   combineError acntRes esRes $ \a es ->
     HalfEntrySet
@@ -399,67 +382,9 @@ resolveHalfEntry f cur r TxHalfGetter {thgAcnt, thgComment, thgTags, thgEntries}
       , hesOther = es
       }
   where
-    acntRes = liftInner $ resolveAcnt r thgAcnt
+    acntRes = resolveAcnt r thgAcnt
     esRes = mapErrors (resolveEntry f cur r) thgEntries
 
--- resolveSubGetter
---   :: TxRecord
---   -> TxSubGetter
---   -> InsertExceptT CurrencyM DeferredEntrySet
--- resolveSubGetter
---   r
---   TxSubGetter
---     { tsgFromAcnt
---     , tsgToAcnt
---     , tsgFromTags
---     , tsgToTags
---     , tsgFromComment
---     , tsgToComment
---     , tsgValue
---     , tsgCurrency
---     , tsgFromEntries
---     , tsgToEntries
---     } = combineErrorM acntRes curRes $ \(fa, ta) (cur, fe, te) ->
---     do
---       m <- ask
---       -- TODO laaaaame...
---       (Deferred _ val) <- liftInner $ mapM (roundPrecisionCur cur m) =<< resolveValue r tsgValue
---       let fromEntry =
---             Entry
---               { eAcnt = fa
---               , eValue = ()
---               , eComment = tsgFromComment
---               , eTags = tsgFromTags
---               }
---       let toEntry =
---             Entry
---               { eAcnt = ta
---               , eValue = ()
---               , eComment = tsgToComment
---               , eTags = tsgToTags
---               }
---       return
---         EntrySet
---           { desTotalValue = val
---           , desCurrency = cur
---           , desFromEntry0 = fromEntry
---           , desFromEntries = fe
---           , desToEntries = te
---           , desToEntryBal = toEntry
---           }
---     where
---       resolveAcnt_ = liftInner . resolveAcnt r
---       acntRes =
---         combineError
---           (resolveAcnt_ tsgFromAcnt)
---           (resolveAcnt_ tsgToAcnt)
---           (,)
---       curRes = do
---         cur <- liftInner $ resolveCurrency r tsgCurrency
---         let feRes = mapErrors (resolveEntry cur r) tsgFromEntries
---         let teRes = mapErrors (resolveEntry cur r) tsgToEntries
---         combineError feRes teRes (cur,,)
-
 valMatches :: ValMatcher -> Rational -> InsertExcept Bool
 valMatches ValMatcher {vmDen, vmSign, vmNum, vmPrec} x
   | Just d_ <- vmDen, d_ >= p = throwError $ InsertException [MatchValPrecisionError d_ p]
@@ -487,47 +412,17 @@ otherMatches dict m = case m of
 resolveEntry
   :: Traversable f
   => (TxRecord -> n -> InsertExcept (f Double))
-  -> CurID
+  -> CurrencyPrec
   -> TxRecord
   -> EntryGetter n
-  -> InsertExceptT CurrencyM (Entry AcntID (f Rational) TagID)
+  -> InsertExcept (Entry AcntID (f Rational) TagID)
 resolveEntry f cur r s@Entry {eAcnt, eValue} = do
-  m <- ask
+  combineError acntRes valRes $ \a v ->
-  liftInner $ combineErrorM acntRes valRes $ \a v -> do
+    s {eAcnt = a, eValue = roundPrecisionCur cur <$> v}
-    v' <- mapM (roundPrecisionCur cur m) v
-    return $ s {eAcnt = a, eValue = v'}
   where
     acntRes = resolveAcnt r eAcnt
     valRes = f r eValue
 
--- resolveEntry
---   :: CurID
---   -> TxRecord
---   -> EntryGetter n
---   -> InsertExceptT CurrencyM (Entry AcntID (Deferred Rational) TagID)
--- resolveEntry cur r s@Entry {eAcnt, eValue} = do
---   m <- ask
---   liftInner $ combineErrorM acntRes valRes $ \a v -> do
---     v' <- mapM (roundPrecisionCur cur m) v
---     return $ s {eAcnt = a, eValue = v'}
---   where
---     acntRes = resolveAcnt r eAcnt
---     valRes = resolveValue r eValue
-
--- curRes = resolveCurrency r eCurrency
-
--- -- TODO wet code (kinda, not sure if it's worth combining with above)
--- resolveToEntry :: TxRecord -> EntryGetter -> InsertExceptT CurrencyM RawEntry
--- resolveToEntry r s@Entry {eAcnt, eValue, eCurrency} = do
---   m <- ask
---   liftInner $ combineErrorM3 acntRes curRes valRes $ \a c v -> do
---     v' <- mapM (roundPrecisionCur c m) v
---     return $ s {eAcnt = a, eValue = maybe Derive (ConstD False) v', eCurrency = c}
---   where
---     acntRes = resolveAcnt r eAcnt
---     curRes = resolveCurrency r eCurrency
---     valRes = mapM (resolveToValue r) eValue
-
 liftInner :: Monad m => ExceptT e Identity a -> ExceptT e m a
 liftInner = mapExceptT (return . runIdentity)
 
@@ -621,27 +516,31 @@ mapErrorsIO f xs = mapM go $ enumTraversable xs
 collectErrorsIO :: (Traversable t, MonadUnliftIO m) => t (m a) -> m (t a)
 collectErrorsIO = mapErrorsIO id
 
-resolveFromValue :: TxRecord -> EntryNumGetter -> InsertExcept (Deferred Double)
+resolveFromValue :: TxRecord -> EntryNumGetter -> InsertExcept (EntryValue Double)
-resolveFromValue r = fmap (uncurry Deferred) . resolveValue r
+resolveFromValue = resolveValue
 
 resolveToValue :: TxRecord -> LinkedEntryNumGetter -> InsertExcept (LinkDeferred Double)
 resolveToValue _ (Linked l) = return $ LinkIndex l
-resolveToValue r (Getter g) = do
+resolveToValue r (Getter g) = LinkDeferred <$> resolveValue r g
-  (l, v) <- resolveValue r g
-  return $ LinkDeferred (Deferred l v)
 
-resolveValue :: TxRecord -> EntryNumGetter -> InsertExcept (Bool, Double)
+resolveValue :: TxRecord -> EntryNumGetter -> InsertExcept (EntryValue Double)
 resolveValue TxRecord {trOther, trAmount} s = case s of
-  (LookupN t) -> (False,) <$> (readDouble =<< lookupErr EntryValField t trOther)
+  (LookupN t) -> EntryValue TFixed <$> (readDouble =<< lookupErr EntryValField t trOther)
-  (ConstN c) -> return (False, c)
+  (ConstN c) -> return $ EntryValue TFixed c
-  AmountN m -> return $ (False,) <$> (* m) $ fromRational trAmount
+  AmountN m -> return $ EntryValue TFixed $ m * fromRational trAmount
-  BalanceN x -> return (True, x)
+  BalanceN x -> return $ EntryValue TBalance x
+  PercentN x -> return $ EntryValue TPercent x
 
 resolveAcnt :: TxRecord -> EntryAcnt -> InsertExcept T.Text
 resolveAcnt = resolveEntryField AcntField
 
-resolveCurrency :: TxRecord -> EntryCur -> InsertExcept T.Text
+resolveCurrency :: CurrencyMap -> TxRecord -> EntryCur -> InsertExcept CurrencyPrec
-resolveCurrency = resolveEntryField CurField
+resolveCurrency m r c = do
+  i <- resolveEntryField CurField r c
+  case M.lookup i m of
+    Just k -> return k
+    -- TODO this should be its own error (I think)
+    Nothing -> throwError $ InsertException [LookupError (EntryIDField CurField) undefined]
 
 resolveEntryField :: EntryIDType -> TxRecord -> EntryAcnt -> InsertExcept T.Text
 resolveEntryField t TxRecord {trOther = o} s = case s of
@@ -728,11 +627,8 @@ roundPrecision n = (% p) . round . (* fromIntegral p) . toRational
   where
     p = 10 ^ n
 
-roundPrecisionCur :: CurID -> CurrencyMap -> Double -> InsertExcept Rational
+roundPrecisionCur :: CurrencyPrec -> Double -> Rational
-roundPrecisionCur c m x =
+roundPrecisionCur (CurrencyPrec _ n) = roundPrecision n
-  case M.lookup c m of
-    Just (_, n) -> return $ roundPrecision n x
-    Nothing -> throwError $ InsertException [RoundError c]
 
 acntPath2Text :: AcntPath -> T.Text
 acntPath2Text (AcntPath t cs) = T.intercalate "/" (atName t : cs)
@@ -1105,14 +1001,14 @@ lookupAccountSign = fmap sndOf3 . lookupAccount
 lookupAccountType :: (MonadInsertError m, MonadFinance m) => AcntID -> m AcntType
 lookupAccountType = fmap thdOf3 . lookupAccount
 
-lookupCurrency :: (MonadInsertError m, MonadFinance m) => CurID -> m (CurrencyRId, Natural)
+lookupCurrency :: (MonadInsertError m, MonadFinance m) => CurID -> m CurrencyPrec
 lookupCurrency = lookupFinance CurField kmCurrency
 
 lookupCurrencyKey :: (MonadInsertError m, MonadFinance m) => AcntID -> m CurrencyRId
-lookupCurrencyKey = fmap fst . lookupCurrency
+lookupCurrencyKey = fmap cpID . lookupCurrency
 
 lookupCurrencyPrec :: (MonadInsertError m, MonadFinance m) => AcntID -> m Natural
-lookupCurrencyPrec = fmap snd . lookupCurrency
+lookupCurrencyPrec = fmap cpPrec . lookupCurrency
 
 lookupTag :: (MonadInsertError m, MonadFinance m) => TagID -> m TagRId
 lookupTag = lookupFinance TagField kmTag