REF move commont stuff to common modules
This commit is contained in:
parent
ebef4e0f6b
commit
d5761c75ed
|
|
@ -163,25 +163,26 @@ runDumpAccountKeys c = do
|
|||
runSync :: FilePath -> IO ()
|
||||
runSync c = do
|
||||
config <- readConfig c
|
||||
let (hTs, hSs) = splitHistory $ statements config
|
||||
pool <- runNoLoggingT $ mkPool $ sqlConfig config
|
||||
handle err $ do
|
||||
-- _ <- askLoggerIO
|
||||
|
||||
-- get the current DB state
|
||||
-- Get the current DB state.
|
||||
(state, updates) <- runSqlQueryT pool $ do
|
||||
runMigration migrateAll
|
||||
liftIOExceptT $ getDBState config
|
||||
|
||||
-- read desired statements from disk
|
||||
-- Read raw transactions according to state. If a transaction is already in
|
||||
-- the database, don't read it but record the commit so we can update it.
|
||||
(rus, is) <-
|
||||
flip runReaderT state $ do
|
||||
let (hTs, hSs) = splitHistory $ statements config
|
||||
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
|
||||
-- Update the DB.
|
||||
runSqlQueryT pool $ withTransaction $ flip runReaderT state $ do
|
||||
res <- runExceptT $ do
|
||||
-- TODO taking out the hash is dumb
|
||||
|
|
|
|||
|
|
@ -3,7 +3,6 @@ module Internal.Budget (readBudget) where
|
|||
import Control.Monad.Except
|
||||
import Data.Foldable
|
||||
import Internal.Database
|
||||
import Internal.History
|
||||
import Internal.Types.Main
|
||||
import Internal.Utils
|
||||
import RIO hiding (to)
|
||||
|
|
@ -13,17 +12,6 @@ import qualified RIO.NonEmpty as NE
|
|||
import qualified RIO.Text as T
|
||||
import RIO.Time
|
||||
|
||||
-- each budget (designated at the top level by a 'name') is processed in the
|
||||
-- following steps
|
||||
-- 1. expand all transactions given the desired date range and date patterns for
|
||||
-- each directive in the budget
|
||||
-- 2. sort all transactions by date
|
||||
-- 3. propagate all balances forward, and while doing so assign values to each
|
||||
-- transaction (some of which depend on the 'current' balance of the
|
||||
-- target account)
|
||||
-- 4. assign shadow transactions
|
||||
-- 5. insert all transactions
|
||||
|
||||
readBudget
|
||||
:: (MonadInsertError m, MonadFinance m)
|
||||
=> Budget
|
||||
|
|
@ -47,7 +35,7 @@ readBudget
|
|||
(intAllos, _) <- combineError intAlloRes acntRes (,)
|
||||
let tc = BudgetCommit key bgtLabel
|
||||
let res1 = mapErrors (readIncome tc intAllos budgetSpan) bgtIncomes
|
||||
let res2 = expandTransfers tc (Just budgetSpan) bgtTransfers
|
||||
let res2 = expandTransfers tc budgetSpan bgtTransfers
|
||||
txs <- combineError (concat <$> res1) res2 (++)
|
||||
shadow <- addShadowTransfers bgtShadowTransfers txs
|
||||
return $ txs ++ shadow
|
||||
|
|
@ -354,9 +342,6 @@ allocatePost precision aftertax = fmap (fmap go)
|
|||
then aftertax * roundPrecision 3 v / 100
|
||||
else roundPrecision precision v
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Standalone Transfer
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- shadow transfers
|
||||
|
||||
|
|
@ -403,12 +388,6 @@ shadowMatches TransferMatcher {tmFrom, tmTo, tmDate} Tx {txPrimary, txDate} = do
|
|||
alloAcnt :: Allocation w v -> AcntID
|
||||
alloAcnt = taAcnt . alloTo
|
||||
|
||||
data UnbalancedValue = UnbalancedValue
|
||||
{ cvType :: !TransferType
|
||||
, cvValue :: !Rational
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
type IntAllocations =
|
||||
( [DaySpanAllocation PretaxValue]
|
||||
, [DaySpanAllocation TaxValue]
|
||||
|
|
|
|||
|
|
@ -15,6 +15,8 @@ module Internal.Database
|
|||
, insertEntry
|
||||
, resolveEntry
|
||||
, readUpdates
|
||||
, insertAll
|
||||
, updateTx
|
||||
)
|
||||
where
|
||||
|
||||
|
|
@ -33,6 +35,7 @@ import Database.Persist.Sqlite hiding
|
|||
, insertKey
|
||||
, insert_
|
||||
, runMigration
|
||||
, update
|
||||
, (==.)
|
||||
, (||.)
|
||||
)
|
||||
|
|
@ -598,3 +601,33 @@ makeRoUE e = makeUE () e $ StaticValue (entryRValue e)
|
|||
|
||||
makeUnkUE :: EntryRId -> EntryR -> UpdateEntry EntryRId ()
|
||||
makeUnkUE k e = makeUE k e ()
|
||||
|
||||
insertAll
|
||||
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
|
||||
=> [EntryBin]
|
||||
-> m ()
|
||||
insertAll ebs = do
|
||||
(toUpdate, toInsert) <- balanceTxs ebs
|
||||
mapM_ updateTx toUpdate
|
||||
forM_ (groupWith itxCommit toInsert) $
|
||||
\(c, ts) -> do
|
||||
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]
|
||||
|
|
|
|||
|
|
@ -1,21 +1,13 @@
|
|||
module Internal.History
|
||||
( readHistStmt
|
||||
, readHistTransfer
|
||||
, insertAll
|
||||
, splitHistory
|
||||
, balanceTxs
|
||||
, updateTx
|
||||
, entryPair_
|
||||
, expandTransfers
|
||||
, entryPair
|
||||
)
|
||||
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
|
||||
import Internal.Utils
|
||||
|
|
@ -24,20 +16,32 @@ import qualified RIO.ByteString.Lazy as BL
|
|||
import RIO.FilePath
|
||||
import qualified RIO.List as L
|
||||
import qualified RIO.Map as M
|
||||
import qualified RIO.NonEmpty as NE
|
||||
import RIO.State
|
||||
import qualified RIO.Text as T
|
||||
import RIO.Time
|
||||
import qualified RIO.Vector as V
|
||||
|
||||
-- TODO unify this with the transfer system I use in the budget now
|
||||
-- NOTE keep statement and transfer readers separate because the former needs
|
||||
-- the IO monad, and thus will throw IO errors rather than using the ExceptT
|
||||
-- thingy
|
||||
splitHistory :: [History] -> ([PairedTransfer], [Statement])
|
||||
splitHistory = partitionEithers . fmap go
|
||||
where
|
||||
go (HistTransfer x) = Left x
|
||||
go (HistStatement x) = Right x
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Transfers
|
||||
|
||||
readHistTransfer
|
||||
:: (MonadInsertError m, MonadFinance m)
|
||||
=> PairedTransfer
|
||||
-> m (Either CommitR [Tx TxCommit])
|
||||
readHistTransfer ht = eitherHash CTManual ht return $ \c -> do
|
||||
bounds <- askDBState kmStatementInterval
|
||||
expandTransfer (HistoryCommit c) (Just bounds) ht
|
||||
expandTransfer (HistoryCommit c) bounds ht
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Statements
|
||||
|
||||
readHistStmt
|
||||
:: (MonadUnliftIO m, MonadFinance m)
|
||||
|
|
@ -49,172 +53,6 @@ readHistStmt root i = eitherHash CTImport i return $ \c -> do
|
|||
bounds <- askDBState kmStatementInterval
|
||||
return $ filter (inDaySpan bounds . txDate) $ fmap (\t -> t {txCommit = HistoryCommit c}) bs
|
||||
|
||||
splitHistory :: [History] -> ([PairedTransfer], [Statement])
|
||||
splitHistory = partitionEithers . fmap go
|
||||
where
|
||||
go (HistTransfer x) = Left x
|
||||
go (HistStatement x) = Right x
|
||||
|
||||
insertAll
|
||||
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
|
||||
=> [EntryBin]
|
||||
-> m ()
|
||||
insertAll ebs = do
|
||||
(toUpdate, toInsert) <- balanceTxs ebs
|
||||
mapM_ updateTx toUpdate
|
||||
forM_ (groupWith itxCommit toInsert) $
|
||||
\(c, ts) -> do
|
||||
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
|
||||
|
||||
expandTransfers
|
||||
:: (MonadInsertError m, MonadFinance m)
|
||||
=> TxCommit
|
||||
-> Maybe DaySpan
|
||||
-> [PairedTransfer]
|
||||
-> m [Tx TxCommit]
|
||||
expandTransfers tc localInterval ts =
|
||||
fmap (L.sortOn txDate . concat) $
|
||||
combineErrors $
|
||||
fmap (expandTransfer tc localInterval) ts
|
||||
|
||||
expandTransfer
|
||||
:: (MonadInsertError m, MonadFinance m)
|
||||
=> TxCommit
|
||||
-> Maybe DaySpan
|
||||
-> PairedTransfer
|
||||
-> m [Tx TxCommit]
|
||||
expandTransfer tc ds Transfer {transAmounts, transTo, transCurrency, transFrom} = do
|
||||
txs <- concat <$> mapErrors go transAmounts
|
||||
return $ case ds of
|
||||
Nothing -> txs
|
||||
Just bounds -> filter (inDaySpan bounds . txDate) txs
|
||||
where
|
||||
go
|
||||
Amount
|
||||
{ amtWhen = pat
|
||||
, amtValue = TransferValue {tvVal = v, tvType = t}
|
||||
, amtDesc = desc
|
||||
} =
|
||||
withDates pat $ \day -> do
|
||||
p <- entryPair_ (\_ x -> EntryValue t $ toRational x) transFrom transTo transCurrency desc v
|
||||
return
|
||||
Tx
|
||||
{ txCommit = tc
|
||||
, txDate = day
|
||||
, txPrimary = p
|
||||
, txOther = []
|
||||
, txDescr = desc
|
||||
}
|
||||
|
||||
entryPair
|
||||
:: (MonadInsertError m, MonadFinance m)
|
||||
=> TaggedAcnt
|
||||
-> TaggedAcnt
|
||||
-> CurID
|
||||
-> T.Text
|
||||
-> Double
|
||||
-> m (EntrySet AcntID CurrencyPrec TagID Rational (EntryValue Rational))
|
||||
entryPair = entryPair_ (fmap (EntryValue TFixed) . roundPrecisionCur)
|
||||
|
||||
entryPair_
|
||||
:: (MonadInsertError m, MonadFinance m)
|
||||
=> (CurrencyPrec -> v -> v')
|
||||
-> TaggedAcnt
|
||||
-> TaggedAcnt
|
||||
-> CurID
|
||||
-> T.Text
|
||||
-> v
|
||||
-> m (EntrySet AcntID CurrencyPrec TagID Rational v')
|
||||
entryPair_ f from to curid com val = do
|
||||
cp <- lookupCurrency curid
|
||||
return $ pair cp from to (f cp val)
|
||||
where
|
||||
halfEntry :: a -> [t] -> HalfEntrySet a c t v
|
||||
halfEntry a ts =
|
||||
HalfEntrySet
|
||||
{ hesPrimary = Entry {eAcnt = a, eValue = (), eComment = com, eTags = ts}
|
||||
, hesOther = []
|
||||
}
|
||||
pair cp (TaggedAcnt fa fts) (TaggedAcnt ta tts) v =
|
||||
EntrySet
|
||||
{ esCurrency = cp
|
||||
, esTotalValue = v
|
||||
, esFrom = halfEntry fa fts
|
||||
, esTo = halfEntry ta tts
|
||||
}
|
||||
|
||||
withDates
|
||||
:: (MonadFinance m, MonadInsertError m)
|
||||
=> DatePat
|
||||
-> (Day -> m a)
|
||||
-> m [a]
|
||||
withDates dp f = do
|
||||
bounds <- askDBState kmBudgetInterval
|
||||
days <- liftExcept $ expandDatePat bounds dp
|
||||
combineErrors $ fmap f days
|
||||
|
||||
-- -- TODO tags here?
|
||||
-- txPair
|
||||
-- :: CommitR
|
||||
-- -> Day
|
||||
-- -> AcntID
|
||||
-- -> AcntID
|
||||
-- -> CurrencyPrec
|
||||
-- -> TransferValue
|
||||
-- -> T.Text
|
||||
-- -> Tx TxCommit
|
||||
-- txPair commit day from to cur (TransferValue t v) desc =
|
||||
-- Tx
|
||||
-- { txDescr = desc
|
||||
-- , txDate = day
|
||||
-- , txCommit = HistoryCommit commit
|
||||
-- , txPrimary =
|
||||
-- EntrySet
|
||||
-- { esTotalValue = EntryValue t $ toRational v
|
||||
-- , esCurrency = cur
|
||||
-- , esFrom = HalfEntrySet {hesPrimary = entry from, hesOther = []}
|
||||
-- , esTo = HalfEntrySet {hesPrimary = entry to, hesOther = []}
|
||||
-- }
|
||||
-- , txOther = []
|
||||
-- }
|
||||
-- where
|
||||
-- entry a =
|
||||
-- Entry
|
||||
-- { eAcnt = a
|
||||
-- , eValue = ()
|
||||
-- , eComment = ""
|
||||
-- , eTags = []
|
||||
-- }
|
||||
|
||||
-- resolveTx :: (MonadInsertError m, MonadFinance m) => BalTx CommitR -> m (KeyTx CommitR)
|
||||
-- resolveTx t@Tx {txEntries = ss} =
|
||||
-- (\kss -> t {txEntries = kss}) <$> mapErrors resolveEntry ss
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Statements
|
||||
|
||||
-- TODO this probably won't scale well (pipes?)
|
||||
readImport :: (MonadUnliftIO m, MonadFinance m) => FilePath -> Statement -> m [Tx ()]
|
||||
readImport root Statement {stmtTxOpts, stmtParsers, stmtSkipLines, stmtDelim, stmtPaths} = do
|
||||
|
|
@ -423,279 +261,3 @@ matchNonDates ms = go ([], [], initZipper ms)
|
|||
MatchSkip -> (Nothing : matched, unmatched)
|
||||
MatchFail -> (matched, r : unmatched)
|
||||
in go (m, u, resetZipper z') rs
|
||||
|
||||
balanceTxs
|
||||
:: (MonadInsertError m, MonadFinance m)
|
||||
=> [EntryBin]
|
||||
-> m ([UEBalanced], [InsertTx])
|
||||
balanceTxs ebs =
|
||||
first concat . partitionEithers . catMaybes
|
||||
<$> 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 Tx {txPrimary, txOther, txDescr, txCommit, txDate}) = do
|
||||
e <- balanceEntrySet primaryBalance txPrimary
|
||||
-- TODO this logic is really stupid, I'm balancing the total twice; fix
|
||||
-- will likely entail making a separate data structure for txs derived
|
||||
-- from transfers vs statements
|
||||
let etot = sum $ eValue . feEntry <$> filter ((< 0) . feIndex) e
|
||||
es <- mapErrors (balanceEntrySet (secondaryBalance etot)) txOther
|
||||
let tx =
|
||||
InsertTx
|
||||
{ itxDescr = txDescr
|
||||
, itxDate = txDate
|
||||
, itxEntries = concat $ e : es
|
||||
, itxCommit = txCommit
|
||||
}
|
||||
return $ Just $ Right tx
|
||||
primaryBalance Entry {eAcnt} c (EntryValue t v) = findBalance eAcnt c t v
|
||||
secondaryBalance tot Entry {eAcnt} c val = case val of
|
||||
Right (EntryValue t v) -> findBalance eAcnt c t v
|
||||
Left v -> return $ toRational v * tot
|
||||
|
||||
binDate :: EntryBin -> Day
|
||||
binDate (ToUpdate UpdateEntrySet {utDate}) = utDate
|
||||
binDate (ToRead ReadEntry {reDate}) = reDate
|
||||
binDate (ToInsert Tx {txDate}) = txDate
|
||||
|
||||
type EntryBals = M.Map (AccountRId, CurrencyRId) Rational
|
||||
|
||||
data UpdateEntryType a
|
||||
= UET_ReadOnly UE_RO
|
||||
| UET_Unk UEUnk
|
||||
| UET_Linked a
|
||||
|
||||
-- TODO make sure new values are rounded properly here
|
||||
rebalanceEntrySet :: UpdateEntrySet -> State EntryBals [UEBalanced]
|
||||
rebalanceEntrySet
|
||||
UpdateEntrySet
|
||||
{ utFrom0
|
||||
, utTo0
|
||||
, utPairs
|
||||
, utFromUnk
|
||||
, utToUnk
|
||||
, utFromRO
|
||||
, utToRO
|
||||
, utCurrency
|
||||
, utToUnkLink0
|
||||
, utTotalValue
|
||||
} =
|
||||
do
|
||||
(f0val, (tpairs, fs)) <-
|
||||
fmap (second partitionEithers) $
|
||||
foldM goFrom (utTotalValue, []) $
|
||||
L.sortOn idx $
|
||||
(UET_ReadOnly <$> utFromRO)
|
||||
++ (UET_Unk <$> utFromUnk)
|
||||
++ (UET_Linked <$> utPairs)
|
||||
let f0 = utFrom0 {ueValue = StaticValue f0val}
|
||||
let tsLink0 = fmap (unlink (-f0val)) utToUnkLink0
|
||||
(t0val, tsUnk) <-
|
||||
fmap (second catMaybes) $
|
||||
foldM goTo (-utTotalValue, []) $
|
||||
L.sortOn idx2 $
|
||||
(UET_Linked <$> (tpairs ++ tsLink0))
|
||||
++ (UET_Unk <$> utToUnk)
|
||||
++ (UET_ReadOnly <$> utToRO)
|
||||
let t0 = utTo0 {ueValue = StaticValue t0val}
|
||||
return (f0 : fs ++ (t0 : tsUnk))
|
||||
where
|
||||
project f _ _ (UET_ReadOnly 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
|
||||
-- TODO the sum accumulator thing is kinda awkward
|
||||
goFrom (tot, es) (UET_ReadOnly e) = do
|
||||
v <- updateFixed e
|
||||
return (tot - v, es)
|
||||
goFrom (tot, esPrev) (UET_Unk e) = do
|
||||
v <- updateUnknown e
|
||||
return (tot - v, Right e {ueValue = StaticValue v} : esPrev)
|
||||
goFrom (tot, esPrev) (UET_Linked (e0, es)) = do
|
||||
v <- updateUnknown e0
|
||||
let e0' = Right $ e0 {ueValue = StaticValue v}
|
||||
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 v = case ueValue e of
|
||||
EVPercent p -> p * curBal
|
||||
EVBalance p -> p - curBal
|
||||
modify $ mapAdd_ key v
|
||||
return v
|
||||
unlink v e = e {ueValue = StaticValue $ v * unLinkScale (ueValue e)}
|
||||
|
||||
balanceEntrySet
|
||||
:: (MonadInsertError m, MonadFinance m)
|
||||
=> (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 = CurrencyPrec {cpID = curID, cpPrec = precision}
|
||||
, esTotalValue
|
||||
} =
|
||||
do
|
||||
-- 1. Resolve tag and accout ids in primary entries since we (might) need
|
||||
-- them later to calculate the total value of the transaction.
|
||||
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
|
||||
|
||||
-- 3. Balance all debit entries (including primary). Note the negative
|
||||
-- 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 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'
|
||||
|
||||
-- 4. Balance credit entries (including primary) analogously.
|
||||
let balToEntry = balanceEntry (balanceLinked fv curID precision) curID
|
||||
ts' <- doEntries balToEntry curID (-tot) t0' ts (NE.iterate (+ 1) 0)
|
||||
return $ fs' ++ ts'
|
||||
|
||||
doEntries
|
||||
:: (MonadInsertError m)
|
||||
=> (Int -> Entry AcntID v TagID -> StateT EntryBals m (InsertEntry AccountRId CurrencyRId TagRId))
|
||||
-> CurrencyRId
|
||||
-> Rational
|
||||
-> Entry AccountRId AcntSign TagRId
|
||||
-> [Entry AcntID v TagID]
|
||||
-> NonEmpty Int
|
||||
-> StateT EntryBals m [InsertEntry AccountRId CurrencyRId TagRId]
|
||||
doEntries f curID tot e es (i0 :| iN) = do
|
||||
es' <- mapErrors (uncurry f) $ zip iN es
|
||||
let e0val = tot - entrySum es'
|
||||
-- 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)
|
||||
|
||||
liftInnerS :: Monad m => StateT e Identity a -> StateT e m a
|
||||
liftInnerS = mapStateT (return . runIdentity)
|
||||
|
||||
balanceLinked
|
||||
:: MonadInsertError m
|
||||
=> Vector Rational
|
||||
-> CurrencyRId
|
||||
-> Natural
|
||||
-> AccountRId
|
||||
-> LinkDeferred Rational
|
||||
-> StateT EntryBals m (Rational, Maybe DBDeferred)
|
||||
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)
|
||||
-- TODO this error would be much more informative if I had access to the
|
||||
-- file from which it came
|
||||
Nothing -> throwError undefined
|
||||
(LinkDeferred d) -> liftInnerS $ balanceDeferred curID acntID d
|
||||
where
|
||||
go s = roundPrecision precision . (* s) . fromRational
|
||||
|
||||
balanceDeferred
|
||||
:: CurrencyRId
|
||||
-> AccountRId
|
||||
-> EntryValue Rational
|
||||
-> State EntryBals (Rational, Maybe DBDeferred)
|
||||
balanceDeferred curID acntID (EntryValue t v) = do
|
||||
newval <- findBalance acntID curID t v
|
||||
let d = case t of
|
||||
TFixed -> Nothing
|
||||
TBalance -> Just $ EntryBalance v
|
||||
TPercent -> Just $ EntryPercent v
|
||||
return (newval, d)
|
||||
|
||||
balanceEntry
|
||||
:: (MonadInsertError m, MonadFinance m)
|
||||
=> (AccountRId -> v -> StateT EntryBals m (Rational, Maybe DBDeferred))
|
||||
-> CurrencyRId
|
||||
-> Int
|
||||
-> Entry AcntID v TagID
|
||||
-> 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
|
||||
combineErrorM acntRes tagRes $ \(acntID, sign, _) tags -> do
|
||||
let s = fromIntegral $ sign2Int sign
|
||||
(newVal, deferred) <- f acntID eValue
|
||||
modify (mapAdd_ (acntID, curID) newVal)
|
||||
return $
|
||||
InsertEntry
|
||||
{ feEntry = e {eValue = s * newVal, eAcnt = acntID, eTags = tags}
|
||||
, feCurrency = curID
|
||||
, feDeferred = deferred
|
||||
, feIndex = idx
|
||||
}
|
||||
|
||||
resolveAcntAndTags
|
||||
:: (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 $ case t of
|
||||
TBalance -> v - curBal
|
||||
TPercent -> v * curBal
|
||||
TFixed -> v
|
||||
|
||||
-- -- reimplementation from future version :/
|
||||
-- mapAccumM
|
||||
-- :: Monad m
|
||||
-- => (s -> a -> m (s, b))
|
||||
-- -> s
|
||||
-- -> [a]
|
||||
-- -> m (s, [b])
|
||||
-- mapAccumM f s xs = foldrM go (s, []) xs
|
||||
-- where
|
||||
-- go x (s', acc) = second (: acc) <$> f s' x
|
||||
|
|
|
|||
|
|
@ -60,6 +60,11 @@ module Internal.Utils
|
|||
, mapAdd_
|
||||
, groupKey
|
||||
, groupWith
|
||||
, balanceTxs
|
||||
, expandTransfers
|
||||
, expandTransfer
|
||||
, entryPair
|
||||
, entryPair_
|
||||
)
|
||||
where
|
||||
|
||||
|
|
@ -72,8 +77,10 @@ import RIO
|
|||
import qualified RIO.List as L
|
||||
import qualified RIO.Map as M
|
||||
import qualified RIO.NonEmpty as NE
|
||||
import RIO.State
|
||||
import qualified RIO.Text as T
|
||||
import RIO.Time
|
||||
import qualified RIO.Vector as V
|
||||
import Text.Regex.TDFA
|
||||
import Text.Regex.TDFA.Text
|
||||
|
||||
|
|
@ -1021,3 +1028,350 @@ lookupFinance
|
|||
-> T.Text
|
||||
-> m a
|
||||
lookupFinance t f c = (liftExcept . lookupErr (DBKey t) c) =<< askDBState f
|
||||
|
||||
balanceTxs
|
||||
:: (MonadInsertError m, MonadFinance m)
|
||||
=> [EntryBin]
|
||||
-> m ([UEBalanced], [InsertTx])
|
||||
balanceTxs ebs =
|
||||
first concat . partitionEithers . catMaybes
|
||||
<$> 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 Tx {txPrimary, txOther, txDescr, txCommit, txDate}) = do
|
||||
e <- balanceEntrySet primaryBalance txPrimary
|
||||
-- TODO this logic is really stupid, I'm balancing the total twice; fix
|
||||
-- will likely entail making a separate data structure for txs derived
|
||||
-- from transfers vs statements
|
||||
let etot = sum $ eValue . feEntry <$> filter ((< 0) . feIndex) e
|
||||
es <- mapErrors (balanceEntrySet (secondaryBalance etot)) txOther
|
||||
let tx =
|
||||
InsertTx
|
||||
{ itxDescr = txDescr
|
||||
, itxDate = txDate
|
||||
, itxEntries = concat $ e : es
|
||||
, itxCommit = txCommit
|
||||
}
|
||||
return $ Just $ Right tx
|
||||
primaryBalance Entry {eAcnt} c (EntryValue t v) = findBalance eAcnt c t v
|
||||
secondaryBalance tot Entry {eAcnt} c val = case val of
|
||||
Right (EntryValue t v) -> findBalance eAcnt c t v
|
||||
Left v -> return $ toRational v * tot
|
||||
|
||||
binDate :: EntryBin -> Day
|
||||
binDate (ToUpdate UpdateEntrySet {utDate}) = utDate
|
||||
binDate (ToRead ReadEntry {reDate}) = reDate
|
||||
binDate (ToInsert Tx {txDate}) = txDate
|
||||
|
||||
type EntryBals = M.Map (AccountRId, CurrencyRId) Rational
|
||||
|
||||
data UpdateEntryType a
|
||||
= UET_ReadOnly UE_RO
|
||||
| UET_Unk UEUnk
|
||||
| UET_Linked a
|
||||
|
||||
-- TODO make sure new values are rounded properly here
|
||||
rebalanceEntrySet :: UpdateEntrySet -> State EntryBals [UEBalanced]
|
||||
rebalanceEntrySet
|
||||
UpdateEntrySet
|
||||
{ utFrom0
|
||||
, utTo0
|
||||
, utPairs
|
||||
, utFromUnk
|
||||
, utToUnk
|
||||
, utFromRO
|
||||
, utToRO
|
||||
, utCurrency
|
||||
, utToUnkLink0
|
||||
, utTotalValue
|
||||
} =
|
||||
do
|
||||
(f0val, (tpairs, fs)) <-
|
||||
fmap (second partitionEithers) $
|
||||
foldM goFrom (utTotalValue, []) $
|
||||
L.sortOn idx $
|
||||
(UET_ReadOnly <$> utFromRO)
|
||||
++ (UET_Unk <$> utFromUnk)
|
||||
++ (UET_Linked <$> utPairs)
|
||||
let f0 = utFrom0 {ueValue = StaticValue f0val}
|
||||
let tsLink0 = fmap (unlink (-f0val)) utToUnkLink0
|
||||
(t0val, tsUnk) <-
|
||||
fmap (second catMaybes) $
|
||||
foldM goTo (-utTotalValue, []) $
|
||||
L.sortOn idx2 $
|
||||
(UET_Linked <$> (tpairs ++ tsLink0))
|
||||
++ (UET_Unk <$> utToUnk)
|
||||
++ (UET_ReadOnly <$> utToRO)
|
||||
let t0 = utTo0 {ueValue = StaticValue t0val}
|
||||
return (f0 : fs ++ (t0 : tsUnk))
|
||||
where
|
||||
project f _ _ (UET_ReadOnly 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
|
||||
-- TODO the sum accumulator thing is kinda awkward
|
||||
goFrom (tot, es) (UET_ReadOnly e) = do
|
||||
v <- updateFixed e
|
||||
return (tot - v, es)
|
||||
goFrom (tot, esPrev) (UET_Unk e) = do
|
||||
v <- updateUnknown e
|
||||
return (tot - v, Right e {ueValue = StaticValue v} : esPrev)
|
||||
goFrom (tot, esPrev) (UET_Linked (e0, es)) = do
|
||||
v <- updateUnknown e0
|
||||
let e0' = Right $ e0 {ueValue = StaticValue v}
|
||||
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 v = case ueValue e of
|
||||
EVPercent p -> p * curBal
|
||||
EVBalance p -> p - curBal
|
||||
modify $ mapAdd_ key v
|
||||
return v
|
||||
unlink v e = e {ueValue = StaticValue $ v * unLinkScale (ueValue e)}
|
||||
|
||||
balanceEntrySet
|
||||
:: (MonadInsertError m, MonadFinance m)
|
||||
=> (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 = CurrencyPrec {cpID = curID, cpPrec = precision}
|
||||
, esTotalValue
|
||||
} =
|
||||
do
|
||||
-- 1. Resolve tag and accout ids in primary entries since we (might) need
|
||||
-- them later to calculate the total value of the transaction.
|
||||
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
|
||||
|
||||
-- 3. Balance all debit entries (including primary). Note the negative
|
||||
-- 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 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'
|
||||
|
||||
-- 4. Balance credit entries (including primary) analogously.
|
||||
let balToEntry = balanceEntry (balanceLinked fv curID precision) curID
|
||||
ts' <- doEntries balToEntry curID (-tot) t0' ts (NE.iterate (+ 1) 0)
|
||||
return $ fs' ++ ts'
|
||||
|
||||
doEntries
|
||||
:: (MonadInsertError m)
|
||||
=> (Int -> Entry AcntID v TagID -> StateT EntryBals m (InsertEntry AccountRId CurrencyRId TagRId))
|
||||
-> CurrencyRId
|
||||
-> Rational
|
||||
-> Entry AccountRId AcntSign TagRId
|
||||
-> [Entry AcntID v TagID]
|
||||
-> NonEmpty Int
|
||||
-> StateT EntryBals m [InsertEntry AccountRId CurrencyRId TagRId]
|
||||
doEntries f curID tot e es (i0 :| iN) = do
|
||||
es' <- mapErrors (uncurry f) $ zip iN es
|
||||
let e0val = tot - entrySum es'
|
||||
-- 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)
|
||||
|
||||
liftInnerS :: Monad m => StateT e Identity a -> StateT e m a
|
||||
liftInnerS = mapStateT (return . runIdentity)
|
||||
|
||||
balanceLinked
|
||||
:: MonadInsertError m
|
||||
=> Vector Rational
|
||||
-> CurrencyRId
|
||||
-> Natural
|
||||
-> AccountRId
|
||||
-> LinkDeferred Rational
|
||||
-> StateT EntryBals m (Rational, Maybe DBDeferred)
|
||||
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)
|
||||
-- TODO this error would be much more informative if I had access to the
|
||||
-- file from which it came
|
||||
Nothing -> throwError undefined
|
||||
(LinkDeferred d) -> liftInnerS $ balanceDeferred curID acntID d
|
||||
where
|
||||
go s = roundPrecision precision . (* s) . fromRational
|
||||
|
||||
balanceDeferred
|
||||
:: CurrencyRId
|
||||
-> AccountRId
|
||||
-> EntryValue Rational
|
||||
-> State EntryBals (Rational, Maybe DBDeferred)
|
||||
balanceDeferred curID acntID (EntryValue t v) = do
|
||||
newval <- findBalance acntID curID t v
|
||||
let d = case t of
|
||||
TFixed -> Nothing
|
||||
TBalance -> Just $ EntryBalance v
|
||||
TPercent -> Just $ EntryPercent v
|
||||
return (newval, d)
|
||||
|
||||
balanceEntry
|
||||
:: (MonadInsertError m, MonadFinance m)
|
||||
=> (AccountRId -> v -> StateT EntryBals m (Rational, Maybe DBDeferred))
|
||||
-> CurrencyRId
|
||||
-> Int
|
||||
-> Entry AcntID v TagID
|
||||
-> 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
|
||||
combineErrorM acntRes tagRes $ \(acntID, sign, _) tags -> do
|
||||
let s = fromIntegral $ sign2Int sign
|
||||
(newVal, deferred) <- f acntID eValue
|
||||
modify (mapAdd_ (acntID, curID) newVal)
|
||||
return $
|
||||
InsertEntry
|
||||
{ feEntry = e {eValue = s * newVal, eAcnt = acntID, eTags = tags}
|
||||
, feCurrency = curID
|
||||
, feDeferred = deferred
|
||||
, feIndex = idx
|
||||
}
|
||||
|
||||
resolveAcntAndTags
|
||||
:: (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 $ case t of
|
||||
TBalance -> v - curBal
|
||||
TPercent -> v * curBal
|
||||
TFixed -> v
|
||||
|
||||
expandTransfers
|
||||
:: (MonadInsertError m, MonadFinance m)
|
||||
=> TxCommit
|
||||
-> DaySpan
|
||||
-> [PairedTransfer]
|
||||
-> m [Tx TxCommit]
|
||||
expandTransfers tc bounds = fmap concat . mapErrors (expandTransfer tc bounds)
|
||||
|
||||
expandTransfer
|
||||
:: (MonadInsertError m, MonadFinance m)
|
||||
=> TxCommit
|
||||
-> DaySpan
|
||||
-> PairedTransfer
|
||||
-> m [Tx TxCommit]
|
||||
expandTransfer tc bounds Transfer {transAmounts, transTo, transCurrency, transFrom} = do
|
||||
txs <- mapErrors go transAmounts
|
||||
return $ filter (inDaySpan bounds . txDate) $ concat txs
|
||||
where
|
||||
go
|
||||
Amount
|
||||
{ amtWhen = pat
|
||||
, amtValue = TransferValue {tvVal = v, tvType = t}
|
||||
, amtDesc = desc
|
||||
} =
|
||||
withDates pat $ \day -> do
|
||||
p <- entryPair_ (\_ x -> EntryValue t $ toRational x) transFrom transTo transCurrency desc v
|
||||
return
|
||||
Tx
|
||||
{ txCommit = tc
|
||||
, txDate = day
|
||||
, txPrimary = p
|
||||
, txOther = []
|
||||
, txDescr = desc
|
||||
}
|
||||
|
||||
entryPair
|
||||
:: (MonadInsertError m, MonadFinance m)
|
||||
=> TaggedAcnt
|
||||
-> TaggedAcnt
|
||||
-> CurID
|
||||
-> T.Text
|
||||
-> Double
|
||||
-> m (EntrySet AcntID CurrencyPrec TagID Rational (EntryValue Rational))
|
||||
entryPair = entryPair_ (fmap (EntryValue TFixed) . roundPrecisionCur)
|
||||
|
||||
entryPair_
|
||||
:: (MonadInsertError m, MonadFinance m)
|
||||
=> (CurrencyPrec -> v -> v')
|
||||
-> TaggedAcnt
|
||||
-> TaggedAcnt
|
||||
-> CurID
|
||||
-> T.Text
|
||||
-> v
|
||||
-> m (EntrySet AcntID CurrencyPrec TagID Rational v')
|
||||
entryPair_ f from to_ curid com val = do
|
||||
cp <- lookupCurrency curid
|
||||
return $ pair cp from to_ (f cp val)
|
||||
where
|
||||
halfEntry :: a -> [t] -> HalfEntrySet a c t v
|
||||
halfEntry a ts =
|
||||
HalfEntrySet
|
||||
{ hesPrimary = Entry {eAcnt = a, eValue = (), eComment = com, eTags = ts}
|
||||
, hesOther = []
|
||||
}
|
||||
pair cp (TaggedAcnt fa fts) (TaggedAcnt ta tts) v =
|
||||
EntrySet
|
||||
{ esCurrency = cp
|
||||
, esTotalValue = v
|
||||
, esFrom = halfEntry fa fts
|
||||
, esTo = halfEntry ta tts
|
||||
}
|
||||
|
||||
withDates
|
||||
:: (MonadFinance m, MonadInsertError m)
|
||||
=> DatePat
|
||||
-> (Day -> m a)
|
||||
-> m [a]
|
||||
withDates dp f = do
|
||||
bounds <- askDBState kmBudgetInterval
|
||||
days <- liftExcept $ expandDatePat bounds dp
|
||||
combineErrors $ fmap f days
|
||||
|
|
|
|||
Loading…
Reference in New Issue