WIP unify budget and history pipelines
This commit is contained in:
parent
1ae670187a
commit
5c1d2bce9d
24
app/Main.hs
24
app/Main.hs
|
@ -174,19 +174,25 @@ runSync c = do
|
|||
liftIOExceptT $ getDBState config
|
||||
|
||||
-- read desired statements from disk
|
||||
bSs <-
|
||||
flip runReaderT state $
|
||||
catMaybes <$> mapErrorsIO (readHistStmt root) hSs
|
||||
(rus, is) <-
|
||||
flip runReaderT state $ do
|
||||
hSs' <- mapErrorsIO (readHistStmt root) hSs
|
||||
hTs' <- liftIOExceptT $ mapErrors readHistTransfer hTs
|
||||
bTs <- liftIOExceptT $ mapErrors readBudget $ budget config
|
||||
return $ second concat $ partitionEithers $ hSs' ++ hTs' ++ bTs
|
||||
|
||||
-- update the DB
|
||||
runSqlQueryT pool $ withTransaction $ flip runReaderT state $ do
|
||||
let runHist = do
|
||||
ts <- catMaybes <$> mapErrors readHistTransfer hTs
|
||||
insertHistory $ bSs ++ ts
|
||||
let runBudget = mapErrors insertBudget $ budget config
|
||||
res <- runExceptT $ do
|
||||
-- TODO taking out the hash is dumb
|
||||
(rs, ues) <- readUpdates $ fmap commitRHash rus
|
||||
let ebs = fmap ToUpdate ues ++ fmap ToRead rs ++ fmap ToInsert is
|
||||
insertAll ebs
|
||||
-- NOTE this rerunnable thing is a bit misleading; fromEither will throw
|
||||
-- whatever error is encountered above in an IO context, but the first
|
||||
-- thrown error should be caught despite possibly needing to be rerun
|
||||
rerunnableIO $ fromEither res
|
||||
updateDBState updates -- TODO this will only work if foreign keys are deferred
|
||||
res <- runExceptT $ combineError runHist runBudget $ \_ _ -> ()
|
||||
rerunnableIO $ fromEither res -- TODO why is this here?
|
||||
where
|
||||
root = takeDirectory c
|
||||
err (InsertException es) = do
|
||||
|
|
|
@ -1,10 +1,8 @@
|
|||
module Internal.Budget (insertBudget) where
|
||||
module Internal.Budget (readBudget) where
|
||||
|
||||
import Control.Monad.Except
|
||||
import Data.Foldable
|
||||
import Database.Persist.Monad
|
||||
import Internal.Database
|
||||
import Internal.History
|
||||
import Internal.Types.Main
|
||||
import Internal.Utils
|
||||
import RIO hiding (to)
|
||||
|
@ -25,11 +23,11 @@ import RIO.Time
|
|||
-- 4. assign shadow transactions
|
||||
-- 5. insert all transactions
|
||||
|
||||
insertBudget
|
||||
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
|
||||
readBudget
|
||||
:: (MonadInsertError m, MonadFinance m)
|
||||
=> Budget
|
||||
-> m ()
|
||||
insertBudget
|
||||
-> m (Either CommitR [Tx TxCommit])
|
||||
readBudget
|
||||
b@Budget
|
||||
{ bgtLabel
|
||||
, bgtIncomes
|
||||
|
@ -40,14 +38,13 @@ insertBudget
|
|||
, bgtPosttax
|
||||
, bgtInterval
|
||||
} =
|
||||
whenHash CTBudget b () $ \key -> do
|
||||
eitherHash CTBudget b return $ \key -> do
|
||||
(intAllos, _) <- combineError intAlloRes acntRes (,)
|
||||
let res1 = mapErrors (insertIncome key bgtLabel intAllos bgtInterval) bgtIncomes
|
||||
let res1 = mapErrors (readIncome key bgtLabel intAllos bgtInterval) bgtIncomes
|
||||
let res2 = expandTransfers key bgtLabel bgtInterval bgtTransfers
|
||||
txs <- combineError (concat <$> res1) res2 (++)
|
||||
shadow <- addShadowTransfers bgtShadowTransfers txs
|
||||
(_, toIns) <- balanceTxs $ fmap ToInsert $ txs ++ shadow
|
||||
void $ insertBudgetTx toIns
|
||||
return $ txs ++ shadow
|
||||
where
|
||||
acntRes = mapErrors isNotIncomeAcnt alloAcnts
|
||||
intAlloRes = combineError3 pre_ tax_ post_ (,,)
|
||||
|
@ -60,60 +57,6 @@ 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 :: [Tx BudgetMeta] -> [KeyEntry]
|
||||
-- balanceTransfers = undefined
|
||||
|
||||
-- balanceTransfers = snd . L.mapAccumR go M.empty . reverse . L.sortOn ftWhen
|
||||
-- where
|
||||
-- go bals f@FlatTransfer {ftFrom, ftTo, ftValue = UnbalancedValue {cvValue, cvType}} =
|
||||
-- let balTo = M.findWithDefault 0 ftTo bals
|
||||
-- x = amtToMove balTo cvType cvValue
|
||||
-- bals' = mapAdd_ ftTo x $ mapAdd_ ftFrom (-x) bals
|
||||
-- in (bals', f {ftValue = x})
|
||||
-- -- TODO might need to query signs to make this intuitive; as it is this will
|
||||
-- -- probably work, but for credit accounts I might need to supply a negative
|
||||
-- -- target value
|
||||
-- amtToMove _ TFixed x = x
|
||||
-- amtToMove bal TPercent x = -(x / 100 * bal)
|
||||
-- amtToMove bal TBalance x = x - bal
|
||||
|
||||
insertBudgetTx
|
||||
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
|
||||
=> [InsertTx BudgetMeta]
|
||||
-> m ()
|
||||
insertBudgetTx toInsert = do
|
||||
forM_ (groupKey (commitRHash . bmCommit) $ (\x -> (itxCommit x, x)) <$> toInsert) $
|
||||
\(c, ts) -> do
|
||||
ck <- insert $ bmCommit c
|
||||
mapM_ (insertTx ck) ts
|
||||
where
|
||||
insertTx c InsertTx {itxDate = d, itxDescr = e, itxEntries = ss, itxCommit = BudgetMeta {bmName}} = do
|
||||
let anyDeferred = any (isJust . feDeferred) ss
|
||||
k <- insert $ TransactionR c d e anyDeferred
|
||||
mapM_ (insertBudgetLabel bmName k) ss
|
||||
insertBudgetLabel n k entry = do
|
||||
sk <- insertEntry k entry
|
||||
insert_ $ BudgetLabelR sk n
|
||||
|
||||
-- insertBudgetTx
|
||||
-- :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
|
||||
-- => BalancedTransfer
|
||||
-- -> m ()
|
||||
-- insertBudgetTx FlatTransfer {ftFrom, ftTo, ftMeta, ftCur, ftValue, ftDesc, ftWhen} = do
|
||||
-- ((sFrom, sTo), exchange) <- entryPair ftFrom ftTo ftCur ftValue
|
||||
-- insertPair sFrom sTo
|
||||
-- forM_ exchange $ uncurry insertPair
|
||||
-- where
|
||||
-- insertPair from to = do
|
||||
-- k <- insert $ TransactionR (bmCommit ftMeta) ftWhen ftDesc
|
||||
-- insertBudgetLabel k from
|
||||
-- insertBudgetLabel k to
|
||||
-- insertBudgetLabel k entry = do
|
||||
-- sk <- insertEntry k entry
|
||||
-- insert_ $ BudgetLabelR sk $ bmName ftMeta
|
||||
|
||||
entryPair
|
||||
:: (MonadInsertError m, MonadFinance m)
|
||||
=> TaggedAcnt
|
||||
|
@ -170,15 +113,15 @@ sortAllo a@Allocation {alloAmts = as} = do
|
|||
-- TODO this will scan the interval allocations fully each time
|
||||
-- iteration which is a total waste, but the fix requires turning this
|
||||
-- loop into a fold which I don't feel like doing now :(
|
||||
insertIncome
|
||||
readIncome
|
||||
:: (MonadInsertError m, MonadFinance m)
|
||||
=> CommitRId
|
||||
=> CommitR
|
||||
-> T.Text
|
||||
-> IntAllocations
|
||||
-> Maybe Interval
|
||||
-> Income
|
||||
-> m [Tx BudgetMeta]
|
||||
insertIncome
|
||||
-> m [Tx TxCommit]
|
||||
readIncome
|
||||
key
|
||||
name
|
||||
(intPre, intTax, intPost)
|
||||
|
@ -212,7 +155,7 @@ insertIncome
|
|||
dayRes = askDays incWhen localInterval
|
||||
start = fromGregorian' $ pStart incPayPeriod
|
||||
pType' = pType incPayPeriod
|
||||
meta = BudgetMeta key name
|
||||
meta = BudgetCommit key name
|
||||
flatPre = concatMap flattenAllo incPretax
|
||||
flatTax = concatMap flattenAllo incTaxes
|
||||
flatPost = concatMap flattenAllo incPosttax
|
||||
|
@ -352,11 +295,11 @@ selectAllos day Allocation {alloAmts, alloCur, alloTo} =
|
|||
|
||||
allo2Trans
|
||||
:: (MonadInsertError m, MonadFinance m)
|
||||
=> BudgetMeta
|
||||
=> TxCommit
|
||||
-> Day
|
||||
-> TaggedAcnt
|
||||
-> FlatAllocation Rational
|
||||
-> m (Tx BudgetMeta)
|
||||
-> m (Tx TxCommit)
|
||||
allo2Trans meta day from FlatAllocation {faValue, faTo, faDesc, faCur} = do
|
||||
-- TODO double here?
|
||||
p <- entryPair from faTo faCur faDesc (fromRational faValue)
|
||||
|
@ -441,12 +384,12 @@ allocatePost precision aftertax = fmap (fmap go)
|
|||
-- Standalone Transfer
|
||||
|
||||
expandTransfers
|
||||
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
|
||||
=> CommitRId
|
||||
:: (MonadInsertError m, MonadFinance m)
|
||||
=> CommitR
|
||||
-> T.Text
|
||||
-> Maybe Interval
|
||||
-> [BudgetTransfer]
|
||||
-> m [Tx BudgetMeta]
|
||||
-> m [Tx TxCommit]
|
||||
expandTransfers key name localInterval ts = do
|
||||
txs <-
|
||||
fmap (L.sortOn txDate . concat) $
|
||||
|
@ -459,13 +402,13 @@ expandTransfers key name localInterval ts = do
|
|||
return $ filter (inDaySpan bounds . txDate) txs
|
||||
|
||||
expandTransfer
|
||||
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
|
||||
=> CommitRId
|
||||
:: (MonadInsertError m, MonadFinance m)
|
||||
=> CommitR
|
||||
-> T.Text
|
||||
-> BudgetTransfer
|
||||
-> m [Tx BudgetMeta]
|
||||
expandTransfer key name Transfer {transAmounts, transTo, transCurrency, transFrom} = do
|
||||
fmap concat $ mapErrors go transAmounts
|
||||
-> m [Tx TxCommit]
|
||||
expandTransfer key name Transfer {transAmounts, transTo, transCurrency, transFrom} =
|
||||
concat <$> mapErrors go transAmounts
|
||||
where
|
||||
go
|
||||
Amount
|
||||
|
@ -474,7 +417,7 @@ expandTransfer key name Transfer {transAmounts, transTo, transCurrency, transFro
|
|||
, amtDesc = desc
|
||||
} =
|
||||
withDates pat $ \day -> do
|
||||
let meta = BudgetMeta {bmCommit = key, bmName = name}
|
||||
let meta = BudgetCommit key name
|
||||
p <- entryPair_ (\_ x -> EntryValue t $ toRational x) transFrom transTo transCurrency desc v
|
||||
return
|
||||
Tx
|
||||
|
@ -486,7 +429,7 @@ expandTransfer key name Transfer {transAmounts, transTo, transCurrency, transFro
|
|||
}
|
||||
|
||||
withDates
|
||||
:: (MonadSqlQuery m, MonadFinance m, MonadInsertError m)
|
||||
:: (MonadFinance m, MonadInsertError m)
|
||||
=> DatePat
|
||||
-> (Day -> m a)
|
||||
-> m [a]
|
||||
|
@ -502,9 +445,9 @@ withDates dp f = do
|
|||
addShadowTransfers
|
||||
:: (MonadInsertError m, MonadFinance m)
|
||||
=> [ShadowTransfer]
|
||||
-> [Tx BudgetMeta]
|
||||
-> m [Tx BudgetMeta]
|
||||
addShadowTransfers ms txs = mapErrors go txs
|
||||
-> [Tx TxCommit]
|
||||
-> m [Tx TxCommit]
|
||||
addShadowTransfers ms = mapErrors go
|
||||
where
|
||||
go tx = do
|
||||
es <- catMaybes <$> mapErrors (fromShadow tx) ms
|
||||
|
@ -512,7 +455,7 @@ addShadowTransfers ms txs = mapErrors go txs
|
|||
|
||||
fromShadow
|
||||
:: (MonadInsertError m, MonadFinance m)
|
||||
=> Tx BudgetMeta
|
||||
=> Tx TxCommit
|
||||
-> ShadowTransfer
|
||||
-> m (Maybe (EntrySet AcntID CurrencyPrec TagID Rational (Either Double (EntryValue Rational))))
|
||||
fromShadow tx ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stMatch} = do
|
||||
|
@ -520,7 +463,7 @@ fromShadow tx ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stMatch
|
|||
es <- entryPair_ (\_ v -> Left v) stFrom stTo stCurrency stDesc stRatio
|
||||
return $ if not res then Nothing else Just es
|
||||
|
||||
shadowMatches :: TransferMatcher -> Tx BudgetMeta -> InsertExcept Bool
|
||||
shadowMatches :: TransferMatcher -> Tx TxCommit -> InsertExcept Bool
|
||||
shadowMatches TransferMatcher {tmFrom, tmTo, tmDate} Tx {txPrimary, txDate} = do
|
||||
-- NOTE this will only match against the primary entry set since those
|
||||
-- are what are guaranteed to exist from a transfer
|
||||
|
@ -538,10 +481,6 @@ shadowMatches TransferMatcher {tmFrom, tmTo, tmDate} Tx {txPrimary, txDate} = do
|
|||
--------------------------------------------------------------------------------
|
||||
-- random
|
||||
|
||||
-- initialCurrency :: TransferCurrency -> CurID
|
||||
-- initialCurrency (NoX c) = c
|
||||
-- initialCurrency (X Exchange {xFromCur = c}) = c
|
||||
|
||||
alloAcnt :: Allocation w v -> AcntID
|
||||
alloAcnt = taAcnt . alloTo
|
||||
|
||||
|
@ -551,85 +490,6 @@ 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 BudgetMeta
|
||||
-- ubt2tx
|
||||
-- FlatTransfer
|
||||
-- { ftFrom
|
||||
-- , ftTo
|
||||
-- , ftValue
|
||||
-- , ftWhen
|
||||
-- , ftDesc
|
||||
-- , ftMeta
|
||||
-- , ftCur
|
||||
-- } =
|
||||
-- Tx
|
||||
-- { txDescr = ftDesc
|
||||
-- , txDate = ftWhen
|
||||
-- , txPrimary = p
|
||||
-- , txOther = maybeToList os
|
||||
-- , txCommit = ftMeta
|
||||
-- }
|
||||
-- where
|
||||
-- (p, os) = entries ftCur
|
||||
-- entries (NoX curid) = (pair curid ftFrom ftTo ftValue, Nothing)
|
||||
-- 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, Just 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
|
||||
-- { ftFrom :: !TaggedAcnt
|
||||
-- , ftTo :: !TaggedAcnt
|
||||
-- , ftValue :: !v
|
||||
-- , ftWhen :: !Day
|
||||
-- , ftDesc :: !T.Text
|
||||
-- , ftMeta :: !BudgetMeta
|
||||
-- , ftCur :: !TransferCurrency
|
||||
-- }
|
||||
-- deriving (Show)
|
||||
|
||||
data BudgetMeta = BudgetMeta
|
||||
{ bmCommit :: !CommitR
|
||||
, bmName :: !T.Text
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
type IntAllocations =
|
||||
( [DaySpanAllocation PretaxValue]
|
||||
, [DaySpanAllocation TaxValue]
|
||||
|
@ -638,8 +498,6 @@ type IntAllocations =
|
|||
|
||||
type DaySpanAllocation = Allocation DaySpan
|
||||
|
||||
type EntryPair = (KeyEntry, KeyEntry)
|
||||
|
||||
type PeriodScaler = Natural -> Double -> Double
|
||||
|
||||
data FlatAllocation v = FlatAllocation
|
||||
|
|
|
@ -459,7 +459,7 @@ resolveEntry s@InsertEntry {feEntry = e@Entry {eValue, eTags, eAcnt}, feCurrency
|
|||
readUpdates
|
||||
:: (MonadInsertError m, MonadSqlQuery m)
|
||||
=> [Int]
|
||||
-> m [Either ReadEntry UpdateEntrySet]
|
||||
-> m ([ReadEntry], [UpdateEntrySet])
|
||||
readUpdates hashes = do
|
||||
xs <- selectE $ do
|
||||
(commits :& txs :& entries) <-
|
||||
|
@ -482,7 +482,7 @@ readUpdates hashes = do
|
|||
liftExcept $
|
||||
mapErrors makeUES $
|
||||
second (fmap snd) <$> groupWith uGroup toUpdate
|
||||
return $ fmap Left toRead ++ fmap Right toUpdate'
|
||||
return (toRead, toUpdate')
|
||||
where
|
||||
unpack = fmap (\(_, d, e) -> (E.unValue d, (entityKey e, entityVal e)))
|
||||
uGroup (day, (_, e)) = (day, entryRCurrency e, entryRTransaction e)
|
||||
|
|
|
@ -1,9 +1,10 @@
|
|||
module Internal.History
|
||||
( readHistStmt
|
||||
, readHistTransfer
|
||||
, insertHistory
|
||||
, insertAll
|
||||
, splitHistory
|
||||
, balanceTxs
|
||||
, updateTx
|
||||
)
|
||||
where
|
||||
|
||||
|
@ -26,21 +27,11 @@ import qualified RIO.Text as T
|
|||
import RIO.Time
|
||||
import qualified RIO.Vector as V
|
||||
|
||||
-- readHistory
|
||||
-- :: (MonadInsertError m, MonadFinance m, MonadUnliftIO m)
|
||||
-- => FilePath
|
||||
-- -> [History]
|
||||
-- -> m [(CommitR, [DeferredTx])]
|
||||
-- readHistory root hs = do
|
||||
-- let (ts, ss) = splitHistory hs
|
||||
-- ts' <- catMaybes <$> mapErrorsIO readHistTransfer ts
|
||||
-- ss' <- catMaybes <$> mapErrorsIO (readHistStmt root) ss
|
||||
-- return $ ts' ++ ss'
|
||||
|
||||
-- TODO unify this with the transfer system I use in the budget now
|
||||
readHistTransfer
|
||||
:: (MonadInsertError m, MonadFinance m)
|
||||
=> HistTransfer
|
||||
-> m [Tx CommitR]
|
||||
-> m (Either CommitR [Tx TxCommit])
|
||||
readHistTransfer
|
||||
m@Transfer
|
||||
{ transFrom = from
|
||||
|
@ -48,7 +39,7 @@ readHistTransfer
|
|||
, transCurrency = u
|
||||
, transAmounts = amts
|
||||
} =
|
||||
whenHash0 CTManual m [] $ \c -> do
|
||||
eitherHash CTManual m return $ \c -> do
|
||||
bounds <- askDBState kmStatementInterval
|
||||
let curRes = lookupCurrency u
|
||||
let go Amount {amtWhen, amtValue, amtDesc} = do
|
||||
|
@ -62,11 +53,11 @@ readHistStmt
|
|||
:: (MonadUnliftIO m, MonadFinance m)
|
||||
=> FilePath
|
||||
-> Statement
|
||||
-> m (Either CommitR [Tx CommitR])
|
||||
-> m (Either CommitR [Tx TxCommit])
|
||||
readHistStmt root i = eitherHash CTImport i return $ \c -> do
|
||||
bs <- readImport root i
|
||||
bounds <- askDBState kmStatementInterval
|
||||
return $ filter (inDaySpan bounds . txDate) $ fmap (\t -> t {txCommit = c}) bs
|
||||
return $ filter (inDaySpan bounds . txDate) $ fmap (\t -> t {txCommit = HistoryCommit c}) bs
|
||||
|
||||
splitHistory :: [History] -> ([HistTransfer], [Statement])
|
||||
splitHistory = partitionEithers . fmap go
|
||||
|
@ -74,17 +65,35 @@ splitHistory = partitionEithers . fmap go
|
|||
go (HistTransfer x) = Left x
|
||||
go (HistStatement x) = Right x
|
||||
|
||||
insertHistory
|
||||
insertAll
|
||||
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
|
||||
=> [EntryBin CommitR]
|
||||
=> [EntryBin]
|
||||
-> m ()
|
||||
insertHistory hs = do
|
||||
(toUpdate, toInsert) <- balanceTxs hs
|
||||
insertAll ebs = do
|
||||
(toUpdate, toInsert) <- balanceTxs ebs
|
||||
mapM_ updateTx toUpdate
|
||||
forM_ (groupKey commitRHash $ (\x -> (itxCommit x, x)) <$> toInsert) $
|
||||
forM_ (groupWith itxCommit toInsert) $
|
||||
\(c, ts) -> do
|
||||
ck <- insert c
|
||||
ck <- insert $ getCommit c
|
||||
mapM_ (insertTx ck) ts
|
||||
where
|
||||
getCommit (HistoryCommit c) = c
|
||||
getCommit (BudgetCommit c _) = c
|
||||
|
||||
insertTx :: MonadSqlQuery m => CommitRId -> InsertTx -> m ()
|
||||
insertTx c InsertTx {itxDate, itxDescr, itxEntries, itxCommit} = do
|
||||
let anyDeferred = any (isJust . feDeferred) itxEntries
|
||||
k <- insert $ TransactionR c itxDate itxDescr anyDeferred
|
||||
mapM_ (go k) itxEntries
|
||||
where
|
||||
go k tx = do
|
||||
ek <- insertEntry k tx
|
||||
case itxCommit of
|
||||
BudgetCommit _ name -> insert_ $ BudgetLabelR ek name
|
||||
_ -> return ()
|
||||
|
||||
updateTx :: MonadSqlQuery m => UEBalanced -> m ()
|
||||
updateTx UpdateEntry {ueID, ueValue} = update ueID [EntryRValue =. unStaticValue ueValue]
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- low-level transaction stuff
|
||||
|
@ -98,12 +107,12 @@ txPair
|
|||
-> CurrencyPrec
|
||||
-> TransferValue
|
||||
-> T.Text
|
||||
-> Tx CommitR
|
||||
-> Tx TxCommit
|
||||
txPair commit day from to cur (TransferValue t v) desc =
|
||||
Tx
|
||||
{ txDescr = desc
|
||||
, txDate = day
|
||||
, txCommit = commit
|
||||
, txCommit = HistoryCommit commit
|
||||
, txPrimary =
|
||||
EntrySet
|
||||
{ esTotalValue = EntryValue t $ toRational v
|
||||
|
@ -126,15 +135,6 @@ txPair commit day from to cur (TransferValue t v) desc =
|
|||
-- resolveTx t@Tx {txEntries = ss} =
|
||||
-- (\kss -> t {txEntries = kss}) <$> mapErrors resolveEntry ss
|
||||
|
||||
insertTx :: MonadSqlQuery m => CommitRId -> InsertTx CommitR -> m ()
|
||||
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 =. unStaticValue ueValue]
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Statements
|
||||
|
||||
|
@ -349,8 +349,8 @@ matchNonDates ms = go ([], [], initZipper ms)
|
|||
|
||||
balanceTxs
|
||||
:: (MonadInsertError m, MonadFinance m)
|
||||
=> [EntryBin a]
|
||||
-> m ([UEBalanced], [InsertTx a])
|
||||
=> [EntryBin]
|
||||
-> m ([UEBalanced], [InsertTx])
|
||||
balanceTxs ebs =
|
||||
first concat . partitionEithers . catMaybes
|
||||
<$> evalStateT (mapErrors go $ L.sortOn binDate ebs) M.empty
|
||||
|
@ -379,7 +379,7 @@ balanceTxs ebs =
|
|||
Right (EntryValue t v) -> findBalance eAcnt c t v
|
||||
Left v -> return $ toRational v * tot
|
||||
|
||||
binDate :: EntryBin a -> Day
|
||||
binDate :: EntryBin -> Day
|
||||
binDate (ToUpdate UpdateEntrySet {utDate}) = utDate
|
||||
binDate (ToRead ReadEntry {reDate}) = reDate
|
||||
binDate (ToInsert Tx {txDate}) = txDate
|
||||
|
|
|
@ -20,7 +20,7 @@ share
|
|||
CommitR sql=commits
|
||||
hash Int
|
||||
type ConfigType
|
||||
deriving Show Eq
|
||||
deriving Show Eq Ord
|
||||
CurrencyR sql=currencies
|
||||
symbol T.Text
|
||||
fullname T.Text
|
||||
|
@ -67,7 +67,7 @@ BudgetLabelR sql=budget_labels
|
|||
|]
|
||||
|
||||
data ConfigType = CTBudget | CTManual | CTImport
|
||||
deriving (Eq, Show, Read, Enum)
|
||||
deriving (Eq, Show, Read, Enum, Ord)
|
||||
|
||||
instance PersistFieldSql ConfigType where
|
||||
sqlType _ = SqlString
|
||||
|
|
|
@ -121,10 +121,10 @@ data UpdateEntrySet = UpdateEntrySet
|
|||
, utTotalValue :: !Rational
|
||||
}
|
||||
|
||||
data EntryBin a
|
||||
data EntryBin
|
||||
= ToUpdate UpdateEntrySet
|
||||
| ToRead ReadEntry
|
||||
| ToInsert (Tx a)
|
||||
| ToInsert (Tx TxCommit)
|
||||
|
||||
data InsertEntry a c t = InsertEntry
|
||||
{ feCurrency :: !c
|
||||
|
@ -218,6 +218,8 @@ data EntrySet a c t v v' = EntrySet
|
|||
, esTo :: !(HalfEntrySet a c t (LinkDeferred v))
|
||||
}
|
||||
|
||||
data TxCommit = HistoryCommit CommitR | BudgetCommit CommitR T.Text deriving (Eq, Ord)
|
||||
|
||||
data Tx k = Tx
|
||||
{ txDescr :: !T.Text
|
||||
, txDate :: !Day
|
||||
|
@ -227,11 +229,11 @@ data Tx k = Tx
|
|||
}
|
||||
deriving (Generic)
|
||||
|
||||
data InsertTx a = InsertTx
|
||||
data InsertTx = InsertTx
|
||||
{ itxDescr :: !T.Text
|
||||
, itxDate :: !Day
|
||||
, itxEntries :: ![InsertEntry AccountRId CurrencyRId TagRId]
|
||||
, itxCommit :: !a
|
||||
, itxCommit :: !TxCommit
|
||||
}
|
||||
deriving (Generic)
|
||||
|
||||
|
|
Loading…
Reference in New Issue