slaesvuo/hledger
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Clarify some code after review

Browse Source
This commit is contained in:
Michael Rees 2025-05-28 19:38:49 -05:00 committed by Simon Michael
parent 17f914e571
commit 5a4aa87df8
2 changed files with 14 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
hledger-lib/Hledger/Data/Balancing.hs
View File

@ -19,7 +19,7 @@ module Hledger.Data.Balancing
, balanceTransaction , balanceTransaction
, balanceTransactionHelper , balanceTransactionHelper
-- * assertion validation -- * assertion validation
, checkAssertions , transactionCheckAssertions
-- * journal balancing -- * journal balancing
, journalBalanceTransactions , journalBalanceTransactions
-- * tests -- * tests
@ -150,12 +150,14 @@ isTransactionBalanced bopts = null . transactionCheckBalanced bopts
-- | Verify that any assertions in this transaction hold -- | Verify that any assertions in this transaction hold
-- when included in the larger journal. -- when included in the larger journal.
checkAssertions :: BalancingOpts -> Journal -> Transaction -> Either String Transaction transactionCheckAssertions :: BalancingOpts -> Journal -> Transaction -> Either String Transaction
checkAssertions bopts j t = transactionCheckAssertions bopts j t =
if (ignore_assertions_ bopts) || noassertions t then Right t else do if (ignore_assertions_ bopts) || noassertions t then Right t else do
j' <- journalStyleAmounts j j' <- journalStyleAmounts j
let newtxns = sortOn tdate (jtxns j' ++ [ t ]) let newtxns = sortOn tdate (jtxns j' ++ [ t ])
fmap (\_ -> t) $ journalBalanceTransactions defbalancingopts j'{jtxns = newtxns} case journalBalanceTransactions defbalancingopts j'{jtxns = newtxns} of
Right _ -> Right t
Left e -> Left e
where where
noassertions = all (isNothing . pbalanceassertion) . tpostings noassertions = all (isNothing . pbalanceassertion) . tpostings
@ -1085,16 +1087,16 @@ tests_Balancing =
] ]
,testGroup "checkAssertions" $ [ ,testGroup "transactionCheckAssertions" $ [
testCase "simple assertion on same day" $ do testCase "simple assertion on same day" $ do
assertRight $ assertRight $
checkAssertions defbalancingopts nulljournal{ jtxns = [ transactionCheckAssertions defbalancingopts nulljournal{ jtxns = [
transaction (fromGregorian 2025 01 01) [ vpost' "a" (usd 1) Nothing ] transaction (fromGregorian 2025 01 01) [ vpost' "a" (usd 1) Nothing ]
] } (transaction (fromGregorian 2025 01 01) [ vpost' "a" (usd 1) (balassert (usd 2)) ]) ] } (transaction (fromGregorian 2025 01 01) [ vpost' "a" (usd 1) (balassert (usd 2)) ])
,testCase "inclusive assertions" $ do ,testCase "inclusive assertions" $ do
assertRight $ assertRight $
checkAssertions defbalancingopts nulljournal{ jtxns = [ transactionCheckAssertions defbalancingopts nulljournal{ jtxns = [
transaction (fromGregorian 2025 01 01) [ vpost' "a:a" (usd 1) Nothing ] transaction (fromGregorian 2025 01 01) [ vpost' "a:a" (usd 1) Nothing ]
,transaction (fromGregorian 2025 01 02) [ vpost' "a:b" (usd 2) Nothing] ,transaction (fromGregorian 2025 01 02) [ vpost' "a:b" (usd 2) Nothing]
,transaction (fromGregorian 2025 01 02) [ vpost' "a:c" (usd 5) Nothing] ,transaction (fromGregorian 2025 01 02) [ vpost' "a:c" (usd 5) Nothing]
@ -1103,7 +1105,7 @@ tests_Balancing =
,testCase "multicommodity assertion" $ do ,testCase "multicommodity assertion" $ do
assertRight $ assertRight $
checkAssertions defbalancingopts nulljournal{ jtxns = [ transactionCheckAssertions defbalancingopts nulljournal{ jtxns = [
transaction (fromGregorian 2025 01 01) [ vpost' "a" (usd 1) Nothing ] transaction (fromGregorian 2025 01 01) [ vpost' "a" (usd 1) Nothing ]
,transaction (fromGregorian 2025 01 02) [ vpost' "a:b" (eur 2) Nothing ] ,transaction (fromGregorian 2025 01 02) [ vpost' "a:b" (eur 2) Nothing ]
,transaction (fromGregorian 2025 01 02) [ vpost' "a:c" (usd 5) Nothing ] ,transaction (fromGregorian 2025 01 02) [ vpost' "a:c" (usd 5) Nothing ]

10
hledger/Hledger/Cli/Commands/Add.hs
View File

@ -232,12 +232,9 @@ confirmedTransactionWizard prevInput es@EntryState{..} stack@(currentStage : _)
EnterAmountAndComment txnParams account -> amountAndCommentWizard prevInput es >>= \case EnterAmountAndComment txnParams account -> amountAndCommentWizard prevInput es >>= \case
Just (amt, assertion, (comment, tags, pdate1, pdate2)) -> do Just (amt, assertion, (comment, tags, pdate1, pdate2)) -> do
-- This check is necessary because we cons a ';' in the comment parser above,
-- and we don't want to add an empty comment here if it wasn't given.
let pcomment = if T.length comment == 1 then "" else comment
let p = nullposting{paccount=T.pack $ stripbrackets account let p = nullposting{paccount=T.pack $ stripbrackets account
,pamount=mixedAmount amt ,pamount=mixedAmount amt
,pcomment=pcomment ,pcomment=T.dropAround isNewline comment
,ptype=accountNamePostingType $ T.pack account ,ptype=accountNamePostingType $ T.pack account
,pbalanceassertion = assertion ,pbalanceassertion = assertion
,pdate=pdate1 ,pdate=pdate1
@ -251,7 +248,7 @@ confirmedTransactionWizard prevInput es@EntryState{..} stack@(currentStage : _)
dummytxn = nulltransaction{tpostings = esPostings ++ [p, post "" missingamt] dummytxn = nulltransaction{tpostings = esPostings ++ [p, post "" missingamt]
,tdate = txnDate txnParams ,tdate = txnDate txnParams
,tdescription = txnDesc txnParams } ,tdescription = txnDesc txnParams }
validated = balanceTransaction defbalancingopts dummytxn >>= checkAssertions defbalancingopts esJournal validated = balanceTransaction defbalancingopts dummytxn >>= transactionCheckAssertions defbalancingopts esJournal
case validated of case validated of
Left err -> do Left err -> do
liftIO (hPutStrLn stderr err) liftIO (hPutStrLn stderr err)
@ -388,7 +385,8 @@ amountAndCommentWizard previnput@PrevInput{..} entrystate@EntryState{..} = do
com <- T.pack <$> fromMaybe "" `fmap` optional (char ';' >> many anySingle) com <- T.pack <$> fromMaybe "" `fmap` optional (char ';' >> many anySingle)
case rtp (postingcommentp Nothing) (T.cons ';' com) of case rtp (postingcommentp Nothing) (T.cons ';' com) of
Left err -> fail $ customErrorBundlePretty err Left err -> fail $ customErrorBundlePretty err
Right comment -> return $ (a, assertion, comment) -- Keep our original comment string from the user to add to the journal
Right (_, tags, date1', date2') -> return $ (a, assertion, (com, tags, date1', date2'))
balancingamt = maNegate . sumPostings $ filter isReal esPostings balancingamt = maNegate . sumPostings $ filter isReal esPostings
balancingamtfirstcommodity = mixed . take 1 $ amounts balancingamt balancingamtfirstcommodity = mixed . take 1 $ amounts balancingamt
showamt = wbUnpack . showMixedAmountB defaultFmt . mixedAmountSetPrecision showamt = wbUnpack . showMixedAmountB defaultFmt . mixedAmountSetPrecision