lib: refactor
This commit is contained in:
Simon Michael
parent
0c835acd18
commit
91e3ddd4fb
@ -485,21 +485,21 @@ filterJournalTransactionsByAccount apats j@Journal{jtxns=ts} = j{jtxns=filter tm
|
||||
-}
|
||||
|
||||
-- | Do post-parse processing on a parsed journal to make it ready for
|
||||
-- use. Reverse parsed data to normal order, canonicalise amount
|
||||
-- use. Reverse parsed data to normal order, standardise amount
|
||||
-- formats, check/ensure that transactions are balanced, and maybe
|
||||
-- check balance assertions.
|
||||
journalFinalise :: ClockTime -> FilePath -> Text -> Bool -> ParsedJournal -> Either String Journal
|
||||
journalFinalise t path txt assrt j@Journal{jfiles=fs} = do
|
||||
(journalTieTransactions <$>
|
||||
journalFinalise t path txt assrt j@Journal{jfiles=fs} =
|
||||
journalTieTransactions <$>
|
||||
(journalBalanceTransactions assrt $
|
||||
journalApplyCommodityStyles $
|
||||
j{ jfiles = (path,txt) : reverse fs
|
||||
, jlastreadtime = t
|
||||
, jtxns = reverse $ jtxns j -- NOTE: see addTransaction
|
||||
, jmodifiertxns = reverse $ jmodifiertxns j -- NOTE: see addModifierTransaction
|
||||
, jperiodictxns = reverse $ jperiodictxns j -- NOTE: see addPeriodicTransaction
|
||||
, jmarketprices = reverse $ jmarketprices j -- NOTE: see addMarketPrice
|
||||
}))
|
||||
j {jfiles = (path,txt) : reverse fs
|
||||
,jlastreadtime = t
|
||||
,jtxns = reverse $ jtxns j -- NOTE: see addTransaction
|
||||
,jmodifiertxns = reverse $ jmodifiertxns j -- NOTE: see addModifierTransaction
|
||||
,jperiodictxns = reverse $ jperiodictxns j -- NOTE: see addPeriodicTransaction
|
||||
,jmarketprices = reverse $ jmarketprices j -- NOTE: see addMarketPrice
|
||||
})
|
||||
|
||||
journalNumberAndTieTransactions = journalTieTransactions . journalNumberTransactions
|
||||
|
||||
@ -521,9 +521,12 @@ journalUntieTransactions t@Transaction{tpostings=ps} = t{tpostings=map (\p -> p{
|
||||
-- message if any of them fail.
|
||||
journalCheckBalanceAssertions :: Journal -> Either String Journal
|
||||
journalCheckBalanceAssertions j =
|
||||
runST $ journalBalanceTransactionsST True j
|
||||
(return ()) (\_ _ -> return ()) (const $ return j) -- noops
|
||||
|
||||
runST $ journalBalanceTransactionsST
|
||||
True
|
||||
j
|
||||
(return ())
|
||||
(\_ _ -> return ())
|
||||
(const $ return j)
|
||||
|
||||
-- | Check a posting's balance assertion and return an error if it
|
||||
-- fails.
|
||||
@ -561,59 +564,58 @@ checkBalanceAssertion p@Posting{ pbalanceassertion = Just (ass,_)} amt
|
||||
(diffplus ++ showAmount diff)
|
||||
checkBalanceAssertion _ _ = Right ()
|
||||
|
||||
-- | Environment for 'CurrentBalancesModifier'
|
||||
data Env s = Env { eBalances :: HT.HashTable s AccountName MixedAmount
|
||||
, eStoreTx :: Transaction -> ST s ()
|
||||
, eAssrt :: Bool
|
||||
, eStyles :: Maybe (M.Map CommoditySymbol AmountStyle) }
|
||||
|
||||
-- | Monad transformer stack with a reference to a mutable hashtable
|
||||
-- of current account balances and a mutable array of finished
|
||||
-- transactions in original parsing order.
|
||||
type CurrentBalancesModifier s = R.ReaderT (Env s) (ExceptT String (ST s))
|
||||
|
||||
-- | Fill in any missing amounts and check that all journal transactions
|
||||
-- balance, or return an error message. This is done after parsing all
|
||||
-- amounts and applying canonical commodity styles, since balancing
|
||||
-- depends on display precision. Reports only the first error encountered.
|
||||
journalBalanceTransactions :: Bool -> Journal -> Either String Journal
|
||||
journalBalanceTransactions assrt j =
|
||||
runST $
|
||||
journalBalanceTransactionsST
|
||||
runST $ journalBalanceTransactionsST
|
||||
assrt -- check balance assertions also ?
|
||||
(journalNumberTransactions j) -- journal to process
|
||||
(newArray_ (1, genericLength $ jtxns j) :: forall s. ST s (STArray s Integer Transaction)) -- initialise state
|
||||
(\arr tx -> writeArray arr (tindex tx) tx) -- update state
|
||||
(fmap (\txns -> j{ jtxns = txns}) . getElems) -- summarise state
|
||||
|
||||
|
||||
-- | Generalization used in the definition of
|
||||
-- 'journalBalanceTransactionsST and 'journalCheckBalanceAssertions'
|
||||
-- | Helper used by 'journalBalanceTransactions' and 'journalCheckBalanceAssertions'.
|
||||
journalBalanceTransactionsST ::
|
||||
Bool
|
||||
-> Journal
|
||||
-> ST s txns
|
||||
-- ^ creates transaction store
|
||||
-> (txns -> Transaction -> ST s ())
|
||||
-- ^ "store" operation
|
||||
-> (txns -> ST s a)
|
||||
-- ^ calculate result from transactions
|
||||
-> ST s txns -- ^ initialise state
|
||||
-> (txns -> Transaction -> ST s ()) -- ^ update state
|
||||
-> (txns -> ST s a) -- ^ summarise state
|
||||
-> ST s (Either String a)
|
||||
journalBalanceTransactionsST assrt j createStore storeIn extract =
|
||||
runExceptT $ do
|
||||
bals <- lift $ HT.newSized size
|
||||
txStore <- lift $ createStore
|
||||
flip R.runReaderT (Env bals (storeIn txStore) assrt $
|
||||
Just $ jinferredcommodities j) $ do
|
||||
let env = Env bals
|
||||
(storeIn txStore)
|
||||
assrt
|
||||
(Just $ jinferredcommodities j)
|
||||
flip R.runReaderT env $ do
|
||||
dated <- fmap snd . sortBy (comparing fst) . concat
|
||||
<$> mapM' discriminateByDate (jtxns j)
|
||||
mapM' checkInferAndRegisterAmounts dated
|
||||
lift $ extract txStore
|
||||
where size = genericLength $ journalPostings j
|
||||
where
|
||||
size = genericLength $ journalPostings j
|
||||
|
||||
-- | This converts a transaction into a list of objects whose dates
|
||||
-- have to be considered when checking balance assertions and handled
|
||||
-- by 'checkInferAndRegisterAmounts'.
|
||||
-- | Monad transformer stack with a reference to a mutable hashtable
|
||||
-- of current account balances and a mutable array of finished
|
||||
-- transactions in original parsing order.
|
||||
type CurrentBalancesModifier s = R.ReaderT (Env s) (ExceptT String (ST s))
|
||||
|
||||
-- | Environment for 'CurrentBalancesModifier'
|
||||
data Env s = Env { eBalances :: HT.HashTable s AccountName MixedAmount
|
||||
, eStoreTx :: Transaction -> ST s ()
|
||||
, eAssrt :: Bool
|
||||
, eStyles :: Maybe (M.Map CommoditySymbol AmountStyle)
|
||||
}
|
||||
|
||||
-- | This converts a transaction into a list of transactions or
|
||||
-- postings whose dates have to be considered when checking
|
||||
-- balance assertions and handled by 'checkInferAndRegisterAmounts'.
|
||||
--
|
||||
-- Transaction without balance assignments can be balanced and stored
|
||||
-- immediately and their (possibly) dated postings are returned.
|
||||
@ -626,25 +628,24 @@ discriminateByDate :: Transaction
|
||||
discriminateByDate tx
|
||||
| null (assignmentPostings tx) = do
|
||||
styles <- R.reader $ eStyles
|
||||
balanced <- lift $ ExceptT $ return
|
||||
$ balanceTransaction styles tx
|
||||
balanced <- lift $ ExceptT $ return $ balanceTransaction styles tx
|
||||
storeTransaction balanced
|
||||
return $ fmap (postingDate &&& (Left . removePrices))
|
||||
$ tpostings $ balanced
|
||||
return $
|
||||
fmap (postingDate &&& (Left . removePrices)) $ tpostings $ balanced
|
||||
| True = do
|
||||
when (any (isJust . pdate) $ tpostings tx) $
|
||||
throwError $ unlines $
|
||||
["Not supported: Transactions with balance assignments "
|
||||
,"AND dated postings without amount:\n"
|
||||
, showTransaction tx]
|
||||
return [(tdate tx, Right
|
||||
$ tx { tpostings = removePrices <$> tpostings tx })]
|
||||
return
|
||||
[(tdate tx, Right $ tx { tpostings = removePrices <$> tpostings tx })]
|
||||
|
||||
-- | This function takes different objects describing changes to
|
||||
-- account balances on a single day. It can handle either a single
|
||||
-- posting (from an already balanced transaction without assigments)
|
||||
-- or a whole transaction with assignments (which is required to no
|
||||
-- posting with pdate set.).
|
||||
-- | This function takes an object describing changes to
|
||||
-- account balances on a single day - either a single posting
|
||||
-- (from an already balanced transaction without assignments)
|
||||
-- or a whole transaction with assignments (which is required to
|
||||
-- have no posting with pdate set).
|
||||
--
|
||||
-- For a single posting, there is not much to do. Only add its amount
|
||||
-- to its account and check the assertion, if there is one. This
|
||||
@ -654,9 +655,9 @@ discriminateByDate tx
|
||||
-- 'addAmountAndCheckBalance', if there is an amount. If there is no
|
||||
-- amount, the amount is inferred by the assertion or left empty if
|
||||
-- there is no assertion. Then, the transaction is balanced, the
|
||||
-- inferred amount added to the balance (all in
|
||||
-- 'balanceTransactionUpdate') and the resulting transaction with no
|
||||
-- missing amounts is stored in the array, for later retrieval.
|
||||
-- inferred amount added to the balance (all in 'balanceTransactionUpdate')
|
||||
-- and the resulting transaction with no missing amounts is stored
|
||||
-- in the array, for later retrieval.
|
||||
--
|
||||
-- Again in short:
|
||||
--
|
||||
@ -682,23 +683,22 @@ checkInferAndRegisterAmounts (Right oldTx) = do
|
||||
(fmap (\a -> p { pamount = a, porigin = Just $ originalPosting p }) . setBalance (paccount p) . fst)
|
||||
$ pbalanceassertion p
|
||||
|
||||
-- | Adds a posting's amonut to the posting's account balance and
|
||||
-- checks a possible balance assertion. If there is no amount, it runs
|
||||
-- the supplied fallback action.
|
||||
addAmountAndCheckBalance :: (Posting -> CurrentBalancesModifier s Posting)
|
||||
-- ^ action to execute, if posting has no amount
|
||||
-- | Adds a posting's amount to the posting's account balance and
|
||||
-- checks a possible balance assertion. Or if there is no amount,
|
||||
-- runs the supplied fallback action.
|
||||
addAmountAndCheckBalance ::
|
||||
(Posting -> CurrentBalancesModifier s Posting) -- ^ action if posting has no amount
|
||||
-> Posting
|
||||
-> CurrentBalancesModifier s Posting
|
||||
addAmountAndCheckBalance _ p | hasAmount p = do
|
||||
newAmt <- addToBalance (paccount p) $ pamount p
|
||||
assrt <- R.reader eAssrt
|
||||
lift $ when assrt $ ExceptT $ return
|
||||
$ checkBalanceAssertion p newAmt
|
||||
lift $ when assrt $ ExceptT $ return $ checkBalanceAssertion p newAmt
|
||||
return p
|
||||
addAmountAndCheckBalance fallback p = fallback p
|
||||
|
||||
-- | Sets an account's balance to a given amount and returns the
|
||||
-- difference of new and old amount
|
||||
-- difference of new and old amount.
|
||||
setBalance :: AccountName -> Amount -> CurrentBalancesModifier s MixedAmount
|
||||
setBalance acc amt = liftModifier $ \Env{ eBalances = bals } -> do
|
||||
old <- HT.lookup bals acc
|
||||
@ -707,20 +707,18 @@ setBalance acc amt = liftModifier $ \Env{ eBalances = bals } -> do
|
||||
HT.insert bals acc new
|
||||
return $ maybe new (new -) old
|
||||
|
||||
-- | Adds an amount to an account's balance and returns the resulting
|
||||
-- balance
|
||||
-- | Adds an amount to an account's balance and returns the resulting balance.
|
||||
addToBalance :: AccountName -> MixedAmount -> CurrentBalancesModifier s MixedAmount
|
||||
addToBalance acc amt = liftModifier $ \Env{ eBalances = bals } -> do
|
||||
new <- maybe amt (+ amt) <$> HT.lookup bals acc
|
||||
HT.insert bals acc new
|
||||
return new
|
||||
|
||||
-- | Stores a transaction in the transaction array in original parsing
|
||||
-- order.
|
||||
-- | Stores a transaction in the transaction array in original parsing order.
|
||||
storeTransaction :: Transaction -> CurrentBalancesModifier s ()
|
||||
storeTransaction tx = liftModifier $ ($tx) . eStoreTx
|
||||
|
||||
-- | Helper function
|
||||
-- | Helper function.
|
||||
liftModifier :: (Env s -> ST s a) -> CurrentBalancesModifier s a
|
||||
liftModifier f = R.ask >>= lift . lift . f
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user