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

tests: port all unit tests to tasty, second pass (#1090)

Browse Source 
Hledger.Util.Tests helpers have been cleaned up, and test names are
now shown.

Tests have been cleaned up a bit. Some groups of unnamed tests have
been collapsed into a single named test containing a sequence of
assertions. The test command counts named tests, not assertions, so
the reported unit test count has dropped from 199 to 188.
This commit is contained in:
Simon Michael 2019-11-27 12:46:29 -08:00
parent 13a3542464
commit b36f6df110
22 changed files with 633 additions and 731 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

38
hledger-lib/Hledger/Data/AccountName.hs
View File

@ -227,27 +227,23 @@ accountRegexToAccountName = T.pack . regexReplace "^\\^(.*?)\\(:\\|\\$\\)$" "\\1
--isAccountRegex s = take 1 s == "^" && take 5 (reverse s) == ")$|:(" --isAccountRegex s = take 1 s == "^" && take 5 (reverse s) == ")$|:("
tests_AccountName = tests "AccountName" [ tests_AccountName = tests "AccountName" [
tests "accountNameTreeFrom" [ testCase "accountNameTreeFrom" $ do
accountNameTreeFrom ["a"] `is` Node "root" [Node "a" []] accountNameTreeFrom ["a"] @?= Node "root" [Node "a" []]
,accountNameTreeFrom ["a","b"] `is` Node "root" [Node "a" [], Node "b" []] accountNameTreeFrom ["a","b"] @?= Node "root" [Node "a" [], Node "b" []]
,accountNameTreeFrom ["a","a:b"] `is` Node "root" [Node "a" [Node "a:b" []]] accountNameTreeFrom ["a","a:b"] @?= Node "root" [Node "a" [Node "a:b" []]]
,accountNameTreeFrom ["a:b:c"] `is` Node "root" [Node "a" [Node "a:b" [Node "a:b:c" []]]] accountNameTreeFrom ["a:b:c"] @?= Node "root" [Node "a" [Node "a:b" [Node "a:b:c" []]]]
] ,testCase "expandAccountNames" $ do
,tests "expandAccountNames" [ expandAccountNames ["assets:cash","assets:checking","expenses:vacation"] @?=
expandAccountNames ["assets:cash","assets:checking","expenses:vacation"] `is`
["assets","assets:cash","assets:checking","expenses","expenses:vacation"] ["assets","assets:cash","assets:checking","expenses","expenses:vacation"]
] ,testCase "isAccountNamePrefixOf" $ do
,tests "isAccountNamePrefixOf" [ "assets" `isAccountNamePrefixOf` "assets" @?= False
"assets" `isAccountNamePrefixOf` "assets" `is` False "assets" `isAccountNamePrefixOf` "assets:bank" @?= True
,"assets" `isAccountNamePrefixOf` "assets:bank" `is` True "assets" `isAccountNamePrefixOf` "assets:bank:checking" @?= True
,"assets" `isAccountNamePrefixOf` "assets:bank:checking" `is` True "my assets" `isAccountNamePrefixOf` "assets:bank" @?= False
,"my assets" `isAccountNamePrefixOf` "assets:bank" `is` False ,testCase "isSubAccountNameOf" $ do
] "assets" `isSubAccountNameOf` "assets" @?= False
,tests "isSubAccountNameOf" [ "assets:bank" `isSubAccountNameOf` "assets" @?= True
"assets" `isSubAccountNameOf` "assets" `is` False "assets:bank:checking" `isSubAccountNameOf` "assets" @?= False
,"assets:bank" `isSubAccountNameOf` "assets" `is` True "assets:bank" `isSubAccountNameOf` "my assets" @?= False
,"assets:bank:checking" `isSubAccountNameOf` "assets" `is` False
,"assets:bank" `isSubAccountNameOf` "my assets" `is` False
]
] ]

111
hledger-lib/Hledger/Data/Amount.hs
View File

@ -735,99 +735,88 @@ mixedAmountTotalPriceToUnitPrice (Mixed as) = Mixed $ map amountTotalPriceToUnit
tests_Amount = tests "Amount" [ tests_Amount = tests "Amount" [
tests "Amount" [ tests "Amount" [
tests "costOfAmount" [ testCase "costOfAmount" $ do
costOfAmount (eur 1) `is` eur 1 costOfAmount (eur 1) @?= eur 1
,costOfAmount (eur 2){aprice=Just $ UnitPrice $ usd 2} `is` usd 4 costOfAmount (eur 2){aprice=Just $ UnitPrice $ usd 2} @?= usd 4
,costOfAmount (eur 1){aprice=Just $ TotalPrice $ usd 2} `is` usd 2 costOfAmount (eur 1){aprice=Just $ TotalPrice $ usd 2} @?= usd 2
,costOfAmount (eur (-1)){aprice=Just $ TotalPrice $ usd 2} `is` usd (-2) costOfAmount (eur (-1)){aprice=Just $ TotalPrice $ usd 2} @?= usd (-2)
]
,tests "isZeroAmount" [ ,testCase "isZeroAmount" $ do
expect $ isZeroAmount amount assertBool "" $ isZeroAmount amount
,expect $ isZeroAmount $ usd 0 assertBool "" $ isZeroAmount $ usd 0
]
,tests "negating amounts" [ ,testCase "negating amounts" $ do
negate (usd 1) `is` (usd 1){aquantity= -1} negate (usd 1) @?= (usd 1){aquantity= -1}
,let b = (usd 1){aprice=Just $ UnitPrice $ eur 2} in negate b `is` b{aquantity= -1} let b = (usd 1){aprice=Just $ UnitPrice $ eur 2} in negate b @?= b{aquantity= -1}
]
,tests "adding amounts without prices" [ ,testCase "adding amounts without prices" $ do
(usd 1.23 + usd (-1.23)) `is` usd 0 (usd 1.23 + usd (-1.23)) @?= usd 0
,(usd 1.23 + usd (-1.23)) `is` usd 0 (usd 1.23 + usd (-1.23)) @?= usd 0
,(usd (-1.23) + usd (-1.23)) `is` usd (-2.46) (usd (-1.23) + usd (-1.23)) @?= usd (-2.46)
,sum [usd 1.23,usd (-1.23),usd (-1.23),-(usd (-1.23))] `is` usd 0 sum [usd 1.23,usd (-1.23),usd (-1.23),-(usd (-1.23))] @?= usd 0
-- highest precision is preserved -- highest precision is preserved
,asprecision (astyle $ sum [usd 1 `withPrecision` 1, usd 1 `withPrecision` 3]) `is` 3 asprecision (astyle $ sum [usd 1 `withPrecision` 1, usd 1 `withPrecision` 3]) @?= 3
,asprecision (astyle $ sum [usd 1 `withPrecision` 3, usd 1 `withPrecision` 1]) `is` 3 asprecision (astyle $ sum [usd 1 `withPrecision` 3, usd 1 `withPrecision` 1]) @?= 3
-- adding different commodities assumes conversion rate 1 -- adding different commodities assumes conversion rate 1
,expect $ isZeroAmount (usd 1.23 - eur 1.23) assertBool "" $ isZeroAmount (usd 1.23 - eur 1.23)
]
,tests "showAmount" [ ,testCase "showAmount" $ do
showAmount (usd 0 + gbp 0) `is` "0" showAmount (usd 0 + gbp 0) @?= "0"
]
] ]
,tests "MixedAmount" [ ,tests "MixedAmount" [
tests "adding mixed amounts to zero, the commodity and amount style are preserved" [ testCase "adding mixed amounts to zero, the commodity and amount style are preserved" $
sum (map (Mixed . (:[])) sum (map (Mixed . (:[]))
[usd 1.25 [usd 1.25
,usd (-1) `withPrecision` 3 ,usd (-1) `withPrecision` 3
,usd (-0.25) ,usd (-0.25)
]) ])
`is` Mixed [usd 0 `withPrecision` 3] @?= Mixed [usd 0 `withPrecision` 3]
]
,tests "adding mixed amounts with total prices" [ ,testCase "adding mixed amounts with total prices" $ do
sum (map (Mixed . (:[])) sum (map (Mixed . (:[]))
[usd 1 @@ eur 1 [usd 1 @@ eur 1
,usd (-2) @@ eur 1 ,usd (-2) @@ eur 1
]) ])
`is` Mixed [usd 1 @@ eur 1 @?= Mixed [usd 1 @@ eur 1
,usd (-2) @@ eur 1 ,usd (-2) @@ eur 1
] ]
]
,tests "showMixedAmount" [ ,testCase "showMixedAmount" $ do
showMixedAmount (Mixed [usd 1]) `is` "$1.00" showMixedAmount (Mixed [usd 1]) @?= "$1.00"
,showMixedAmount (Mixed [usd 1 `at` eur 2]) `is` "$1.00 @ €2.00" showMixedAmount (Mixed [usd 1 `at` eur 2]) @?= "$1.00 @ €2.00"
,showMixedAmount (Mixed [usd 0]) `is` "0" showMixedAmount (Mixed [usd 0]) @?= "0"
,showMixedAmount (Mixed []) `is` "0" showMixedAmount (Mixed []) @?= "0"
,showMixedAmount missingmixedamt `is` "" showMixedAmount missingmixedamt @?= ""
]
,tests "showMixedAmountWithoutPrice" $ ,testCase "showMixedAmountWithoutPrice" $ do
let a = usd 1 `at` eur 2 in let a = usd 1 `at` eur 2
[ showMixedAmountWithoutPrice (Mixed [a]) @?= "$1.00"
showMixedAmountWithoutPrice (Mixed [a]) `is` "$1.00" showMixedAmountWithoutPrice (Mixed [a, -a]) @?= "0"
,showMixedAmountWithoutPrice (Mixed [a, -a]) `is` "0"
]
,tests "normaliseMixedAmount" [ ,tests "normaliseMixedAmount" [
test "a missing amount overrides any other amounts" $ testCase "a missing amount overrides any other amounts" $
normaliseMixedAmount (Mixed [usd 1, missingamt]) `is` missingmixedamt normaliseMixedAmount (Mixed [usd 1, missingamt]) @?= missingmixedamt
,test "unpriced same-commodity amounts are combined" $ ,testCase "unpriced same-commodity amounts are combined" $
normaliseMixedAmount (Mixed [usd 0, usd 2]) `is` Mixed [usd 2] normaliseMixedAmount (Mixed [usd 0, usd 2]) @?= Mixed [usd 2]
,test "amounts with same unit price are combined" $ ,testCase "amounts with same unit price are combined" $
normaliseMixedAmount (Mixed [usd 1 `at` eur 1, usd 1 `at` eur 1]) `is` Mixed [usd 2 `at` eur 1] normaliseMixedAmount (Mixed [usd 1 `at` eur 1, usd 1 `at` eur 1]) @?= Mixed [usd 2 `at` eur 1]
,test "amounts with different unit prices are not combined" $ ,testCase "amounts with different unit prices are not combined" $
normaliseMixedAmount (Mixed [usd 1 `at` eur 1, usd 1 `at` eur 2]) `is` Mixed [usd 1 `at` eur 1, usd 1 `at` eur 2] normaliseMixedAmount (Mixed [usd 1 `at` eur 1, usd 1 `at` eur 2]) @?= Mixed [usd 1 `at` eur 1, usd 1 `at` eur 2]
,test "amounts with total prices are not combined" $ ,testCase "amounts with total prices are not combined" $
normaliseMixedAmount (Mixed [usd 1 @@ eur 1, usd 1 @@ eur 1]) `is` Mixed [usd 1 @@ eur 1, usd 1 @@ eur 1] normaliseMixedAmount (Mixed [usd 1 @@ eur 1, usd 1 @@ eur 1]) @?= Mixed [usd 1 @@ eur 1, usd 1 @@ eur 1]
] ]
,tests "normaliseMixedAmountSquashPricesForDisplay" [ ,testCase "normaliseMixedAmountSquashPricesForDisplay" $ do
normaliseMixedAmountSquashPricesForDisplay (Mixed []) `is` Mixed [nullamt] normaliseMixedAmountSquashPricesForDisplay (Mixed []) @?= Mixed [nullamt]
,expect $ isZeroMixedAmount $ normaliseMixedAmountSquashPricesForDisplay assertBool "" $ isZeroMixedAmount $ normaliseMixedAmountSquashPricesForDisplay
(Mixed [usd 10 (Mixed [usd 10
,usd 10 @@ eur 7 ,usd 10 @@ eur 7
,usd (-10) ,usd (-10)
,usd (-10) @@ eur 7 ,usd (-10) @@ eur 7
]) ])
]
] ]

36
hledger-lib/Hledger/Data/Journal.hs
View File

@ -1296,7 +1296,7 @@ Right samplejournal = journalBalanceTransactions False $
tests_Journal = tests "Journal" [ tests_Journal = tests "Journal" [
test "journalDateSpan" $ testCase "journalDateSpan" $
journalDateSpan True nulljournal{ journalDateSpan True nulljournal{
jtxns = [nulltransaction{tdate = parsedate "2014/02/01" jtxns = [nulltransaction{tdate = parsedate "2014/02/01"
,tpostings = [posting{pdate=Just (parsedate "2014/01/10")}] ,tpostings = [posting{pdate=Just (parsedate "2014/01/10")}]
@ -1306,7 +1306,7 @@ tests_Journal = tests "Journal" [
} }
] ]
} }
`is` (DateSpan (Just $ fromGregorian 2014 1 10) (Just $ fromGregorian 2014 10 11)) @?= (DateSpan (Just $ fromGregorian 2014 1 10) (Just $ fromGregorian 2014 10 11))
,tests "standard account type queries" $ ,tests "standard account type queries" $
let let
@ -1315,16 +1315,16 @@ tests_Journal = tests "Journal" [
journalAccountNamesMatching q = filter (q `matchesAccount`) . journalAccountNames journalAccountNamesMatching q = filter (q `matchesAccount`) . journalAccountNames
namesfrom qfunc = journalAccountNamesMatching (qfunc j) j namesfrom qfunc = journalAccountNamesMatching (qfunc j) j
in [ in [
test "assets" $ expectEq (namesfrom journalAssetAccountQuery) ["assets","assets:bank","assets:bank:checking","assets:bank:saving","assets:cash"] testCase "assets" $ assertEqual "" (namesfrom journalAssetAccountQuery) ["assets","assets:bank","assets:bank:checking","assets:bank:saving","assets:cash"]
,test "liabilities" $ expectEq (namesfrom journalLiabilityAccountQuery) ["liabilities","liabilities:debts"] ,testCase "liabilities" $ assertEqual "" (namesfrom journalLiabilityAccountQuery) ["liabilities","liabilities:debts"]
,test "equity" $ expectEq (namesfrom journalEquityAccountQuery) [] ,testCase "equity" $ assertEqual "" (namesfrom journalEquityAccountQuery) []
,test "income" $ expectEq (namesfrom journalRevenueAccountQuery) ["income","income:gifts","income:salary"] ,testCase "income" $ assertEqual "" (namesfrom journalRevenueAccountQuery) ["income","income:gifts","income:salary"]
,test "expenses" $ expectEq (namesfrom journalExpenseAccountQuery) ["expenses","expenses:food","expenses:supplies"] ,testCase "expenses" $ assertEqual "" (namesfrom journalExpenseAccountQuery) ["expenses","expenses:food","expenses:supplies"]
] ]
,tests "journalBalanceTransactions" [ ,tests "journalBalanceTransactions" [
test "balance-assignment" $ testCaseSteps "sometests" $ \_step -> do testCase "balance-assignment" $ do
let ej = journalBalanceTransactions True $ let ej = journalBalanceTransactions True $
--2019/01/01 --2019/01/01
-- (a) = 1 -- (a) = 1
@ -1335,8 +1335,8 @@ tests_Journal = tests "Journal" [
let Right j = ej let Right j = ej
(jtxns j & head & tpostings & head & pamount) @?= Mixed [num 1] (jtxns j & head & tpostings & head & pamount) @?= Mixed [num 1]
,test "same-day-1" $ do ,testCase "same-day-1" $ do
expectRight $ journalBalanceTransactions True $ assertRight $ journalBalanceTransactions True $
--2019/01/01 --2019/01/01
-- (a) = 1 -- (a) = 1
--2019/01/01 --2019/01/01
@ -1346,8 +1346,8 @@ tests_Journal = tests "Journal" [
,transaction "2019/01/01" [ vpost' "a" (num 1) (balassert (num 2)) ] ,transaction "2019/01/01" [ vpost' "a" (num 1) (balassert (num 2)) ]
]} ]}
,test "same-day-2" $ do ,testCase "same-day-2" $ do
expectRight $ journalBalanceTransactions True $ assertRight $ journalBalanceTransactions True $
--2019/01/01 --2019/01/01
-- (a) 2 = 2 -- (a) 2 = 2
--2019/01/01 --2019/01/01
@ -1364,8 +1364,8 @@ tests_Journal = tests "Journal" [
,transaction "2019/01/01" [ post' "a" (num 0) (balassert (num 1)) ] ,transaction "2019/01/01" [ post' "a" (num 0) (balassert (num 1)) ]
]} ]}
,test "out-of-order" $ do ,testCase "out-of-order" $ do
expectRight $ journalBalanceTransactions True $ assertRight $ journalBalanceTransactions True $
--2019/1/2 --2019/1/2
-- (a) 1 = 2 -- (a) 1 = 2
--2019/1/1 --2019/1/1
@ -1386,24 +1386,24 @@ tests_Journal = tests "Journal" [
-- 2019/09/26 -- 2019/09/26
-- (a) 1000,000 -- (a) 1000,000
-- --
test "1091a" $ do testCase "1091a" $ do
commodityStylesFromAmounts [ commodityStylesFromAmounts [
nullamt{aquantity=1000, astyle=AmountStyle L False 3 (Just ',') Nothing} nullamt{aquantity=1000, astyle=AmountStyle L False 3 (Just ',') Nothing}
,nullamt{aquantity=1000, astyle=AmountStyle L False 2 (Just '.') (Just (DigitGroups ',' [3]))} ,nullamt{aquantity=1000, astyle=AmountStyle L False 2 (Just '.') (Just (DigitGroups ',' [3]))}
] ]
`is` @?=
-- The commodity style should have period as decimal mark -- The commodity style should have period as decimal mark
-- and comma as digit group mark. -- and comma as digit group mark.
Right (M.fromList [ Right (M.fromList [
("", AmountStyle L False 3 (Just '.') (Just (DigitGroups ',' [3]))) ("", AmountStyle L False 3 (Just '.') (Just (DigitGroups ',' [3])))
]) ])
-- same journal, entries in reverse order -- same journal, entries in reverse order
,test "1091b" $ do ,testCase "1091b" $ do
commodityStylesFromAmounts [ commodityStylesFromAmounts [
nullamt{aquantity=1000, astyle=AmountStyle L False 2 (Just '.') (Just (DigitGroups ',' [3]))} nullamt{aquantity=1000, astyle=AmountStyle L False 2 (Just '.') (Just (DigitGroups ',' [3]))}
,nullamt{aquantity=1000, astyle=AmountStyle L False 3 (Just ',') Nothing} ,nullamt{aquantity=1000, astyle=AmountStyle L False 3 (Just ',') Nothing}
] ]
`is` @?=
-- The commodity style should have period as decimal mark -- The commodity style should have period as decimal mark
-- and comma as digit group mark. -- and comma as digit group mark.
Right (M.fromList [ Right (M.fromList [

15
hledger-lib/Hledger/Data/Ledger.hs
View File

@ -109,12 +109,9 @@ ledgerCommodities = M.keys . jinferredcommodities . ljournal
-- tests -- tests
tests_Ledger = tests_Ledger =
tests tests "Ledger" [
"Ledger" testCase "ledgerFromJournal" $ do
[ tests length (ledgerPostings $ ledgerFromJournal Any nulljournal) @?= 0
"ledgerFromJournal" length (ledgerPostings $ ledgerFromJournal Any samplejournal) @?= 13
[ length (ledgerPostings $ ledgerFromJournal Any nulljournal) `is` 0 length (ledgerPostings $ ledgerFromJournal (Depth 2) samplejournal) @?= 7
, length (ledgerPostings $ ledgerFromJournal Any samplejournal) `is` 13 ]
, length (ledgerPostings $ ledgerFromJournal (Depth 2) samplejournal) `is` 7
]
]

52
hledger-lib/Hledger/Data/Posting.hs
View File

@ -392,40 +392,34 @@ commentAddTagNextLine cmt (t,v) =
tests_Posting = tests "Posting" [ tests_Posting = tests "Posting" [
tests "accountNamePostingType" [ testCase "accountNamePostingType" $ do
accountNamePostingType "a" `is` RegularPosting accountNamePostingType "a" @?= RegularPosting
,accountNamePostingType "(a)" `is` VirtualPosting accountNamePostingType "(a)" @?= VirtualPosting
,accountNamePostingType "[a]" `is` BalancedVirtualPosting accountNamePostingType "[a]" @?= BalancedVirtualPosting
]
,tests "accountNameWithoutPostingType" [ ,testCase "accountNameWithoutPostingType" $ do
accountNameWithoutPostingType "(a)" `is` "a" accountNameWithoutPostingType "(a)" @?= "a"
]
,tests "accountNameWithPostingType" [ ,testCase "accountNameWithPostingType" $ do
accountNameWithPostingType VirtualPosting "[a]" `is` "(a)" accountNameWithPostingType VirtualPosting "[a]" @?= "(a)"
]
,tests "joinAccountNames" [ ,testCase "joinAccountNames" $ do
"a" `joinAccountNames` "b:c" `is` "a:b:c" "a" `joinAccountNames` "b:c" @?= "a:b:c"
,"a" `joinAccountNames` "(b:c)" `is` "(a:b:c)" "a" `joinAccountNames` "(b:c)" @?= "(a:b:c)"
,"[a]" `joinAccountNames` "(b:c)" `is` "[a:b:c]" "[a]" `joinAccountNames` "(b:c)" @?= "[a:b:c]"
,"" `joinAccountNames` "a" `is` "a" "" `joinAccountNames` "a" @?= "a"
]
,tests "concatAccountNames" [ ,testCase "concatAccountNames" $ do
concatAccountNames [] `is` "" concatAccountNames [] @?= ""
,concatAccountNames ["a","(b)","[c:d]"] `is` "(a:b:c:d)" concatAccountNames ["a","(b)","[c:d]"] @?= "(a:b:c:d)"
]
,tests "commentAddTag" [ ,testCase "commentAddTag" $ do
commentAddTag "" ("a","") `is` "a: " commentAddTag "" ("a","") @?= "a: "
,commentAddTag "[1/2]" ("a","") `is` "[1/2], a: " commentAddTag "[1/2]" ("a","") @?= "[1/2], a: "
]
,testCase "commentAddTagNextLine" $ do
commentAddTagNextLine "" ("a","") @?= "\na: "
commentAddTagNextLine "[1/2]" ("a","") @?= "[1/2]\na: "
,tests "commentAddTagNextLine" [
commentAddTagNextLine "" ("a","") `is` "\na: "
,commentAddTagNextLine "[1/2]" ("a","") `is` "[1/2]\na: "
]
] ]

26
hledger-lib/Hledger/Data/StringFormat.hs
View File

@ -137,7 +137,7 @@ fieldp = do
---------------------------------------------------------------------- ----------------------------------------------------------------------
formatStringTester fs value expected = actual `is` expected formatStringTester fs value expected = actual @?= expected
where where
actual = case fs of actual = case fs of
FormatLiteral l -> formatString False Nothing Nothing l FormatLiteral l -> formatString False Nothing Nothing l
@ -145,20 +145,18 @@ formatStringTester fs value expected = actual `is` expected
tests_StringFormat = tests "StringFormat" [ tests_StringFormat = tests "StringFormat" [
tests "formatStringHelper" [ testCase "formatStringHelper" $ do
formatStringTester (FormatLiteral " ") "" " " formatStringTester (FormatLiteral " ") "" " "
, formatStringTester (FormatField False Nothing Nothing DescriptionField) "description" "description" formatStringTester (FormatField False Nothing Nothing DescriptionField) "description" "description"
, formatStringTester (FormatField False (Just 20) Nothing DescriptionField) "description" " description" formatStringTester (FormatField False (Just 20) Nothing DescriptionField) "description" " description"
, formatStringTester (FormatField False Nothing (Just 20) DescriptionField) "description" "description" formatStringTester (FormatField False Nothing (Just 20) DescriptionField) "description" "description"
, formatStringTester (FormatField True Nothing (Just 20) DescriptionField) "description" "description" formatStringTester (FormatField True Nothing (Just 20) DescriptionField) "description" "description"
, formatStringTester (FormatField True (Just 20) Nothing DescriptionField) "description" "description " formatStringTester (FormatField True (Just 20) Nothing DescriptionField) "description" "description "
, formatStringTester (FormatField True (Just 20) (Just 20) DescriptionField) "description" "description " formatStringTester (FormatField True (Just 20) (Just 20) DescriptionField) "description" "description "
, formatStringTester (FormatField True Nothing (Just 3) DescriptionField) "description" "des" formatStringTester (FormatField True Nothing (Just 3) DescriptionField) "description" "des"
]
,tests "parseStringFormat" $ ,let s `gives` expected = testCase s $ parseStringFormat s @?= Right expected
let s `gives` expected = test s $ parseStringFormat s `is` Right expected in tests "parseStringFormat" [
in [
"" `gives` (defaultStringFormatStyle []) "" `gives` (defaultStringFormatStyle [])
, "D" `gives` (defaultStringFormatStyle [FormatLiteral "D"]) , "D" `gives` (defaultStringFormatStyle [FormatLiteral "D"])
, "%(date)" `gives` (defaultStringFormatStyle [FormatField False Nothing Nothing DescriptionField]) , "%(date)" `gives` (defaultStringFormatStyle [FormatField False Nothing Nothing DescriptionField])
@ -176,6 +174,6 @@ tests_StringFormat = tests "StringFormat" [
,FormatLiteral " " ,FormatLiteral " "
,FormatField False Nothing (Just 10) TotalField ,FormatField False Nothing (Just 10) TotalField
]) ])
, test "newline not parsed" $ expectLeft $ parseStringFormat "\n" , testCase "newline not parsed" $ assertLeft $ parseStringFormat "\n"
] ]
] ]

176
hledger-lib/Hledger/Data/Transaction.hs
View File

@ -559,12 +559,12 @@ transactionToCost styles t@Transaction{tpostings=ps} = t{tpostings=map (postingT
-- tests -- tests
tests_Transaction = tests_Transaction =
tests tests "Transaction" [
"Transaction"
[ tests tests "postingAsLines" [
"postingAsLines" testCase "null posting" $ postingAsLines False False [posting] posting @?= [""]
[ postingAsLines False False [posting] posting `is` [""] , testCase "non-null posting" $
, let p = let p =
posting posting
{ pstatus = Cleared { pstatus = Cleared
, paccount = "a" , paccount = "a"
@ -573,7 +573,7 @@ tests_Transaction =
, ptype = RegularPosting , ptype = RegularPosting
, ptags = [("ptag1", "val1"), ("ptag2", "val2")] , ptags = [("ptag1", "val1"), ("ptag2", "val2")]
} }
in postingAsLines False False [p] p `is` in postingAsLines False False [p] p @?=
[ " * a $1.00 ; pcomment1" [ " * a $1.00 ; pcomment1"
, " ; pcomment2" , " ; pcomment2"
, " ; tag3: val3 " , " ; tag3: val3 "
@ -582,77 +582,61 @@ tests_Transaction =
, " ; tag3: val3 " , " ; tag3: val3 "
] ]
] ]
-- postingsAsLines
-- one implicit amount , let
, let timp = nulltransaction {tpostings = ["a" `post` usd 1, "b" `post` missingamt]} -- one implicit amount
-- explicit amounts, balanced timp = nulltransaction {tpostings = ["a" `post` usd 1, "b" `post` missingamt]}
texp = nulltransaction {tpostings = ["a" `post` usd 1, "b" `post` usd (-1)]} -- explicit amounts, balanced
-- explicit amount, only one posting texp = nulltransaction {tpostings = ["a" `post` usd 1, "b" `post` usd (-1)]}
texp1 = nulltransaction {tpostings = ["(a)" `post` usd 1]} -- explicit amount, only one posting
-- explicit amounts, two commodities, explicit balancing price texp1 = nulltransaction {tpostings = ["(a)" `post` usd 1]}
texp2 = nulltransaction {tpostings = ["a" `post` usd 1, "b" `post` (hrs (-1) `at` usd 1)]} -- explicit amounts, two commodities, explicit balancing price
-- explicit amounts, two commodities, implicit balancing price texp2 = nulltransaction {tpostings = ["a" `post` usd 1, "b" `post` (hrs (-1) `at` usd 1)]}
texp2b = nulltransaction {tpostings = ["a" `post` usd 1, "b" `post` hrs (-1)]} -- explicit amounts, two commodities, implicit balancing price
-- one missing amount, not the last one texp2b = nulltransaction {tpostings = ["a" `post` usd 1, "b" `post` hrs (-1)]}
t3 = nulltransaction {tpostings = ["a" `post` usd 1, "b" `post` missingamt, "c" `post` usd (-1)]} -- one missing amount, not the last one
-- unbalanced amounts when precision is limited (#931) t3 = nulltransaction {tpostings = ["a" `post` usd 1, "b" `post` missingamt, "c" `post` usd (-1)]}
-- t4 = nulltransaction {tpostings = ["a" `post` usd (-0.01), "b" `post` usd (0.005), "c" `post` usd (0.005)]} -- unbalanced amounts when precision is limited (#931)
in tests -- t4 = nulltransaction {tpostings = ["a" `post` usd (-0.01), "b" `post` usd (0.005), "c" `post` usd (0.005)]}
"postingsAsLines" in tests "postingsAsLines" [
[ test "null-transaction" $ testCase "null-transaction" $ postingsAsLines False (tpostings nulltransaction) @?= []
let t = nulltransaction , testCase "implicit-amount" $ postingsAsLines False (tpostings timp) @?=
in postingsAsLines False (tpostings t) `is` []
, test "implicit-amount" $
let t = timp
in postingsAsLines False (tpostings t) `is`
[ " a $1.00" [ " a $1.00"
, " b" -- implicit amount remains implicit , " b" -- implicit amount remains implicit
] ]
, test "explicit-amounts" $ , testCase "explicit-amounts" $ postingsAsLines False (tpostings texp) @?=
let t = texp
in postingsAsLines False (tpostings t) `is`
[ " a $1.00" [ " a $1.00"
, " b $-1.00" , " b $-1.00"
] ]
, test "one-explicit-amount" $ , testCase "one-explicit-amount" $ postingsAsLines False (tpostings texp1) @?=
let t = texp1
in postingsAsLines False (tpostings t) `is`
[ " (a) $1.00" [ " (a) $1.00"
] ]
, test "explicit-amounts-two-commodities" $ , testCase "explicit-amounts-two-commodities" $ postingsAsLines False (tpostings texp2) @?=
let t = texp2
in postingsAsLines False (tpostings t) `is`
[ " a $1.00" [ " a $1.00"
, " b -1.00h @ $1.00" , " b -1.00h @ $1.00"
] ]
, test "explicit-amounts-not-explicitly-balanced" $ , testCase "explicit-amounts-not-explicitly-balanced" $ postingsAsLines False (tpostings texp2b) @?=
let t = texp2b
in postingsAsLines False (tpostings t) `is`
[ " a $1.00" [ " a $1.00"
, " b -1.00h" , " b -1.00h"
] ]
, test "implicit-amount-not-last" $ , testCase "implicit-amount-not-last" $ postingsAsLines False (tpostings t3) @?=
let t = t3
in postingsAsLines False (tpostings t) `is`
[" a $1.00", " b", " c $-1.00"] [" a $1.00", " b", " c $-1.00"]
-- , _test "ensure-visibly-balanced" $ -- , _testCase "ensure-visibly-balanced" $
-- let t = t4 -- in postingsAsLines False (tpostings t4) @?=
-- in postingsAsLines False (tpostings t) `is`
-- [" a $-0.01", " b $0.005", " c $0.005"] -- [" a $-0.01", " b $0.005", " c $0.005"]
] ]
, tests
"inferBalancingAmount" , testCase "inferBalancingAmount" $ do
[ (fst <$> inferBalancingAmount M.empty nulltransaction) `is` Right nulltransaction (fst <$> inferBalancingAmount M.empty nulltransaction) @?= Right nulltransaction
, (fst <$> inferBalancingAmount M.empty nulltransaction{tpostings = ["a" `post` usd (-5), "b" `post` missingamt]}) `is` (fst <$> inferBalancingAmount M.empty nulltransaction{tpostings = ["a" `post` usd (-5), "b" `post` missingamt]}) @?=
Right nulltransaction{tpostings = ["a" `post` usd (-5), "b" `post` usd 5]} Right nulltransaction{tpostings = ["a" `post` usd (-5), "b" `post` usd 5]}
, (fst <$> inferBalancingAmount M.empty nulltransaction{tpostings = ["a" `post` usd (-5), "b" `post` (eur 3 @@ usd 4), "c" `post` missingamt]}) `is` (fst <$> inferBalancingAmount M.empty nulltransaction{tpostings = ["a" `post` usd (-5), "b" `post` (eur 3 @@ usd 4), "c" `post` missingamt]}) @?=
Right nulltransaction{tpostings = ["a" `post` usd (-5), "b" `post` (eur 3 @@ usd 4), "c" `post` usd 1]} Right nulltransaction{tpostings = ["a" `post` usd (-5), "b" `post` (eur 3 @@ usd 4), "c" `post` usd 1]}
]
, tests , tests "showTransaction" [
"showTransaction" testCase "null transaction" $ showTransaction nulltransaction @?= "0000/01/01\n\n"
[ showTransaction nulltransaction `is` "0000/01/01\n\n" , testCase "non-null transaction" $ showTransaction
, showTransaction
nulltransaction nulltransaction
{ tdate = parsedate "2012/05/14" { tdate = parsedate "2012/05/14"
, tdate2 = Just $ parsedate "2012/05/15" , tdate2 = Just $ parsedate "2012/05/15"
@ -671,7 +655,7 @@ tests_Transaction =
, ptags = [("ptag1", "val1"), ("ptag2", "val2")] , ptags = [("ptag1", "val1"), ("ptag2", "val2")]
} }
] ]
} `is` } @?=
unlines unlines
[ "2012/05/14=2012/05/15 (code) desc ; tcomment1" [ "2012/05/14=2012/05/15 (code) desc ; tcomment1"
, " ; tcomment2" , " ; tcomment2"
@ -681,7 +665,7 @@ tests_Transaction =
, " ; pcomment2" , " ; pcomment2"
, "" , ""
] ]
, test "show a balanced transaction" $ , testCase "show a balanced transaction" $
(let t = (let t =
Transaction Transaction
0 0
@ -697,14 +681,14 @@ tests_Transaction =
[ posting {paccount = "expenses:food:groceries", pamount = Mixed [usd 47.18], ptransaction = Just t} [ posting {paccount = "expenses:food:groceries", pamount = Mixed [usd 47.18], ptransaction = Just t}
, posting {paccount = "assets:checking", pamount = Mixed [usd (-47.18)], ptransaction = Just t} , posting {paccount = "assets:checking", pamount = Mixed [usd (-47.18)], ptransaction = Just t}
] ]
in showTransaction t) `is` in showTransaction t) @?=
(unlines (unlines
[ "2007/01/28 coopportunity" [ "2007/01/28 coopportunity"
, " expenses:food:groceries $47.18" , " expenses:food:groceries $47.18"
, " assets:checking $-47.18" , " assets:checking $-47.18"
, "" , ""
]) ])
, test "show an unbalanced transaction, should not elide" $ , testCase "show an unbalanced transaction, should not elide" $
(showTransaction (showTransaction
(txnTieKnot $ (txnTieKnot $
Transaction Transaction
@ -720,14 +704,14 @@ tests_Transaction =
[] []
[ posting {paccount = "expenses:food:groceries", pamount = Mixed [usd 47.18]} [ posting {paccount = "expenses:food:groceries", pamount = Mixed [usd 47.18]}
, posting {paccount = "assets:checking", pamount = Mixed [usd (-47.19)]} , posting {paccount = "assets:checking", pamount = Mixed [usd (-47.19)]}
])) `is` ])) @?=
(unlines (unlines
[ "2007/01/28 coopportunity" [ "2007/01/28 coopportunity"
, " expenses:food:groceries $47.18" , " expenses:food:groceries $47.18"
, " assets:checking $-47.19" , " assets:checking $-47.19"
, "" , ""
]) ])
, test "show a transaction with one posting and a missing amount" $ , testCase "show a transaction with one posting and a missing amount" $
(showTransaction (showTransaction
(txnTieKnot $ (txnTieKnot $
Transaction Transaction
@ -741,9 +725,9 @@ tests_Transaction =
"coopportunity" "coopportunity"
"" ""
[] []
[posting {paccount = "expenses:food:groceries", pamount = missingmixedamt}])) `is` [posting {paccount = "expenses:food:groceries", pamount = missingmixedamt}])) @?=
(unlines ["2007/01/28 coopportunity", " expenses:food:groceries", ""]) (unlines ["2007/01/28 coopportunity", " expenses:food:groceries", ""])
, test "show a transaction with a priced commodityless amount" $ , testCase "show a transaction with a priced commodityless amount" $
(showTransaction (showTransaction
(txnTieKnot $ (txnTieKnot $
Transaction Transaction
@ -759,13 +743,12 @@ tests_Transaction =
[] []
[ posting {paccount = "a", pamount = Mixed [num 1 `at` (usd 2 `withPrecision` 0)]} [ posting {paccount = "a", pamount = Mixed [num 1 `at` (usd 2 `withPrecision` 0)]}
, posting {paccount = "b", pamount = missingmixedamt} , posting {paccount = "b", pamount = missingmixedamt}
])) `is` ])) @?=
(unlines ["2010/01/01 x", " a 1 @ $2", " b", ""]) (unlines ["2010/01/01 x", " a 1 @ $2", " b", ""])
] ]
, tests , tests "balanceTransaction" [
"balanceTransaction" testCase "detect unbalanced entry, sign error" $
[ test "detect unbalanced entry, sign error" $ assertLeft
expectLeft
(balanceTransaction (balanceTransaction
Nothing Nothing
(Transaction (Transaction
@ -780,8 +763,8 @@ tests_Transaction =
"" ""
[] []
[posting {paccount = "a", pamount = Mixed [usd 1]}, posting {paccount = "b", pamount = Mixed [usd 1]}])) [posting {paccount = "a", pamount = Mixed [usd 1]}, posting {paccount = "b", pamount = Mixed [usd 1]}]))
, test "detect unbalanced entry, multiple missing amounts" $ ,testCase "detect unbalanced entry, multiple missing amounts" $
expectLeft $ assertLeft $
balanceTransaction balanceTransaction
Nothing Nothing
(Transaction (Transaction
@ -798,7 +781,7 @@ tests_Transaction =
[ posting {paccount = "a", pamount = missingmixedamt} [ posting {paccount = "a", pamount = missingmixedamt}
, posting {paccount = "b", pamount = missingmixedamt} , posting {paccount = "b", pamount = missingmixedamt}
]) ])
, test "one missing amount is inferred" $ ,testCase "one missing amount is inferred" $
(pamount . last . tpostings <$> (pamount . last . tpostings <$>
balanceTransaction balanceTransaction
Nothing Nothing
@ -813,9 +796,9 @@ tests_Transaction =
"" ""
"" ""
[] []
[posting {paccount = "a", pamount = Mixed [usd 1]}, posting {paccount = "b", pamount = missingmixedamt}])) `is` [posting {paccount = "a", pamount = Mixed [usd 1]}, posting {paccount = "b", pamount = missingmixedamt}])) @?=
Right (Mixed [usd (-1)]) Right (Mixed [usd (-1)])
, test "conversion price is inferred" $ ,testCase "conversion price is inferred" $
(pamount . head . tpostings <$> (pamount . head . tpostings <$>
balanceTransaction balanceTransaction
Nothing Nothing
@ -832,10 +815,10 @@ tests_Transaction =
[] []
[ posting {paccount = "a", pamount = Mixed [usd 1.35]} [ posting {paccount = "a", pamount = Mixed [usd 1.35]}
, posting {paccount = "b", pamount = Mixed [eur (-1)]} , posting {paccount = "b", pamount = Mixed [eur (-1)]}
])) `is` ])) @?=
Right (Mixed [usd 1.35 @@ (eur 1 `withPrecision` maxprecision)]) Right (Mixed [usd 1.35 @@ (eur 1 `withPrecision` maxprecision)])
, test "balanceTransaction balances based on cost if there are unit prices" $ ,testCase "balanceTransaction balances based on cost if there are unit prices" $
expectRight $ assertRight $
balanceTransaction balanceTransaction
Nothing Nothing
(Transaction (Transaction
@ -852,8 +835,8 @@ tests_Transaction =
[ posting {paccount = "a", pamount = Mixed [usd 1 `at` eur 2]} [ posting {paccount = "a", pamount = Mixed [usd 1 `at` eur 2]}
, posting {paccount = "a", pamount = Mixed [usd (-2) `at` eur 1]} , posting {paccount = "a", pamount = Mixed [usd (-2) `at` eur 1]}
]) ])
, test "balanceTransaction balances based on cost if there are total prices" $ ,testCase "balanceTransaction balances based on cost if there are total prices" $
expectRight $ assertRight $
balanceTransaction balanceTransaction
Nothing Nothing
(Transaction (Transaction
@ -871,10 +854,9 @@ tests_Transaction =
, posting {paccount = "a", pamount = Mixed [usd (-2) @@ eur 1]} , posting {paccount = "a", pamount = Mixed [usd (-2) @@ eur 1]}
]) ])
] ]
, tests , tests "isTransactionBalanced" [
"isTransactionBalanced" testCase "detect balanced" $
[ test "detect balanced" $ assertBool "" $
expect $
isTransactionBalanced Nothing $ isTransactionBalanced Nothing $
Transaction Transaction
0 0
@ -890,8 +872,8 @@ tests_Transaction =
[ posting {paccount = "b", pamount = Mixed [usd 1.00]} [ posting {paccount = "b", pamount = Mixed [usd 1.00]}
, posting {paccount = "c", pamount = Mixed [usd (-1.00)]} , posting {paccount = "c", pamount = Mixed [usd (-1.00)]}
] ]
, test "detect unbalanced" $ ,testCase "detect unbalanced" $
expect $ assertBool "" $
not $ not $
isTransactionBalanced Nothing $ isTransactionBalanced Nothing $
Transaction Transaction
@ -908,8 +890,8 @@ tests_Transaction =
[ posting {paccount = "b", pamount = Mixed [usd 1.00]} [ posting {paccount = "b", pamount = Mixed [usd 1.00]}
, posting {paccount = "c", pamount = Mixed [usd (-1.01)]} , posting {paccount = "c", pamount = Mixed [usd (-1.01)]}
] ]
, test "detect unbalanced, one posting" $ ,testCase "detect unbalanced, one posting" $
expect $ assertBool "" $
not $ not $
isTransactionBalanced Nothing $ isTransactionBalanced Nothing $
Transaction Transaction
@ -924,8 +906,8 @@ tests_Transaction =
"" ""
[] []
[posting {paccount = "b", pamount = Mixed [usd 1.00]}] [posting {paccount = "b", pamount = Mixed [usd 1.00]}]
, test "one zero posting is considered balanced for now" $ ,testCase "one zero posting is considered balanced for now" $
expect $ assertBool "" $
isTransactionBalanced Nothing $ isTransactionBalanced Nothing $
Transaction Transaction
0 0
@ -939,8 +921,8 @@ tests_Transaction =
"" ""
[] []
[posting {paccount = "b", pamount = Mixed [usd 0]}] [posting {paccount = "b", pamount = Mixed [usd 0]}]
, test "virtual postings don't need to balance" $ ,testCase "virtual postings don't need to balance" $
expect $ assertBool "" $
isTransactionBalanced Nothing $ isTransactionBalanced Nothing $
Transaction Transaction
0 0
@ -957,8 +939,8 @@ tests_Transaction =
, posting {paccount = "c", pamount = Mixed [usd (-1.00)]} , posting {paccount = "c", pamount = Mixed [usd (-1.00)]}
, posting {paccount = "d", pamount = Mixed [usd 100], ptype = VirtualPosting} , posting {paccount = "d", pamount = Mixed [usd 100], ptype = VirtualPosting}
] ]
, test "balanced virtual postings need to balance among themselves" $ ,testCase "balanced virtual postings need to balance among themselves" $
expect $ assertBool "" $
not $ not $
isTransactionBalanced Nothing $ isTransactionBalanced Nothing $
Transaction Transaction
@ -976,8 +958,8 @@ tests_Transaction =
, posting {paccount = "c", pamount = Mixed [usd (-1.00)]} , posting {paccount = "c", pamount = Mixed [usd (-1.00)]}
, posting {paccount = "d", pamount = Mixed [usd 100], ptype = BalancedVirtualPosting} , posting {paccount = "d", pamount = Mixed [usd 100], ptype = BalancedVirtualPosting}
] ]
, test "balanced virtual postings need to balance among themselves (2)" $ ,testCase "balanced virtual postings need to balance among themselves (2)" $
expect $ assertBool "" $
isTransactionBalanced Nothing $ isTransactionBalanced Nothing $
Transaction Transaction
0 0

20
hledger-lib/Hledger/Data/Valuation.hs
View File

@ -48,11 +48,6 @@ import Hledger.Data.Amount
import Hledger.Data.Dates (parsedate) import Hledger.Data.Dates (parsedate)
tests_Valuation = tests "Valuation" [
tests_priceLookup
]
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
-- Types -- Types
@ -278,12 +273,11 @@ tests_priceLookup =
,p "2001/01/01" "A" 11 "B" ,p "2001/01/01" "A" 11 "B"
] ]
pricesatdate = pricesAtDate ps1 pricesatdate = pricesAtDate ps1
in tests "priceLookup" [ in testCase "priceLookup" $ do
priceLookup pricesatdate (d "1999/01/01") "A" Nothing `is` Nothing priceLookup pricesatdate (d "1999/01/01") "A" Nothing @?= Nothing
,priceLookup pricesatdate (d "2000/01/01") "A" Nothing `is` Just ("B",10) priceLookup pricesatdate (d "2000/01/01") "A" Nothing @?= Just ("B",10)
,priceLookup pricesatdate (d "2000/01/01") "B" (Just "A") `is` Just ("A",0.1) priceLookup pricesatdate (d "2000/01/01") "B" (Just "A") @?= Just ("A",0.1)
,priceLookup pricesatdate (d "2000/01/01") "A" (Just "E") `is` Just ("E",500) priceLookup pricesatdate (d "2000/01/01") "A" (Just "E") @?= Just ("E",500)
]
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
-- Building the price graph (network of commodity conversions) on a given day. -- Building the price graph (network of commodity conversions) on a given day.
@ -365,3 +359,7 @@ nodesEdgeLabel :: Ord b => Gr a b -> (Node, Node) -> Maybe b
nodesEdgeLabel g (from,to) = headMay $ sort [l | (_,t,l) <- out g from, t==to] nodesEdgeLabel g (from,to) = headMay $ sort [l | (_,t,l) <- out g from, t==to]
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
tests_Valuation = tests "Valuation" [
tests_priceLookup
]

218
hledger-lib/Hledger/Query.hs
View File

@ -653,130 +653,122 @@ matchesPriceDirective _ _ = True
-- tests -- tests
tests_Query = tests "Query" [ tests_Query = tests "Query" [
tests "simplifyQuery" [ testCase "simplifyQuery" $ do
(simplifyQuery $ Or [Acct "a"]) @?= (Acct "a")
(simplifyQuery $ Or [Any,None]) @?= (Any)
(simplifyQuery $ And [Any,None]) @?= (None)
(simplifyQuery $ And [Any,Any]) @?= (Any)
(simplifyQuery $ And [Acct "b",Any]) @?= (Acct "b")
(simplifyQuery $ And [Any,And [Date (DateSpan Nothing Nothing)]]) @?= (Any)
(simplifyQuery $ And [Date (DateSpan Nothing (Just $ parsedate "2013-01-01")), Date (DateSpan (Just $ parsedate "2012-01-01") Nothing)])
@?= (Date (DateSpan (Just $ parsedate "2012-01-01") (Just $ parsedate "2013-01-01")))
(simplifyQuery $ And [Or [],Or [Desc "b b"]]) @?= (Desc "b b")
(simplifyQuery $ Or [Acct "a"]) `is` (Acct "a") ,testCase "parseQuery" $ do
,(simplifyQuery $ Or [Any,None]) `is` (Any) (parseQuery nulldate "acct:'expenses:autres d\233penses' desc:b") @?= (And [Acct "expenses:autres d\233penses", Desc "b"], [])
,(simplifyQuery $ And [Any,None]) `is` (None) parseQuery nulldate "inacct:a desc:\"b b\"" @?= (Desc "b b", [QueryOptInAcct "a"])
,(simplifyQuery $ And [Any,Any]) `is` (Any) parseQuery nulldate "inacct:a inacct:b" @?= (Any, [QueryOptInAcct "a", QueryOptInAcct "b"])
,(simplifyQuery $ And [Acct "b",Any]) `is` (Acct "b") parseQuery nulldate "desc:'x x'" @?= (Desc "x x", [])
,(simplifyQuery $ And [Any,And [Date (DateSpan Nothing Nothing)]]) `is` (Any) parseQuery nulldate "'a a' 'b" @?= (Or [Acct "a a",Acct "'b"], [])
,(simplifyQuery $ And [Date (DateSpan Nothing (Just $ parsedate "2013-01-01")), Date (DateSpan (Just $ parsedate "2012-01-01") Nothing)]) parseQuery nulldate "\"" @?= (Acct "\"", [])
`is` (Date (DateSpan (Just $ parsedate "2012-01-01") (Just $ parsedate "2013-01-01")))
,(simplifyQuery $ And [Or [],Or [Desc "b b"]]) `is` (Desc "b b")
]
,tests "parseQuery" [ ,testCase "words''" $ do
(parseQuery nulldate "acct:'expenses:autres d\233penses' desc:b") `is` (And [Acct "expenses:autres d\233penses", Desc "b"], []) (words'' [] "a b") @?= ["a","b"]
,parseQuery nulldate "inacct:a desc:\"b b\"" `is` (Desc "b b", [QueryOptInAcct "a"]) (words'' [] "'a b'") @?= ["a b"]
,parseQuery nulldate "inacct:a inacct:b" `is` (Any, [QueryOptInAcct "a", QueryOptInAcct "b"]) (words'' [] "not:a b") @?= ["not:a","b"]
,parseQuery nulldate "desc:'x x'" `is` (Desc "x x", []) (words'' [] "not:'a b'") @?= ["not:a b"]
,parseQuery nulldate "'a a' 'b" `is` (Or [Acct "a a",Acct "'b"], []) (words'' [] "'not:a b'") @?= ["not:a b"]
,parseQuery nulldate "\"" `is` (Acct "\"", []) (words'' ["desc:"] "not:desc:'a b'") @?= ["not:desc:a b"]
] (words'' prefixes "\"acct:expenses:autres d\233penses\"") @?= ["acct:expenses:autres d\233penses"]
(words'' prefixes "\"") @?= ["\""]
,tests "words''" [ ,testCase "filterQuery" $ do
(words'' [] "a b") `is` ["a","b"] filterQuery queryIsDepth Any @?= Any
, (words'' [] "'a b'") `is` ["a b"] filterQuery queryIsDepth (Depth 1) @?= Depth 1
, (words'' [] "not:a b") `is` ["not:a","b"] filterQuery (not.queryIsDepth) (And [And [StatusQ Cleared,Depth 1]]) @?= StatusQ Cleared
, (words'' [] "not:'a b'") `is` ["not:a b"] filterQuery queryIsDepth (And [Date nulldatespan, Not (Or [Any, Depth 1])]) @?= Any -- XXX unclear
, (words'' [] "'not:a b'") `is` ["not:a b"]
, (words'' ["desc:"] "not:desc:'a b'") `is` ["not:desc:a b"]
, (words'' prefixes "\"acct:expenses:autres d\233penses\"") `is` ["acct:expenses:autres d\233penses"]
, (words'' prefixes "\"") `is` ["\""]
]
,tests "filterQuery" [ ,testCase "parseQueryTerm" $ do
filterQuery queryIsDepth Any `is` Any parseQueryTerm nulldate "a" @?= (Left $ Acct "a")
,filterQuery queryIsDepth (Depth 1) `is` Depth 1 parseQueryTerm nulldate "acct:expenses:autres d\233penses" @?= (Left $ Acct "expenses:autres d\233penses")
,filterQuery (not.queryIsDepth) (And [And [StatusQ Cleared,Depth 1]]) `is` StatusQ Cleared parseQueryTerm nulldate "not:desc:a b" @?= (Left $ Not $ Desc "a b")
,filterQuery queryIsDepth (And [Date nulldatespan, Not (Or [Any, Depth 1])]) `is` Any -- XXX unclear parseQueryTerm nulldate "status:1" @?= (Left $ StatusQ Cleared)
] parseQueryTerm nulldate "status:*" @?= (Left $ StatusQ Cleared)
parseQueryTerm nulldate "status:!" @?= (Left $ StatusQ Pending)
parseQueryTerm nulldate "status:0" @?= (Left $ StatusQ Unmarked)
parseQueryTerm nulldate "status:" @?= (Left $ StatusQ Unmarked)
parseQueryTerm nulldate "payee:x" @?= (Left $ Tag "payee" (Just "x"))
parseQueryTerm nulldate "note:x" @?= (Left $ Tag "note" (Just "x"))
parseQueryTerm nulldate "real:1" @?= (Left $ Real True)
parseQueryTerm nulldate "date:2008" @?= (Left $ Date $ DateSpan (Just $ parsedate "2008/01/01") (Just $ parsedate "2009/01/01"))
parseQueryTerm nulldate "date:from 2012/5/17" @?= (Left $ Date $ DateSpan (Just $ parsedate "2012/05/17") Nothing)
parseQueryTerm nulldate "date:20180101-201804" @?= (Left $ Date $ DateSpan (Just $ parsedate "2018/01/01") (Just $ parsedate "2018/04/01"))
parseQueryTerm nulldate "inacct:a" @?= (Right $ QueryOptInAcct "a")
parseQueryTerm nulldate "tag:a" @?= (Left $ Tag "a" Nothing)
parseQueryTerm nulldate "tag:a=some value" @?= (Left $ Tag "a" (Just "some value"))
parseQueryTerm nulldate "amt:<0" @?= (Left $ Amt Lt 0)
parseQueryTerm nulldate "amt:>10000.10" @?= (Left $ Amt AbsGt 10000.1)
,tests "parseQueryTerm" [ ,testCase "parseAmountQueryTerm" $ do
parseQueryTerm nulldate "a" `is` (Left $ Acct "a") parseAmountQueryTerm "<0" @?= (Lt,0) -- special case for convenience, since AbsLt 0 would be always false
,parseQueryTerm nulldate "acct:expenses:autres d\233penses" `is` (Left $ Acct "expenses:autres d\233penses") parseAmountQueryTerm ">0" @?= (Gt,0) -- special case for convenience and consistency with above
,parseQueryTerm nulldate "not:desc:a b" `is` (Left $ Not $ Desc "a b") parseAmountQueryTerm ">10000.10" @?= (AbsGt,10000.1)
,parseQueryTerm nulldate "status:1" `is` (Left $ StatusQ Cleared) parseAmountQueryTerm "=0.23" @?= (AbsEq,0.23)
,parseQueryTerm nulldate "status:*" `is` (Left $ StatusQ Cleared) parseAmountQueryTerm "0.23" @?= (AbsEq,0.23)
,parseQueryTerm nulldate "status:!" `is` (Left $ StatusQ Pending) parseAmountQueryTerm "<=+0.23" @?= (LtEq,0.23)
,parseQueryTerm nulldate "status:0" `is` (Left $ StatusQ Unmarked) parseAmountQueryTerm "-0.23" @?= (Eq,(-0.23))
,parseQueryTerm nulldate "status:" `is` (Left $ StatusQ Unmarked) -- ,_test "number beginning with decimal mark" $ parseAmountQueryTerm "=.23" @?= (AbsEq,0.23) -- XXX
,parseQueryTerm nulldate "payee:x" `is` (Left $ Tag "payee" (Just "x"))
,parseQueryTerm nulldate "note:x" `is` (Left $ Tag "note" (Just "x"))
,parseQueryTerm nulldate "real:1" `is` (Left $ Real True)
,parseQueryTerm nulldate "date:2008" `is` (Left $ Date $ DateSpan (Just $ parsedate "2008/01/01") (Just $ parsedate "2009/01/01"))
,parseQueryTerm nulldate "date:from 2012/5/17" `is` (Left $ Date $ DateSpan (Just $ parsedate "2012/05/17") Nothing)
,parseQueryTerm nulldate "date:20180101-201804" `is` (Left $ Date $ DateSpan (Just $ parsedate "2018/01/01") (Just $ parsedate "2018/04/01"))
,parseQueryTerm nulldate "inacct:a" `is` (Right $ QueryOptInAcct "a")
,parseQueryTerm nulldate "tag:a" `is` (Left $ Tag "a" Nothing)
,parseQueryTerm nulldate "tag:a=some value" `is` (Left $ Tag "a" (Just "some value"))
,parseQueryTerm nulldate "amt:<0" `is` (Left $ Amt Lt 0)
,parseQueryTerm nulldate "amt:>10000.10" `is` (Left $ Amt AbsGt 10000.1)
]
,tests "parseAmountQueryTerm" [ ,testCase "matchesAccount" $ do
parseAmountQueryTerm "<0" `is` (Lt,0) -- special case for convenience, since AbsLt 0 would be always false assertBool "" $ (Acct "b:c") `matchesAccount` "a:bb:c:d"
,parseAmountQueryTerm ">0" `is` (Gt,0) -- special case for convenience and consistency with above assertBool "" $ not $ (Acct "^a:b") `matchesAccount` "c:a:b"
,parseAmountQueryTerm ">10000.10" `is` (AbsGt,10000.1) assertBool "" $ Depth 2 `matchesAccount` "a"
,parseAmountQueryTerm "=0.23" `is` (AbsEq,0.23) assertBool "" $ Depth 2 `matchesAccount` "a:b"
,parseAmountQueryTerm "0.23" `is` (AbsEq,0.23) assertBool "" $ not $ Depth 2 `matchesAccount` "a:b:c"
,parseAmountQueryTerm "<=+0.23" `is` (LtEq,0.23) assertBool "" $ Date nulldatespan `matchesAccount` "a"
,parseAmountQueryTerm "-0.23" `is` (Eq,(-0.23)) assertBool "" $ Date2 nulldatespan `matchesAccount` "a"
-- ,_test "number beginning with decimal mark" $ parseAmountQueryTerm "=.23" `is` (AbsEq,0.23) -- XXX assertBool "" $ not $ (Tag "a" Nothing) `matchesAccount` "a"
]
,tests "matchesAccount" [
expect $ (Acct "b:c") `matchesAccount` "a:bb:c:d"
,expect $ not $ (Acct "^a:b") `matchesAccount` "c:a:b"
,expect $ Depth 2 `matchesAccount` "a"
,expect $ Depth 2 `matchesAccount` "a:b"
,expect $ not $ Depth 2 `matchesAccount` "a:b:c"
,expect $ Date nulldatespan `matchesAccount` "a"
,expect $ Date2 nulldatespan `matchesAccount` "a"
,expect $ not $ (Tag "a" Nothing) `matchesAccount` "a"
]
,tests "matchesPosting" [ ,tests "matchesPosting" [
test "positive match on cleared posting status" $ testCase "positive match on cleared posting status" $
expect $ (StatusQ Cleared) `matchesPosting` nullposting{pstatus=Cleared} assertBool "" $ (StatusQ Cleared) `matchesPosting` nullposting{pstatus=Cleared}
,test "negative match on cleared posting status" $ ,testCase "negative match on cleared posting status" $
expect $ not $ (Not $ StatusQ Cleared) `matchesPosting` nullposting{pstatus=Cleared} assertBool "" $ not $ (Not $ StatusQ Cleared) `matchesPosting` nullposting{pstatus=Cleared}
,test "positive match on unmarked posting status" $ ,testCase "positive match on unmarked posting status" $
expect $ (StatusQ Unmarked) `matchesPosting` nullposting{pstatus=Unmarked} assertBool "" $ (StatusQ Unmarked) `matchesPosting` nullposting{pstatus=Unmarked}
,test "negative match on unmarked posting status" $ ,testCase "negative match on unmarked posting status" $
expect $ not $ (Not $ StatusQ Unmarked) `matchesPosting` nullposting{pstatus=Unmarked} assertBool "" $ not $ (Not $ StatusQ Unmarked) `matchesPosting` nullposting{pstatus=Unmarked}
,test "positive match on true posting status acquired from transaction" $ ,testCase "positive match on true posting status acquired from transaction" $
expect $ (StatusQ Cleared) `matchesPosting` nullposting{pstatus=Unmarked,ptransaction=Just nulltransaction{tstatus=Cleared}} assertBool "" $ (StatusQ Cleared) `matchesPosting` nullposting{pstatus=Unmarked,ptransaction=Just nulltransaction{tstatus=Cleared}}
,test "real:1 on real posting" $ expect $ (Real True) `matchesPosting` nullposting{ptype=RegularPosting} ,testCase "real:1 on real posting" $ assertBool "" $ (Real True) `matchesPosting` nullposting{ptype=RegularPosting}
,test "real:1 on virtual posting fails" $ expect $ not $ (Real True) `matchesPosting` nullposting{ptype=VirtualPosting} ,testCase "real:1 on virtual posting fails" $ assertBool "" $ not $ (Real True) `matchesPosting` nullposting{ptype=VirtualPosting}
,test "real:1 on balanced virtual posting fails" $ expect $ not $ (Real True) `matchesPosting` nullposting{ptype=BalancedVirtualPosting} ,testCase "real:1 on balanced virtual posting fails" $ assertBool "" $ not $ (Real True) `matchesPosting` nullposting{ptype=BalancedVirtualPosting}
,test "a" $ expect $ (Acct "'b") `matchesPosting` nullposting{paccount="'b"} ,testCase "acct:" $ assertBool "" $ (Acct "'b") `matchesPosting` nullposting{paccount="'b"}
,test "b" $ expect $ not $ (Tag "a" (Just "r$")) `matchesPosting` nullposting ,testCase "tag:" $ do
,test "c" $ expect $ (Tag "foo" Nothing) `matchesPosting` nullposting{ptags=[("foo","")]} assertBool "" $ not $ (Tag "a" (Just "r$")) `matchesPosting` nullposting
,test "d" $ expect $ (Tag "foo" Nothing) `matchesPosting` nullposting{ptags=[("foo","baz")]} assertBool "" $ (Tag "foo" Nothing) `matchesPosting` nullposting{ptags=[("foo","")]}
,test "e" $ expect $ (Tag "foo" (Just "a")) `matchesPosting` nullposting{ptags=[("foo","bar")]} assertBool "" $ (Tag "foo" Nothing) `matchesPosting` nullposting{ptags=[("foo","baz")]}
,test "f" $ expect $ not $ (Tag "foo" (Just "a$")) `matchesPosting` nullposting{ptags=[("foo","bar")]} assertBool "" $ (Tag "foo" (Just "a")) `matchesPosting` nullposting{ptags=[("foo","bar")]}
,test "g" $ expect $ not $ (Tag " foo " (Just "a")) `matchesPosting` nullposting{ptags=[("foo","bar")]} assertBool "" $ not $ (Tag "foo" (Just "a$")) `matchesPosting` nullposting{ptags=[("foo","bar")]}
,test "h" $ expect $ not $ (Tag "foo foo" (Just " ar ba ")) `matchesPosting` nullposting{ptags=[("foo foo","bar bar")]} assertBool "" $ not $ (Tag " foo " (Just "a")) `matchesPosting` nullposting{ptags=[("foo","bar")]}
-- a tag match on a posting also sees inherited tags assertBool "" $ not $ (Tag "foo foo" (Just " ar ba ")) `matchesPosting` nullposting{ptags=[("foo foo","bar bar")]}
,test "i" $ expect $ (Tag "txntag" Nothing) `matchesPosting` nullposting{ptransaction=Just nulltransaction{ttags=[("txntag","")]}} ,testCase "a tag match on a posting also sees inherited tags" $ assertBool "" $ (Tag "txntag" Nothing) `matchesPosting` nullposting{ptransaction=Just nulltransaction{ttags=[("txntag","")]}}
,test "j" $ expect $ not $ (Sym "$") `matchesPosting` nullposting{pamount=Mixed [usd 1]} -- becomes "^$$", ie testing for null symbol ,testCase "cur:" $ do
,test "k" $ expect $ (Sym "\\$") `matchesPosting` nullposting{pamount=Mixed [usd 1]} -- have to quote $ for regexpr assertBool "" $ not $ (Sym "$") `matchesPosting` nullposting{pamount=Mixed [usd 1]} -- becomes "^$$", ie testing for null symbol
,test "l" $ expect $ (Sym "shekels") `matchesPosting` nullposting{pamount=Mixed [nullamt{acommodity="shekels"}]} assertBool "" $ (Sym "\\$") `matchesPosting` nullposting{pamount=Mixed [usd 1]} -- have to quote $ for regexpr
,test "m" $ expect $ not $ (Sym "shek") `matchesPosting` nullposting{pamount=Mixed [nullamt{acommodity="shekels"}]} assertBool "" $ (Sym "shekels") `matchesPosting` nullposting{pamount=Mixed [nullamt{acommodity="shekels"}]}
assertBool "" $ not $ (Sym "shek") `matchesPosting` nullposting{pamount=Mixed [nullamt{acommodity="shekels"}]}
] ]
,tests "matchesTransaction" [ ,testCase "matchesTransaction" $ do
expect $ Any `matchesTransaction` nulltransaction assertBool "" $ Any `matchesTransaction` nulltransaction
,expect $ not $ (Desc "x x") `matchesTransaction` nulltransaction{tdescription="x"} assertBool "" $ not $ (Desc "x x") `matchesTransaction` nulltransaction{tdescription="x"}
,expect $ (Desc "x x") `matchesTransaction` nulltransaction{tdescription="x x"} assertBool "" $ (Desc "x x") `matchesTransaction` nulltransaction{tdescription="x x"}
-- see posting for more tag tests -- see posting for more tag tests
,expect $ (Tag "foo" (Just "a")) `matchesTransaction` nulltransaction{ttags=[("foo","bar")]} assertBool "" $ (Tag "foo" (Just "a")) `matchesTransaction` nulltransaction{ttags=[("foo","bar")]}
,expect $ (Tag "payee" (Just "payee")) `matchesTransaction` nulltransaction{tdescription="payee|note"} assertBool "" $ (Tag "payee" (Just "payee")) `matchesTransaction` nulltransaction{tdescription="payee|note"}
,expect $ (Tag "note" (Just "note")) `matchesTransaction` nulltransaction{tdescription="payee|note"} assertBool "" $ (Tag "note" (Just "note")) `matchesTransaction` nulltransaction{tdescription="payee|note"}
-- a tag match on a transaction also matches posting tags -- a tag match on a transaction also matches posting tags
,expect $ (Tag "postingtag" Nothing) `matchesTransaction` nulltransaction{tpostings=[nullposting{ptags=[("postingtag","")]}]} assertBool "" $ (Tag "postingtag" Nothing) `matchesTransaction` nulltransaction{tpostings=[nullposting{ptags=[("postingtag","")]}]}
]
] ]

57
hledger-lib/Hledger/Read/Common.hs
View File

@ -1308,14 +1308,14 @@ match' p = do
tests_Common = tests "Common" [ tests_Common = tests "Common" [
tests "amountp" [ tests "amountp" [
test "basic" $ expectParseEq amountp "$47.18" (usd 47.18) testCase "basic" $ assertParseEq amountp "$47.18" (usd 47.18)
,test "ends with decimal mark" $ expectParseEq amountp "$1." (usd 1 `withPrecision` 0) ,testCase "ends with decimal mark" $ assertParseEq amountp "$1." (usd 1 `withPrecision` 0)
,test "unit price" $ expectParseEq amountp "$10 @ €0.5" ,testCase "unit price" $ assertParseEq amountp "$10 @ €0.5"
-- not precise enough: -- not precise enough:
-- (usd 10 `withPrecision` 0 `at` (eur 0.5 `withPrecision` 1)) -- `withStyle` asdecimalpoint=Just '.' -- (usd 10 `withPrecision` 0 `at` (eur 0.5 `withPrecision` 1)) -- `withStyle` asdecimalpoint=Just '.'
amount{ amount{
acommodity="$" acommodity="$"
,aquantity=10 -- need to test internal precision with roundTo ? I think not ,aquantity=10 -- need to testCase internal precision with roundTo ? I think not
,astyle=amountstyle{asprecision=0, asdecimalpoint=Nothing} ,astyle=amountstyle{asprecision=0, asdecimalpoint=Nothing}
,aprice=Just $ UnitPrice $ ,aprice=Just $ UnitPrice $
amount{ amount{
@ -1324,7 +1324,7 @@ tests_Common = tests "Common" [
,astyle=amountstyle{asprecision=1, asdecimalpoint=Just '.'} ,astyle=amountstyle{asprecision=1, asdecimalpoint=Just '.'}
} }
} }
,test "total price" $ expectParseEq amountp "$10 @@ €5" ,testCase "total price" $ assertParseEq amountp "$10 @@ €5"
amount{ amount{
acommodity="$" acommodity="$"
,aquantity=10 ,aquantity=10
@ -1339,32 +1339,31 @@ tests_Common = tests "Common" [
] ]
,let p = lift (numberp Nothing) :: JournalParser IO (Quantity, Int, Maybe Char, Maybe DigitGroupStyle) in ,let p = lift (numberp Nothing) :: JournalParser IO (Quantity, Int, Maybe Char, Maybe DigitGroupStyle) in
tests "numberp" [ testCase "numberp" $ do
test "." $ expectParseEq p "0" (0, 0, Nothing, Nothing) assertParseEq p "0" (0, 0, Nothing, Nothing)
,test "." $ expectParseEq p "1" (1, 0, Nothing, Nothing) assertParseEq p "1" (1, 0, Nothing, Nothing)
,test "." $ expectParseEq p "1.1" (1.1, 1, Just '.', Nothing) assertParseEq p "1.1" (1.1, 1, Just '.', Nothing)
,test "." $ expectParseEq p "1,000.1" (1000.1, 1, Just '.', Just $ DigitGroups ',' [3]) assertParseEq p "1,000.1" (1000.1, 1, Just '.', Just $ DigitGroups ',' [3])
,test "." $ expectParseEq p "1.00.000,1" (100000.1, 1, Just ',', Just $ DigitGroups '.' [3,2]) assertParseEq p "1.00.000,1" (100000.1, 1, Just ',', Just $ DigitGroups '.' [3,2])
,test "." $ expectParseEq p "1,000,000" (1000000, 0, Nothing, Just $ DigitGroups ',' [3,3]) -- could be simplified to [3] assertParseEq p "1,000,000" (1000000, 0, Nothing, Just $ DigitGroups ',' [3,3]) -- could be simplified to [3]
,test "." $ expectParseEq p "1." (1, 0, Just '.', Nothing) assertParseEq p "1." (1, 0, Just '.', Nothing)
,test "." $ expectParseEq p "1," (1, 0, Just ',', Nothing) assertParseEq p "1," (1, 0, Just ',', Nothing)
,test "." $ expectParseEq p ".1" (0.1, 1, Just '.', Nothing) assertParseEq p ".1" (0.1, 1, Just '.', Nothing)
,test "." $ expectParseEq p ",1" (0.1, 1, Just ',', Nothing) assertParseEq p ",1" (0.1, 1, Just ',', Nothing)
,test "." $ expectParseError p "" "" assertParseError p "" ""
,test "." $ expectParseError p "1,000.000,1" "" assertParseError p "1,000.000,1" ""
,test "." $ expectParseError p "1.000,000.1" "" assertParseError p "1.000,000.1" ""
,test "." $ expectParseError p "1,000.000.1" "" assertParseError p "1,000.000.1" ""
,test "." $ expectParseError p "1,,1" "" assertParseError p "1,,1" ""
,test "." $ expectParseError p "1..1" "" assertParseError p "1..1" ""
,test "." $ expectParseError p ".1," "" assertParseError p ".1," ""
,test "." $ expectParseError p ",1." "" assertParseError p ",1." ""
]
,tests "spaceandamountormissingp" [ ,tests "spaceandamountormissingp" [
test "space and amount" $ expectParseEq spaceandamountormissingp " $47.18" (Mixed [usd 47.18]) testCase "space and amount" $ assertParseEq spaceandamountormissingp " $47.18" (Mixed [usd 47.18])
,test "empty string" $ expectParseEq spaceandamountormissingp "" missingmixedamt ,testCase "empty string" $ assertParseEq spaceandamountormissingp "" missingmixedamt
-- ,_test "just space" $ expectParseEq spaceandamountormissingp " " missingmixedamt -- XXX should it ? -- ,_testCase "just space" $ assertParseEq spaceandamountormissingp " " missingmixedamt -- XXX should it ?
-- ,test "just amount" $ expectParseError spaceandamountormissingp "$47.18" "" -- succeeds, consuming nothing -- ,testCase "just amount" $ assertParseError spaceandamountormissingp "$47.18" "" -- succeeds, consuming nothing
] ]
] ]

24
hledger-lib/Hledger/Read/CsvReader.hs
View File

@ -987,26 +987,26 @@ parseDateWithFormatOrDefaultFormats mformat s = firstJust $ map parsewith format
tests_CsvReader = tests "CsvReader" [ tests_CsvReader = tests "CsvReader" [
tests "parseCsvRules" [ tests "parseCsvRules" [
test "empty file" $ testCase"empty file" $
parseCsvRules "unknown" "" `is` Right defrules parseCsvRules "unknown" "" @?= Right defrules
] ]
,tests "rulesp" [ ,tests "rulesp" [
test "trailing comments" $ testCase"trailing comments" $
parseWithState' defrules rulesp "skip\n# \n#\n" `is` Right defrules{rdirectives = [("skip","")]} parseWithState' defrules rulesp "skip\n# \n#\n" @?= Right defrules{rdirectives = [("skip","")]}
,test "trailing blank lines" $ ,testCase"trailing blank lines" $
parseWithState' defrules rulesp "skip\n\n \n" `is` (Right defrules{rdirectives = [("skip","")]}) parseWithState' defrules rulesp "skip\n\n \n" @?= (Right defrules{rdirectives = [("skip","")]})
,test "no final newline" $ ,testCase"no final newline" $
parseWithState' defrules rulesp "skip" `is` (Right defrules{rdirectives=[("skip","")]}) parseWithState' defrules rulesp "skip" @?= (Right defrules{rdirectives=[("skip","")]})
,test "assignment with empty value" $ ,testCase"assignment with empty value" $
parseWithState' defrules rulesp "account1 \nif foo\n account2 foo\n" `is` parseWithState' defrules rulesp "account1 \nif foo\n account2 foo\n" @?=
(Right defrules{rassignments = [("account1","")], rconditionalblocks = [([["foo"]],[("account2","foo")])]}) (Right defrules{rassignments = [("account1","")], rconditionalblocks = [([["foo"]],[("account2","foo")])]})
] ]
,tests "conditionalblockp" [ ,tests "conditionalblockp" [
test "space after conditional" $ -- #1120 testCase"space after conditional" $ -- #1120
parseWithState' defrules conditionalblockp "if a\n account2 b\n \n" `is` parseWithState' defrules conditionalblockp "if a\n account2 b\n \n" @?=
(Right ([["a"]],[("account2","b")])) (Right ([["a"]],[("account2","b")]))
] ]
] ]

167
hledger-lib/Hledger/Read/JournalReader.hs
View File

@ -667,10 +667,10 @@ tests_JournalReader = tests "JournalReader" [
let p = lift accountnamep :: JournalParser IO AccountName in let p = lift accountnamep :: JournalParser IO AccountName in
tests "accountnamep" [ tests "accountnamep" [
test "basic" $ expectParse p "a:b:c" testCase "basic" $ assertParse p "a:b:c"
-- ,_test "empty inner component" $ expectParseError p "a::c" "" -- TODO -- ,_testCase "empty inner component" $ assertParseError p "a::c" "" -- TODO
-- ,_test "empty leading component" $ expectParseError p ":b:c" "x" -- ,_testCase "empty leading component" $ assertParseError p ":b:c" "x"
-- ,_test "empty trailing component" $ expectParseError p "a:b:" "x" -- ,_testCase "empty trailing component" $ assertParseError p "a:b:" "x"
] ]
-- "Parse a date in YYYY/MM/DD format. -- "Parse a date in YYYY/MM/DD format.
@ -678,37 +678,35 @@ tests_JournalReader = tests "JournalReader" [
-- The year may be omitted if a default year has been set. -- The year may be omitted if a default year has been set.
-- Leading zeroes may be omitted." -- Leading zeroes may be omitted."
,tests "datep" [ ,tests "datep" [
test "YYYY/MM/DD" $ expectParseEq datep "2018/01/01" (fromGregorian 2018 1 1) testCase "YYYY/MM/DD" $ assertParseEq datep "2018/01/01" (fromGregorian 2018 1 1)
,test "YYYY-MM-DD" $ expectParse datep "2018-01-01" ,testCase "YYYY-MM-DD" $ assertParse datep "2018-01-01"
,test "YYYY.MM.DD" $ expectParse datep "2018.01.01" ,testCase "YYYY.MM.DD" $ assertParse datep "2018.01.01"
,test "yearless date with no default year" $ expectParseError datep "1/1" "current year is unknown" ,testCase "yearless date with no default year" $ assertParseError datep "1/1" "current year is unknown"
,testCaseSteps "yearless date with default year" $ \_step -> do ,testCase "yearless date with default year" $ do
let s = "1/1" let s = "1/1"
ep <- parseWithState mempty{jparsedefaultyear=Just 2018} datep s ep <- parseWithState mempty{jparsedefaultyear=Just 2018} datep s
either (assertFailure . ("parse error at "++) . customErrorBundlePretty) (const $ return ()) ep either (assertFailure . ("parse error at "++) . customErrorBundlePretty) (const $ return ()) ep
,test "no leading zero" $ expectParse datep "2018/1/1" ,testCase "no leading zero" $ assertParse datep "2018/1/1"
] ]
,let ,testCase "datetimep" $ do
good = expectParse datetimep let
bad = (\t -> expectParseError datetimep t "") good = assertParse datetimep
in tests "datetimep" [ bad = (\t -> assertParseError datetimep t "")
good "2011/1/1 00:00" good "2011/1/1 00:00"
,good "2011/1/1 23:59:59" good "2011/1/1 23:59:59"
,bad "2011/1/1" bad "2011/1/1"
,bad "2011/1/1 24:00:00" bad "2011/1/1 24:00:00"
,bad "2011/1/1 00:60:00" bad "2011/1/1 00:60:00"
,bad "2011/1/1 00:00:60" bad "2011/1/1 00:00:60"
,bad "2011/1/1 3:5:7" bad "2011/1/1 3:5:7"
,let t = LocalTime (fromGregorian 2018 1 1) (TimeOfDay 0 0 (fromIntegral 0)) -- timezone is parsed but ignored
in tests "timezone is parsed but ignored" [ let t = LocalTime (fromGregorian 2018 1 1) (TimeOfDay 0 0 (fromIntegral 0))
expectParseEq datetimep "2018/1/1 00:00-0800" t assertParseEq datetimep "2018/1/1 00:00-0800" t
,expectParseEq datetimep "2018/1/1 00:00+1234" t assertParseEq datetimep "2018/1/1 00:00+1234" t
]
]
,tests "periodictransactionp" [ ,tests "periodictransactionp" [
test "more period text in comment after one space" $ expectParseEq periodictransactionp testCase "more period text in comment after one space" $ assertParseEq periodictransactionp
"~ monthly from 2018/6 ;In 2019 we will change this\n" "~ monthly from 2018/6 ;In 2019 we will change this\n"
nullperiodictransaction { nullperiodictransaction {
ptperiodexpr = "monthly from 2018/6" ptperiodexpr = "monthly from 2018/6"
@ -718,7 +716,7 @@ tests_JournalReader = tests "JournalReader" [
,ptcomment = "In 2019 we will change this\n" ,ptcomment = "In 2019 we will change this\n"
} }
,test "more period text in description after two spaces" $ expectParseEq periodictransactionp ,testCase "more period text in description after two spaces" $ assertParseEq periodictransactionp
"~ monthly from 2018/6 In 2019 we will change this\n" "~ monthly from 2018/6 In 2019 we will change this\n"
nullperiodictransaction { nullperiodictransaction {
ptperiodexpr = "monthly from 2018/6" ptperiodexpr = "monthly from 2018/6"
@ -728,7 +726,7 @@ tests_JournalReader = tests "JournalReader" [
,ptcomment = "" ,ptcomment = ""
} }
,test "Next year in description" $ expectParseEq periodictransactionp ,testCase "Next year in description" $ assertParseEq periodictransactionp
"~ monthly Next year blah blah\n" "~ monthly Next year blah blah\n"
nullperiodictransaction { nullperiodictransaction {
ptperiodexpr = "monthly" ptperiodexpr = "monthly"
@ -738,7 +736,7 @@ tests_JournalReader = tests "JournalReader" [
,ptcomment = "" ,ptcomment = ""
} }
,test "Just date, no description" $ expectParseEq periodictransactionp ,testCase "Just date, no description" $ assertParseEq periodictransactionp
"~ 2019-01-04\n" "~ 2019-01-04\n"
nullperiodictransaction { nullperiodictransaction {
ptperiodexpr = "2019-01-04" ptperiodexpr = "2019-01-04"
@ -748,13 +746,13 @@ tests_JournalReader = tests "JournalReader" [
,ptcomment = "" ,ptcomment = ""
} }
,test "Just date, no description + empty transaction comment" $ expectParse periodictransactionp ,testCase "Just date, no description + empty transaction comment" $ assertParse periodictransactionp
"~ 2019-01-04\n ;\n a 1\n b\n" "~ 2019-01-04\n ;\n a 1\n b\n"
] ]
,tests "postingp" [ ,tests "postingp" [
test "basic" $ expectParseEq (postingp Nothing) testCase "basic" $ assertParseEq (postingp Nothing)
" expenses:food:dining $10.00 ; a: a a \n ; b: b b \n" " expenses:food:dining $10.00 ; a: a a \n ; b: b b \n"
posting{ posting{
paccount="expenses:food:dining", paccount="expenses:food:dining",
@ -763,7 +761,7 @@ tests_JournalReader = tests "JournalReader" [
ptags=[("a","a a"), ("b","b b")] ptags=[("a","a a"), ("b","b b")]
} }
,test "posting dates" $ expectParseEq (postingp Nothing) ,testCase "posting dates" $ assertParseEq (postingp Nothing)
" a 1. ; date:2012/11/28, date2=2012/11/29,b:b\n" " a 1. ; date:2012/11/28, date2=2012/11/29,b:b\n"
nullposting{ nullposting{
paccount="a" paccount="a"
@ -774,7 +772,7 @@ tests_JournalReader = tests "JournalReader" [
,pdate2=Nothing -- Just $ fromGregorian 2012 11 29 ,pdate2=Nothing -- Just $ fromGregorian 2012 11 29
} }
,test "posting dates bracket syntax" $ expectParseEq (postingp Nothing) ,testCase "posting dates bracket syntax" $ assertParseEq (postingp Nothing)
" a 1. ; [2012/11/28=2012/11/29]\n" " a 1. ; [2012/11/28=2012/11/29]\n"
nullposting{ nullposting{
paccount="a" paccount="a"
@ -785,16 +783,16 @@ tests_JournalReader = tests "JournalReader" [
,pdate2=Just $ fromGregorian 2012 11 29 ,pdate2=Just $ fromGregorian 2012 11 29
} }
,test "quoted commodity symbol with digits" $ expectParse (postingp Nothing) " a 1 \"DE123\"\n" ,testCase "quoted commodity symbol with digits" $ assertParse (postingp Nothing) " a 1 \"DE123\"\n"
,test "balance assertion and fixed lot price" $ expectParse (postingp Nothing) " a 1 \"DE123\" =$1 { =2.2 EUR} \n" ,testCase "balance assertion and fixed lot price" $ assertParse (postingp Nothing) " a 1 \"DE123\" =$1 { =2.2 EUR} \n"
,test "balance assertion over entire contents of account" $ expectParse (postingp Nothing) " a $1 == $1\n" ,testCase "balance assertion over entire contents of account" $ assertParse (postingp Nothing) " a $1 == $1\n"
] ]
,tests "transactionmodifierp" [ ,tests "transactionmodifierp" [
test "basic" $ expectParseEq transactionmodifierp testCase "basic" $ assertParseEq transactionmodifierp
"= (some value expr)\n some:postings 1.\n" "= (some value expr)\n some:postings 1.\n"
nulltransactionmodifier { nulltransactionmodifier {
tmquerytxt = "(some value expr)" tmquerytxt = "(some value expr)"
@ -804,9 +802,9 @@ tests_JournalReader = tests "JournalReader" [
,tests "transactionp" [ ,tests "transactionp" [
test "just a date" $ expectParseEq transactionp "2015/1/1\n" nulltransaction{tdate=fromGregorian 2015 1 1} testCase "just a date" $ assertParseEq transactionp "2015/1/1\n" nulltransaction{tdate=fromGregorian 2015 1 1}
,test "more complex" $ expectParseEq transactionp ,testCase "more complex" $ assertParseEq transactionp
(T.unlines [ (T.unlines [
"2012/05/14=2012/05/15 (code) desc ; tcomment1", "2012/05/14=2012/05/15 (code) desc ; tcomment1",
" ; tcomment2", " ; tcomment2",
@ -840,27 +838,27 @@ tests_JournalReader = tests "JournalReader" [
] ]
} }
,test "parses a well-formed transaction" $ ,testCase "parses a well-formed transaction" $
expect $ isRight $ rjp transactionp $ T.unlines assertBool "" $ isRight $ rjp transactionp $ T.unlines
["2007/01/28 coopportunity" ["2007/01/28 coopportunity"
," expenses:food:groceries $47.18" ," expenses:food:groceries $47.18"
," assets:checking $-47.18" ," assets:checking $-47.18"
,"" ,""
] ]
,test "does not parse a following comment as part of the description" $ ,testCase "does not parse a following comment as part of the description" $
expectParseEqOn transactionp "2009/1/1 a ;comment\n b 1\n" tdescription "a" assertParseEqOn transactionp "2009/1/1 a ;comment\n b 1\n" tdescription "a"
,test "transactionp parses a following whitespace line" $ ,testCase "parses a following whitespace line" $
expect $ isRight $ rjp transactionp $ T.unlines assertBool "" $ isRight $ rjp transactionp $ T.unlines
["2012/1/1" ["2012/1/1"
," a 1" ," a 1"
," b" ," b"
," " ," "
] ]
,test "transactionp parses an empty transaction comment following whitespace line" $ ,testCase "parses an empty transaction comment following whitespace line" $
expect $ isRight $ rjp transactionp $ T.unlines assertBool "" $ isRight $ rjp transactionp $ T.unlines
["2012/1/1" ["2012/1/1"
," ;" ," ;"
," a 1" ," a 1"
@ -868,8 +866,8 @@ tests_JournalReader = tests "JournalReader" [
," " ," "
] ]
,test "comments everywhere, two postings parsed" $ ,testCase "comments everywhere, two postings parsed" $
expectParseEqOn transactionp assertParseEqOn transactionp
(T.unlines (T.unlines
["2009/1/1 x ; transaction comment" ["2009/1/1 x ; transaction comment"
," a 1 ; posting 1 comment" ," a 1 ; posting 1 comment"
@ -885,17 +883,16 @@ tests_JournalReader = tests "JournalReader" [
-- directives -- directives
,tests "directivep" [ ,tests "directivep" [
tests "supports !" [ testCase "supports !" $ do
expectParseE directivep "!account a\n" assertParseE directivep "!account a\n"
,expectParseE directivep "!D 1.0\n" assertParseE directivep "!D 1.0\n"
] ]
]
,tests "accountdirectivep" [ ,tests "accountdirectivep" [
test "with-comment" $ expectParse accountdirectivep "account a:b ; a comment\n" testCase "with-comment" $ assertParse accountdirectivep "account a:b ; a comment\n"
,test "does-not-support-!" $ expectParseError accountdirectivep "!account a:b\n" "" ,testCase "does-not-support-!" $ assertParseError accountdirectivep "!account a:b\n" ""
,test "account-type-code" $ expectParse accountdirectivep "account a:b A\n" ,testCase "account-type-code" $ assertParse accountdirectivep "account a:b A\n"
,test "account-type-tag" $ expectParseStateOn accountdirectivep "account a:b ; type:asset\n" ,testCase "account-type-tag" $ assertParseStateOn accountdirectivep "account a:b ; type:asset\n"
jdeclaredaccounts jdeclaredaccounts
[("a:b", AccountDeclarationInfo{adicomment = "type:asset\n" [("a:b", AccountDeclarationInfo{adicomment = "type:asset\n"
,aditags = [("type","asset")] ,aditags = [("type","asset")]
@ -904,29 +901,28 @@ tests_JournalReader = tests "JournalReader" [
] ]
] ]
,test "commodityconversiondirectivep" $ do ,testCase "commodityconversiondirectivep" $ do
expectParse commodityconversiondirectivep "C 1h = $50.00\n" assertParse commodityconversiondirectivep "C 1h = $50.00\n"
,tests "defaultcommoditydirectivep" [ ,testCase "defaultcommoditydirectivep" $ do
expectParse defaultcommoditydirectivep "D $1,000.0\n" assertParse defaultcommoditydirectivep "D $1,000.0\n"
,expectParseError defaultcommoditydirectivep "D $1000\n" "please include a decimal separator" assertParseError defaultcommoditydirectivep "D $1000\n" "please include a decimal separator"
]
,tests "defaultyeardirectivep" [ ,tests "defaultyeardirectivep" [
test "1000" $ expectParse defaultyeardirectivep "Y 1000" -- XXX no \n like the others testCase "1000" $ assertParse defaultyeardirectivep "Y 1000" -- XXX no \n like the others
,test "999" $ expectParseError defaultyeardirectivep "Y 999" "bad year number" ,testCase "999" $ assertParseError defaultyeardirectivep "Y 999" "bad year number"
,test "12345" $ expectParse defaultyeardirectivep "Y 12345" ,testCase "12345" $ assertParse defaultyeardirectivep "Y 12345"
] ]
,test "ignoredpricecommoditydirectivep" $ do ,testCase "ignoredpricecommoditydirectivep" $ do
expectParse ignoredpricecommoditydirectivep "N $\n" assertParse ignoredpricecommoditydirectivep "N $\n"
,tests "includedirectivep" [ ,tests "includedirectivep" [
test "include" $ expectParseErrorE includedirectivep "include nosuchfile\n" "No existing files match pattern: nosuchfile" testCase "include" $ assertParseErrorE includedirectivep "include nosuchfile\n" "No existing files match pattern: nosuchfile"
,test "glob" $ expectParseErrorE includedirectivep "include nosuchfile*\n" "No existing files match pattern: nosuchfile*" ,testCase "glob" $ assertParseErrorE includedirectivep "include nosuchfile*\n" "No existing files match pattern: nosuchfile*"
] ]
,test "marketpricedirectivep" $ expectParseEq marketpricedirectivep ,testCase "marketpricedirectivep" $ assertParseEq marketpricedirectivep
"P 2017/01/30 BTC $922.83\n" "P 2017/01/30 BTC $922.83\n"
PriceDirective{ PriceDirective{
pddate = fromGregorian 2017 1 30, pddate = fromGregorian 2017 1 30,
@ -934,24 +930,21 @@ tests_JournalReader = tests "JournalReader" [
pdamount = usd 922.83 pdamount = usd 922.83
} }
,test "tagdirectivep" $ do ,testCase "tagdirectivep" $ do
expectParse tagdirectivep "tag foo \n" assertParse tagdirectivep "tag foo \n"
,tests "endtagdirectivep" [ ,testCase "endtagdirectivep" $ do
expectParse endtagdirectivep "end tag \n" assertParse endtagdirectivep "end tag \n"
,expectParse endtagdirectivep "pop \n" assertParse endtagdirectivep "pop \n"
]
,tests "journalp" [ ,tests "journalp" [
test "empty file" $ expectParseEqE journalp "" nulljournal testCase "empty file" $ assertParseEqE journalp "" nulljournal
] ]
-- these are defined here rather than in Common so they can use journalp -- these are defined here rather than in Common so they can use journalp
,tests "parseAndFinaliseJournal" [ ,testCase "parseAndFinaliseJournal" $ do
testCaseSteps "basic" $ \_step -> do ej <- runExceptT $ parseAndFinaliseJournal journalp definputopts "" "2019-1-1\n"
ej <- runExceptT $ parseAndFinaliseJournal journalp definputopts "" "2019-1-1\n" let Right j = ej
let Right j = ej assertEqual "" [""] $ journalFilePaths j
assertEq [""] $ journalFilePaths j
]
] ]

46
hledger-lib/Hledger/Reports/BalanceReport.hs
View File

@ -248,20 +248,21 @@ Right samplejournal2 =
} }
tests_BalanceReport = tests "BalanceReport" [ tests_BalanceReport = tests "BalanceReport" [
let let
(opts,journal) `gives` r = testCaseSteps "sometest" $ \_step -> do (opts,journal) `gives` r = do
let (eitems, etotal) = r let (eitems, etotal) = r
(aitems, atotal) = balanceReport opts (queryFromOpts nulldate opts) journal (aitems, atotal) = balanceReport opts (queryFromOpts nulldate opts) journal
showw (acct,acct',indent,amt) = (acct, acct', indent, showMixedAmountDebug amt) showw (acct,acct',indent,amt) = (acct, acct', indent, showMixedAmountDebug amt)
(map showw eitems) @?= (map showw aitems) (map showw eitems) @?= (map showw aitems)
(showMixedAmountDebug etotal) @?= (showMixedAmountDebug atotal) (showMixedAmountDebug etotal) @?= (showMixedAmountDebug atotal)
usd0 = usd 0 in
in tests "balanceReport" [ tests "balanceReport" [
test "balanceReport with no args on null journal" $ testCase "no args, null journal" $
(defreportopts, nulljournal) `gives` ([], Mixed [nullamt]) (defreportopts, nulljournal) `gives` ([], Mixed [nullamt])
,test "balanceReport with no args on sample journal" $ ,testCase "no args, sample journal" $
(defreportopts, samplejournal) `gives` (defreportopts, samplejournal) `gives`
([ ([
("assets","assets",0, mamountp' "$0.00") ("assets","assets",0, mamountp' "$0.00")
@ -276,45 +277,46 @@ tests_BalanceReport = tests "BalanceReport" [
,("income:gifts","gifts",1, mamountp' "$-1.00") ,("income:gifts","gifts",1, mamountp' "$-1.00")
,("income:salary","salary",1, mamountp' "$-1.00") ,("income:salary","salary",1, mamountp' "$-1.00")
], ],
Mixed [usd0]) Mixed [usd 0])
,test "balanceReport with --depth=N" $ ,testCase "with --depth=N" $
(defreportopts{depth_=Just 1}, samplejournal) `gives` (defreportopts{depth_=Just 1}, samplejournal) `gives`
([ ([
("expenses", "expenses", 0, mamountp' "$2.00") ("expenses", "expenses", 0, mamountp' "$2.00")
,("income", "income", 0, mamountp' "$-2.00") ,("income", "income", 0, mamountp' "$-2.00")
], ],
Mixed [usd0]) Mixed [usd 0])
,test "balanceReport with depth:N" $ ,testCase "with depth:N" $
(defreportopts{query_="depth:1"}, samplejournal) `gives` (defreportopts{query_="depth:1"}, samplejournal) `gives`
([ ([
("expenses", "expenses", 0, mamountp' "$2.00") ("expenses", "expenses", 0, mamountp' "$2.00")
,("income", "income", 0, mamountp' "$-2.00") ,("income", "income", 0, mamountp' "$-2.00")
], ],
Mixed [usd0]) Mixed [usd 0])
,tests "balanceReport with a date or secondary date span" [ ,testCase "with date:" $
(defreportopts{query_="date:'in 2009'"}, samplejournal2) `gives` (defreportopts{query_="date:'in 2009'"}, samplejournal2) `gives`
([], ([],
Mixed [nullamt]) Mixed [nullamt])
,(defreportopts{query_="date2:'in 2009'"}, samplejournal2) `gives`
,testCase "with date2:" $
(defreportopts{query_="date2:'in 2009'"}, samplejournal2) `gives`
([ ([
("assets:bank:checking","assets:bank:checking",0,mamountp' "$1.00") ("assets:bank:checking","assets:bank:checking",0,mamountp' "$1.00")
,("income:salary","income:salary",0,mamountp' "$-1.00") ,("income:salary","income:salary",0,mamountp' "$-1.00")
], ],
Mixed [usd0]) Mixed [usd 0])
]
,test "balanceReport with desc:" $ ,testCase "with desc:" $
(defreportopts{query_="desc:income"}, samplejournal) `gives` (defreportopts{query_="desc:income"}, samplejournal) `gives`
([ ([
("assets:bank:checking","assets:bank:checking",0,mamountp' "$1.00") ("assets:bank:checking","assets:bank:checking",0,mamountp' "$1.00")
,("income:salary","income:salary",0, mamountp' "$-1.00") ,("income:salary","income:salary",0, mamountp' "$-1.00")
], ],
Mixed [usd0]) Mixed [usd 0])
,test "balanceReport with not:desc:" $ ,testCase "with not:desc:" $
(defreportopts{query_="not:desc:income"}, samplejournal) `gives` (defreportopts{query_="not:desc:income"}, samplejournal) `gives`
([ ([
("assets","assets",0, mamountp' "$-1.00") ("assets","assets",0, mamountp' "$-1.00")
@ -325,18 +327,18 @@ tests_BalanceReport = tests "BalanceReport" [
,("expenses:supplies","supplies",1, mamountp' "$1.00") ,("expenses:supplies","supplies",1, mamountp' "$1.00")
,("income:gifts","income:gifts",0, mamountp' "$-1.00") ,("income:gifts","income:gifts",0, mamountp' "$-1.00")
], ],
Mixed [usd0]) Mixed [usd 0])
,test "balanceReport with period on a populated period" $ ,testCase "with period on a populated period" $
(defreportopts{period_= PeriodBetween (fromGregorian 2008 1 1) (fromGregorian 2008 1 2)}, samplejournal) `gives` (defreportopts{period_= PeriodBetween (fromGregorian 2008 1 1) (fromGregorian 2008 1 2)}, samplejournal) `gives`
( (
[ [
("assets:bank:checking","assets:bank:checking",0, mamountp' "$1.00") ("assets:bank:checking","assets:bank:checking",0, mamountp' "$1.00")
,("income:salary","income:salary",0, mamountp' "$-1.00") ,("income:salary","income:salary",0, mamountp' "$-1.00")
], ],
Mixed [usd0]) Mixed [usd 0])
,test "balanceReport with period on an unpopulated period" $ ,testCase "with period on an unpopulated period" $
(defreportopts{period_= PeriodBetween (fromGregorian 2008 1 2) (fromGregorian 2008 1 3)}, samplejournal) `gives` (defreportopts{period_= PeriodBetween (fromGregorian 2008 1 2) (fromGregorian 2008 1 3)}, samplejournal) `gives`
([],Mixed [nullamt]) ([],Mixed [nullamt])
@ -456,7 +458,7 @@ tests_BalanceReport = tests "BalanceReport" [
," 0" ," 0"
] ]
-} -}
] ]
] ]

4
hledger-lib/Hledger/Reports/EntriesReport.hs
View File

@ -49,8 +49,8 @@ entriesReport ropts@ReportOpts{..} q j@Journal{..} =
tests_EntriesReport = tests "EntriesReport" [ tests_EntriesReport = tests "EntriesReport" [
tests "entriesReport" [ tests "entriesReport" [
test "not acct" $ (length $ entriesReport defreportopts (Not $ Acct "bank") samplejournal) `is` 1 testCase "not acct" $ (length $ entriesReport defreportopts (Not $ Acct "bank") samplejournal) @?= 1
,test "date" $ (length $ entriesReport defreportopts (Date $ mkdatespan "2008/06/01" "2008/07/01") samplejournal) `is` 3 ,testCase "date" $ (length $ entriesReport defreportopts (Date $ mkdatespan "2008/06/01" "2008/07/01") samplejournal) @?= 3
] ]
] ]

36
hledger-lib/Hledger/Reports/MultiBalanceReport.hs
View File

@ -416,49 +416,49 @@ tableAsText (ReportOpts{pretty_tables_ = pretty}) showcell =
-- tests -- tests
tests_MultiBalanceReport = tests "MultiBalanceReport" [ tests_MultiBalanceReport = tests "MultiBalanceReport" [
let let
(opts,journal) `gives` r = testCaseSteps "sometest" $ \_step -> do amt0 = Amount {acommodity="$", aquantity=0, aprice=Nothing, astyle=AmountStyle {ascommodityside = L, ascommodityspaced = False, asprecision = 2, asdecimalpoint = Just '.', asdigitgroups = Nothing}, aismultiplier=False}
(opts,journal) `gives` r = do
let (eitems, etotal) = r let (eitems, etotal) = r
(MultiBalanceReport (_, aitems, atotal)) = multiBalanceReport opts (queryFromOpts nulldate opts) journal (MultiBalanceReport (_, aitems, atotal)) = multiBalanceReport opts (queryFromOpts nulldate opts) journal
showw (acct,acct',indent,lAmt,amt,amt') = (acct, acct', indent, map showMixedAmountDebug lAmt, showMixedAmountDebug amt, showMixedAmountDebug amt') showw (acct,acct',indent,lAmt,amt,amt') = (acct, acct', indent, map showMixedAmountDebug lAmt, showMixedAmountDebug amt, showMixedAmountDebug amt')
(map showw aitems) @?= (map showw eitems) (map showw aitems) @?= (map showw eitems)
((\(_, b, _) -> showMixedAmountDebug b) atotal) @?= (showMixedAmountDebug etotal) -- we only check the sum of the totals ((\(_, b, _) -> showMixedAmountDebug b) atotal) @?= (showMixedAmountDebug etotal) -- we only check the sum of the totals
-- usd0 = usd 0
amount0 = Amount {acommodity="$", aquantity=0, aprice=Nothing, astyle=AmountStyle {ascommodityside = L, ascommodityspaced = False, asprecision = 2, asdecimalpoint = Just '.', asdigitgroups = Nothing}, aismultiplier=False}
in in
tests "multiBalanceReport" [ tests "multiBalanceReport" [
test "null journal" $ testCase "null journal" $
(defreportopts, nulljournal) `gives` ([], Mixed [nullamt]) (defreportopts, nulljournal) `gives` ([], Mixed [nullamt])
,test "with -H on a populated period" $ ,testCase "with -H on a populated period" $
(defreportopts{period_= PeriodBetween (fromGregorian 2008 1 1) (fromGregorian 2008 1 2), balancetype_=HistoricalBalance}, samplejournal) `gives` (defreportopts{period_= PeriodBetween (fromGregorian 2008 1 1) (fromGregorian 2008 1 2), balancetype_=HistoricalBalance}, samplejournal) `gives`
( (
[ [
("assets:bank:checking", "checking", 3, [mamountp' "$1.00"] , Mixed [nullamt], Mixed [amount0 {aquantity=1}]) ("assets:bank:checking", "checking", 3, [mamountp' "$1.00"] , Mixed [nullamt], Mixed [amt0 {aquantity=1}])
,("income:salary" ,"salary" , 2, [mamountp' "$-1.00"], Mixed [nullamt], Mixed [amount0 {aquantity=(-1)}]) ,("income:salary" ,"salary" , 2, [mamountp' "$-1.00"], Mixed [nullamt], Mixed [amt0 {aquantity=(-1)}])
], ],
Mixed [nullamt]) Mixed [nullamt])
-- ,_test "a valid history on an empty period" $ -- ,testCase "a valid history on an empty period" $
-- (defreportopts{period_= PeriodBetween (fromGregorian 2008 1 2) (fromGregorian 2008 1 3), balancetype_=HistoricalBalance}, samplejournal) `gives` -- (defreportopts{period_= PeriodBetween (fromGregorian 2008 1 2) (fromGregorian 2008 1 3), balancetype_=HistoricalBalance}, samplejournal) `gives`
-- ( -- (
-- [ -- [
-- ("assets:bank:checking","checking",3, [mamountp' "$1.00"], mamountp' "$1.00",Mixed [amount0 {aquantity=1}]) -- ("assets:bank:checking","checking",3, [mamountp' "$1.00"], mamountp' "$1.00",Mixed [amt0 {aquantity=1}])
-- ,("income:salary","salary",2, [mamountp' "$-1.00"], mamountp' "$-1.00",Mixed [amount0 {aquantity=(-1)}]) -- ,("income:salary","salary",2, [mamountp' "$-1.00"], mamountp' "$-1.00",Mixed [amt0 {aquantity=(-1)}])
-- ], -- ],
-- Mixed [usd0]) -- Mixed [usd0])
-- ,_test "a valid history on an empty period (more complex)" $ -- ,testCase "a valid history on an empty period (more complex)" $
-- (defreportopts{period_= PeriodBetween (fromGregorian 2009 1 1) (fromGregorian 2009 1 2), balancetype_=HistoricalBalance}, samplejournal) `gives` -- (defreportopts{period_= PeriodBetween (fromGregorian 2009 1 1) (fromGregorian 2009 1 2), balancetype_=HistoricalBalance}, samplejournal) `gives`
-- ( -- (
-- [ -- [
-- ("assets:bank:checking","checking",3, [mamountp' "$1.00"], mamountp' "$1.00",Mixed [amount0 {aquantity=1}]) -- ("assets:bank:checking","checking",3, [mamountp' "$1.00"], mamountp' "$1.00",Mixed [amt0 {aquantity=1}])
-- ,("assets:bank:saving","saving",3, [mamountp' "$1.00"], mamountp' "$1.00",Mixed [amount0 {aquantity=1}]) -- ,("assets:bank:saving","saving",3, [mamountp' "$1.00"], mamountp' "$1.00",Mixed [amt0 {aquantity=1}])
-- ,("assets:cash","cash",2, [mamountp' "$-2.00"], mamountp' "$-2.00",Mixed [amount0 {aquantity=(-2)}]) -- ,("assets:cash","cash",2, [mamountp' "$-2.00"], mamountp' "$-2.00",Mixed [amt0 {aquantity=(-2)}])
-- ,("expenses:food","food",2, [mamountp' "$1.00"], mamountp' "$1.00",Mixed [amount0 {aquantity=(1)}]) -- ,("expenses:food","food",2, [mamountp' "$1.00"], mamountp' "$1.00",Mixed [amt0 {aquantity=(1)}])
-- ,("expenses:supplies","supplies",2, [mamountp' "$1.00"], mamountp' "$1.00",Mixed [amount0 {aquantity=(1)}]) -- ,("expenses:supplies","supplies",2, [mamountp' "$1.00"], mamountp' "$1.00",Mixed [amt0 {aquantity=(1)}])
-- ,("income:gifts","gifts",2, [mamountp' "$-1.00"], mamountp' "$-1.00",Mixed [amount0 {aquantity=(-1)}]) -- ,("income:gifts","gifts",2, [mamountp' "$-1.00"], mamountp' "$-1.00",Mixed [amt0 {aquantity=(-1)}])
-- ,("income:salary","salary",2, [mamountp' "$-1.00"], mamountp' "$-1.00",Mixed [amount0 {aquantity=(-1)}]) -- ,("income:salary","salary",2, [mamountp' "$-1.00"], mamountp' "$-1.00",Mixed [amt0 {aquantity=(-1)}])
-- ], -- ],
-- Mixed [usd0]) -- Mixed [usd0])
] ]

38
hledger-lib/Hledger/Reports/PostingsReport.hs
View File

@ -270,22 +270,20 @@ negatePostingAmount p = p { pamount = negate $ pamount p }
tests_PostingsReport = tests "PostingsReport" [ tests_PostingsReport = tests "PostingsReport" [
tests "postingsReport" $ testCase "postingsReport" $ do
let (query, journal) `gives` n = (length $ snd $ postingsReport defreportopts query journal) `is` n let (query, journal) `gives` n = (length $ snd $ postingsReport defreportopts query journal) @?= n
in [ -- with the query specified explicitly
-- with the query specified explicitly (Any, nulljournal) `gives` 0
(Any, nulljournal) `gives` 0 (Any, samplejournal) `gives` 13
,(Any, samplejournal) `gives` 13 -- register --depth just clips account names
-- register --depth just clips account names (Depth 2, samplejournal) `gives` 13
,(Depth 2, samplejournal) `gives` 13 (And [Depth 1, StatusQ Cleared, Acct "expenses"], samplejournal) `gives` 2
,(And [Depth 1, StatusQ Cleared, Acct "expenses"], samplejournal) `gives` 2 (And [And [Depth 1, StatusQ Cleared], Acct "expenses"], samplejournal) `gives` 2
,(And [And [Depth 1, StatusQ Cleared], Acct "expenses"], samplejournal) `gives` 2 -- with query and/or command-line options
(length $ snd $ postingsReport defreportopts Any samplejournal) @?= 13
-- with query and/or command-line options (length $ snd $ postingsReport defreportopts{interval_=Months 1} Any samplejournal) @?= 11
,(length $ snd $ postingsReport defreportopts Any samplejournal) `is` 13 (length $ snd $ postingsReport defreportopts{interval_=Months 1, empty_=True} Any samplejournal) @?= 20
,(length $ snd $ postingsReport defreportopts{interval_=Months 1} Any samplejournal) `is` 11 (length $ snd $ postingsReport defreportopts (Acct "assets:bank:checking") samplejournal) @?= 5
,(length $ snd $ postingsReport defreportopts{interval_=Months 1, empty_=True} Any samplejournal) `is` 20
,(length $ snd $ postingsReport defreportopts (Acct "assets:bank:checking") samplejournal) `is` 5
-- (defreportopts, And [Acct "a a", Acct "'b"], samplejournal2) `gives` 0 -- (defreportopts, And [Acct "a a", Acct "'b"], samplejournal2) `gives` 0
-- [(Just (parsedate "2008-01-01","income"),assets:bank:checking $1,$1) -- [(Just (parsedate "2008-01-01","income"),assets:bank:checking $1,$1)
@ -432,13 +430,9 @@ tests_PostingsReport = tests "PostingsReport" [
] ]
-} -}
]
,tests "summarisePostingsByInterval" [ ,testCase "summarisePostingsByInterval" $
tests "summarisePostingsByInterval" [ summarisePostingsByInterval (Quarters 1) PrimaryDate 99999 False (DateSpan Nothing Nothing) [] @?= []
summarisePostingsByInterval (Quarters 1) PrimaryDate 99999 False (DateSpan Nothing Nothing) [] `is` []
]
]
-- ,tests_summarisePostingsInDateSpan = [ -- ,tests_summarisePostingsInDateSpan = [
-- "summarisePostingsInDateSpan" ~: do -- "summarisePostingsInDateSpan" ~: do

30
hledger-lib/Hledger/Reports/ReportOptions.hs
View File

@ -539,23 +539,19 @@ reportPeriodOrJournalLastDay ropts@ReportOpts{..} j =
-- tests -- tests
tests_ReportOptions = tests "ReportOptions" [ tests_ReportOptions = tests "ReportOptions" [
tests "queryFromOpts" [ testCase "queryFromOpts" $ do
(queryFromOpts nulldate defreportopts) `is` Any queryFromOpts nulldate defreportopts @?= Any
,(queryFromOpts nulldate defreportopts{query_="a"}) `is` (Acct "a") queryFromOpts nulldate defreportopts{query_="a"} @?= Acct "a"
,(queryFromOpts nulldate defreportopts{query_="desc:'a a'"}) `is` (Desc "a a") queryFromOpts nulldate defreportopts{query_="desc:'a a'"} @?= Desc "a a"
,(queryFromOpts nulldate defreportopts{period_=PeriodFrom (parsedate "2012/01/01"),query_="date:'to 2013'" }) queryFromOpts nulldate defreportopts{period_=PeriodFrom (parsedate "2012/01/01"),query_="date:'to 2013'" }
`is` (Date $ mkdatespan "2012/01/01" "2013/01/01") @?= (Date $ mkdatespan "2012/01/01" "2013/01/01")
,(queryFromOpts nulldate defreportopts{query_="date2:'in 2012'"}) `is` (Date2 $ mkdatespan "2012/01/01" "2013/01/01") queryFromOpts nulldate defreportopts{query_="date2:'in 2012'"} @?= (Date2 $ mkdatespan "2012/01/01" "2013/01/01")
,(queryFromOpts nulldate defreportopts{query_="'a a' 'b"}) `is` (Or [Acct "a a", Acct "'b"]) queryFromOpts nulldate defreportopts{query_="'a a' 'b"} @?= Or [Acct "a a", Acct "'b"]
]
,tests "queryOptsFromOpts" [ ,testCase "queryOptsFromOpts" $ do
(queryOptsFromOpts nulldate defreportopts) `is` [] queryOptsFromOpts nulldate defreportopts @?= []
,(queryOptsFromOpts nulldate defreportopts{query_="a"}) `is` [] queryOptsFromOpts nulldate defreportopts{query_="a"} @?= []
,(queryOptsFromOpts nulldate defreportopts{period_=PeriodFrom (parsedate "2012/01/01") queryOptsFromOpts nulldate defreportopts{period_=PeriodFrom (parsedate "2012/01/01")
,query_="date:'to 2013'" ,query_="date:'to 2013'"} @?= []
})
`is` []
]
] ]

175
hledger-lib/Hledger/Utils/Test.hs
View File

@ -10,30 +10,19 @@ module Hledger.Utils.Test (
-- ,module SC -- ,module SC
,tests ,tests
,test ,test
,is
,expect
,assertEq
,expectEq
,assertLeft ,assertLeft
,expectLeft
,assertRight ,assertRight
,expectRight ,assertParse
,expectParse ,assertParseEq
,expectParseEq ,assertParseEqOn
,expectParseEqOn ,assertParseError
,expectParseError ,assertParseE
,expectParseE ,assertParseEqE
,expectParseEqE ,assertParseErrorE
,expectParseErrorE ,assertParseStateOn
,expectParseStateOn
) )
where where
import Test.Tasty
import Test.Tasty.HUnit
-- import Test.Tasty.QuickCheck as QC
-- import Test.Tasty.SmallCheck as SC
import Control.Monad.Except (ExceptT, runExceptT) import Control.Monad.Except (ExceptT, runExceptT)
import Control.Monad.State.Strict (StateT, evalStateT, execStateT) import Control.Monad.State.Strict (StateT, evalStateT, execStateT)
-- #if !(MIN_VERSION_base(4,11,0)) -- #if !(MIN_VERSION_base(4,11,0))
@ -42,97 +31,76 @@ import Control.Monad.State.Strict (StateT, evalStateT, execStateT)
-- import Data.CallStack -- import Data.CallStack
import Data.List (isInfixOf) import Data.List (isInfixOf)
import qualified Data.Text as T import qualified Data.Text as T
import Test.Tasty
import Test.Tasty.HUnit
-- import Test.Tasty.QuickCheck as QC
-- import Test.Tasty.SmallCheck as SC
import Text.Megaparsec import Text.Megaparsec
import Text.Megaparsec.Custom import Text.Megaparsec.Custom
( CustomErr,
FinalParseError,
attachSource,
customErrorBundlePretty,
finalErrorBundlePretty,
)
import Hledger.Utils.Debug (pshow) import Hledger.Utils.Debug (pshow)
-- import Hledger.Utils.UTF8IOCompat (error') -- import Hledger.Utils.UTF8IOCompat (error')
-- * tasty helpers -- * tasty helpers
-- | Name and group a list of tests. -- TODO: pretty-print values in failure messages
-- | Name and group a list of tests. Shorter alias for Test.Tasty.HUnit.testGroup.
tests :: String -> [TestTree] -> TestTree tests :: String -> [TestTree] -> TestTree
tests = testGroup tests = testGroup
-- | Name the given test(s). -- | Name an assertion or sequence of assertions. Shorter alias for Test.Tasty.HUnit.testCase.
-- test :: T.Text -> E.Test a -> E.Test a test :: String -> Assertion -> TestTree
-- test :: String -> Assertion -> TestTree test = testCase
test :: String -> TestTree -> TestTree
test _name = id
-- | Skip the given test(s), with the same type signature as "test".
-- If called in a monadic sequence of tests, also skips following tests. (?)
-- _test :: T.Text -> E.Test a -> E.Test a
-- _test _name = (E.skip >>)
-- | Short equality test constructor. Actual value on the left, expected on the right.
is :: (Eq a, Show a, HasCallStack) => a -> a -> TestTree
is actual expected = testCase "sometest" $ actual @?= expected
-- | Expect True.
expect :: HasCallStack => Bool -> TestTree
expect val = testCase "sometest" $ assertBool "was false" val
-- | Assert equality. Expected first, actual second.
assertEq :: (HasCallStack, Eq a, Show a) => a -> a -> Assertion
assertEq expected actual = assertEqual "was not equal" expected actual
-- | Test for equality. Expected first, actual second.
expectEq :: (HasCallStack, Eq a, Show a) => a -> a -> TestTree
expectEq a b = testCase "sometest" $ assertEq a b
-- | Assert any Left value. -- | Assert any Left value.
assertLeft :: (HasCallStack, Eq b, Show b) => Either a b -> Assertion assertLeft :: (HasCallStack, Eq b, Show b) => Either a b -> Assertion
assertLeft (Left _) = return () assertLeft (Left _) = return ()
assertLeft (Right b) = assertFailure $ "expected Left, got (Right " ++ show b ++ ")" assertLeft (Right b) = assertFailure $ "expected Left, got (Right " ++ show b ++ ")"
-- | Test for any Left value.
expectLeft :: (HasCallStack, Eq a, Show a) => Either e a -> TestTree
expectLeft = testCase "sometest" . assertLeft
-- | Assert any Right value. -- | Assert any Right value.
assertRight :: (HasCallStack, Eq a, Show a) => Either a b -> Assertion assertRight :: (HasCallStack, Eq a, Show a) => Either a b -> Assertion
assertRight (Right _) = return () assertRight (Right _) = return ()
assertRight (Left a) = assertFailure $ "expected Right, got (Left " ++ show a ++ ")" assertRight (Left a) = assertFailure $ "expected Right, got (Left " ++ show a ++ ")"
-- | Test for any Right value. -- | Assert that this stateful parser runnable in IO successfully parses
expectRight :: (HasCallStack, Eq a, Show a) => Either a b -> TestTree
expectRight = testCase "sometest" . assertRight
-- | Test that this stateful parser runnable in IO successfully parses
-- all of the given input text, showing the parse error if it fails. -- all of the given input text, showing the parse error if it fails.
-- Suitable for hledger's JournalParser parsers. -- Suitable for hledger's JournalParser parsers.
-- expectParse :: (Monoid st, Eq a, Show a, HasCallStack) => assertParse :: (HasCallStack, Eq a, Show a, Monoid st) =>
-- StateT st (ParsecT CustomErr T.Text IO) a -> T.Text -> E.Test () StateT st (ParsecT CustomErr T.Text IO) a -> T.Text -> Assertion
expectParse :: (HasCallStack, Eq a, Show a, Monoid st) => assertParse parser input = do
StateT st (ParsecT CustomErr T.Text IO) a -> T.Text -> TestTree
expectParse parser input = testCaseSteps "sometest" $ \_step -> do
ep <- runParserT (evalStateT (parser <* eof) mempty) "" input ep <- runParserT (evalStateT (parser <* eof) mempty) "" input
either (assertFailure.(++"\n").("\nparse error at "++).customErrorBundlePretty) either (assertFailure.(++"\n").("\nparse error at "++).customErrorBundlePretty)
(const $ return ()) (const $ return ())
ep ep
-- -- pretty-printing both if it fails. -- | Assert a parser produces an expected value.
-- | Like expectParse, but also test the parse result is an expected value. assertParseEq :: (HasCallStack, Eq a, Show a, Monoid st) =>
expectParseEq :: (HasCallStack, Eq a, Show a, Monoid st) => StateT st (ParsecT CustomErr T.Text IO) a -> T.Text -> a -> Assertion
StateT st (ParsecT CustomErr T.Text IO) a -> T.Text -> a -> TestTree assertParseEq parser input expected = assertParseEqOn parser input id expected
expectParseEq parser input expected = expectParseEqOn parser input id expected
-- | Like expectParseEq, but transform the parse result with the given function -- | Like assertParseEq, but transform the parse result with the given function
-- before comparing it. -- before comparing it.
expectParseEqOn :: (HasCallStack, Eq b, Show b, Monoid st) => assertParseEqOn :: (HasCallStack, Eq b, Show b, Monoid st) =>
StateT st (ParsecT CustomErr T.Text IO) a -> T.Text -> (a -> b) -> b -> TestTree StateT st (ParsecT CustomErr T.Text IO) a -> T.Text -> (a -> b) -> b -> Assertion
expectParseEqOn parser input f expected = testCaseSteps "sometest" $ \_step -> do assertParseEqOn parser input f expected = do
ep <- runParserT (evalStateT (parser <* eof) mempty) "" input ep <- runParserT (evalStateT (parser <* eof) mempty) "" input
either (assertFailure . (++"\n") . ("\nparse error at "++) . customErrorBundlePretty) either (assertFailure . (++"\n") . ("\nparse error at "++) . customErrorBundlePretty)
(assertEq expected . f) (assertEqual "" expected . f)
ep ep
-- | Test that this stateful parser runnable in IO fails to parse -- | Assert that this stateful parser runnable in IO fails to parse
-- the given input text, with a parse error containing the given string. -- the given input text, with a parse error containing the given string.
expectParseError :: (HasCallStack, Eq a, Show a, Monoid st) => assertParseError :: (HasCallStack, Eq a, Show a, Monoid st) =>
StateT st (ParsecT CustomErr T.Text IO) a -> String -> String -> TestTree StateT st (ParsecT CustomErr T.Text IO) a -> String -> String -> Assertion
expectParseError parser input errstr = testCaseSteps "sometest" $ \_step -> do assertParseError parser input errstr = do
ep <- runParserT (evalStateT parser mempty) "" (T.pack input) ep <- runParserT (evalStateT parser mempty) "" (T.pack input)
case ep of case ep of
Right v -> assertFailure $ "\nparse succeeded unexpectedly, producing:\n" ++ pshow v ++ "\n" Right v -> assertFailure $ "\nparse succeeded unexpectedly, producing:\n" ++ pshow v ++ "\n"
@ -142,13 +110,28 @@ expectParseError parser input errstr = testCaseSteps "sometest" $ \_step -> do
then return () then return ()
else assertFailure $ "\nparse error is not as expected:\n" ++ e' ++ "\n" else assertFailure $ "\nparse error is not as expected:\n" ++ e' ++ "\n"
-- Suitable for hledger's ErroringJournalParser parsers. -- | Run a stateful parser in IO like assertParse, then assert that the
expectParseE -- final state (the wrapped state, not megaparsec's internal state),
-- transformed by the given function, matches the given expected value.
assertParseStateOn :: (HasCallStack, Eq b, Show b, Monoid st) =>
StateT st (ParsecT CustomErr T.Text IO) a
-> T.Text
-> (st -> b)
-> b
-> Assertion
assertParseStateOn parser input f expected = do
es <- runParserT (execStateT (parser <* eof) mempty) "" input
case es of
Left err -> assertFailure $ (++"\n") $ ("\nparse error at "++) $ customErrorBundlePretty err
Right s -> assertEqual "" expected $ f s
-- | These "E" variants of the above are suitable for hledger's ErroringJournalParser parsers.
assertParseE
:: (HasCallStack, Eq a, Show a, Monoid st) :: (HasCallStack, Eq a, Show a, Monoid st)
=> StateT st (ParsecT CustomErr T.Text (ExceptT FinalParseError IO)) a => StateT st (ParsecT CustomErr T.Text (ExceptT FinalParseError IO)) a
-> T.Text -> T.Text
-> TestTree -> Assertion
expectParseE parser input = testCaseSteps "sometest" $ \_step -> do assertParseE parser input = do
let filepath = "" let filepath = ""
eep <- runExceptT $ eep <- runExceptT $
runParserT (evalStateT (parser <* eof) mempty) filepath input runParserT (evalStateT (parser <* eof) mempty) filepath input
@ -161,22 +144,22 @@ expectParseE parser input = testCaseSteps "sometest" $ \_step -> do
(const $ return ()) (const $ return ())
ep ep
expectParseEqE assertParseEqE
:: (Monoid st, Eq a, Show a, HasCallStack) :: (Monoid st, Eq a, Show a, HasCallStack)
=> StateT st (ParsecT CustomErr T.Text (ExceptT FinalParseError IO)) a => StateT st (ParsecT CustomErr T.Text (ExceptT FinalParseError IO)) a
-> T.Text -> T.Text
-> a -> a
-> TestTree -> Assertion
expectParseEqE parser input expected = expectParseEqOnE parser input id expected assertParseEqE parser input expected = assertParseEqOnE parser input id expected
expectParseEqOnE assertParseEqOnE
:: (HasCallStack, Eq b, Show b, Monoid st) :: (HasCallStack, Eq b, Show b, Monoid st)
=> StateT st (ParsecT CustomErr T.Text (ExceptT FinalParseError IO)) a => StateT st (ParsecT CustomErr T.Text (ExceptT FinalParseError IO)) a
-> T.Text -> T.Text
-> (a -> b) -> (a -> b)
-> b -> b
-> TestTree -> Assertion
expectParseEqOnE parser input f expected = testCaseSteps "sometest" $ \_step -> do assertParseEqOnE parser input f expected = do
let filepath = "" let filepath = ""
eep <- runExceptT $ runParserT (evalStateT (parser <* eof) mempty) filepath input eep <- runExceptT $ runParserT (evalStateT (parser <* eof) mempty) filepath input
case eep of case eep of
@ -185,16 +168,16 @@ expectParseEqOnE parser input f expected = testCaseSteps "sometest" $ \_step ->
in assertFailure $ "parse error at " <> prettyErr in assertFailure $ "parse error at " <> prettyErr
Right ep -> Right ep ->
either (assertFailure . (++"\n") . ("\nparse error at "++) . customErrorBundlePretty) either (assertFailure . (++"\n") . ("\nparse error at "++) . customErrorBundlePretty)
(assertEq expected . f) (assertEqual "" expected . f)
ep ep
expectParseErrorE assertParseErrorE
:: (Monoid st, Eq a, Show a, HasCallStack) :: (Monoid st, Eq a, Show a, HasCallStack)
=> StateT st (ParsecT CustomErr T.Text (ExceptT FinalParseError IO)) a => StateT st (ParsecT CustomErr T.Text (ExceptT FinalParseError IO)) a
-> T.Text -> T.Text
-> String -> String
-> TestTree -> Assertion
expectParseErrorE parser input errstr = testCaseSteps "sometest" $ \_step -> do assertParseErrorE parser input errstr = do
let filepath = "" let filepath = ""
eep <- runExceptT $ runParserT (evalStateT parser mempty) filepath input eep <- runExceptT $ runParserT (evalStateT parser mempty) filepath input
case eep of case eep of
@ -210,19 +193,3 @@ expectParseErrorE parser input errstr = testCaseSteps "sometest" $ \_step -> do
if errstr `isInfixOf` e' if errstr `isInfixOf` e'
then return () then return ()
else assertFailure $ "\nparse error is not as expected:\n" ++ e' ++ "\n" else assertFailure $ "\nparse error is not as expected:\n" ++ e' ++ "\n"
-- | Run a stateful parser in IO like expectParse, then compare the
-- final state (the wrapped state, not megaparsec's internal state),
-- transformed by the given function, with the given expected value.
expectParseStateOn :: (HasCallStack, Eq b, Show b, Monoid st) =>
StateT st (ParsecT CustomErr T.Text IO) a
-> T.Text
-> (st -> b)
-> b
-> TestTree
expectParseStateOn parser input f expected = testCaseSteps "sometest" $ \_step -> do
es <- runParserT (execStateT (parser <* eof) mempty) "" input
case es of
Left err -> assertFailure $ (++"\n") $ ("\nparse error at "++) $ customErrorBundlePretty err
Right s -> assertEq expected $ f s

17
hledger-lib/Hledger/Utils/Text.hs
View File

@ -421,13 +421,12 @@ textWidth s = maximum $ map (T.foldr (\a b -> charWidth a + b) 0) $ T.lines s
tests_Text = tests "Text" [ tests_Text = tests "Text" [
tests "quoteIfSpaced" [ testCase "quoteIfSpaced" $ do
quoteIfSpaced "a'a" `is` "a'a" quoteIfSpaced "a'a" @?= "a'a"
,quoteIfSpaced "a\"a" `is` "a\"a" quoteIfSpaced "a\"a" @?= "a\"a"
,quoteIfSpaced "a a" `is` "\"a a\"" quoteIfSpaced "a a" @?= "\"a a\""
,quoteIfSpaced "mimi's cafe" `is` "\"mimi's cafe\"" quoteIfSpaced "mimi's cafe" @?= "\"mimi's cafe\""
,quoteIfSpaced "\"alex\" cafe" `is` "\"\\\"alex\\\" cafe\"" quoteIfSpaced "\"alex\" cafe" @?= "\"\\\"alex\\\" cafe\""
,quoteIfSpaced "le'shan's cafe" `is` "\"le'shan's cafe\"" quoteIfSpaced "le'shan's cafe" @?= "\"le'shan's cafe\""
,quoteIfSpaced "\"be'any's\" cafe" `is` "\"\\\"be'any's\\\" cafe\"" quoteIfSpaced "\"be'any's\" cafe" @?= "\"\\\"be'any's\\\" cafe\""
]
] ]

63
hledger/Hledger/Cli/Commands.hs
View File

@ -267,7 +267,7 @@ testmode = hledgerCommandMode
testcmd :: CliOpts -> Journal -> IO () testcmd :: CliOpts -> Journal -> IO ()
testcmd opts _undefined = do testcmd opts _undefined = do
withArgs (words' $ query_ $ reportopts_ opts) $ withArgs (words' $ query_ $ reportopts_ opts) $
defaultMain $ tests "sometests" [ -- Test.Tasty.defaultMain from Hledger.Util.Tests defaultMain $ tests "hledger" [ -- Test.Tasty.defaultMain from Hledger.Util.Tests
tests_Hledger tests_Hledger
,tests "Hledger.Cli" [ ,tests "Hledger.Cli" [
tests_Cli_Utils tests_Cli_Utils
@ -282,37 +282,44 @@ tests_Commands = tests "Commands" [
-- some more tests easiest to define here: -- some more tests easiest to define here:
,test "apply account directive" $ let ,tests "apply account directive" [
ignoresourcepos j = j{jtxns=map (\t -> t{tsourcepos=nullsourcepos}) (jtxns j)} testCase "works" $ do
sameParse str1 str2 = testCaseSteps "sometest" $ \_step -> do let
j1 <- readJournal def Nothing str1 >>= either error' (return . ignoresourcepos) ignoresourcepos j = j{jtxns=map (\t -> t{tsourcepos=nullsourcepos}) (jtxns j)}
j2 <- readJournal def Nothing str2 >>= either error' (return . ignoresourcepos) sameParse str1 str2 = do
j1 @?= j2{jlastreadtime=jlastreadtime j1, jfiles=jfiles j1} --, jparsestate=jparsestate j1} j1 <- readJournal def Nothing str1 >>= either error' (return . ignoresourcepos)
in sameParse j2 <- readJournal def Nothing str2 >>= either error' (return . ignoresourcepos)
("2008/12/07 One\n alpha $-1\n beta $1\n" <> j1 @?= j2{jlastreadtime=jlastreadtime j1, jfiles=jfiles j1} --, jparsestate=jparsestate j1}
"apply account outer\n2008/12/07 Two\n aigh $-2\n bee $2\n" <> sameParse
"apply account inner\n2008/12/07 Three\n gamma $-3\n delta $3\n" <> ("2008/12/07 One\n alpha $-1\n beta $1\n" <>
"end apply account\n2008/12/07 Four\n why $-4\n zed $4\n" <> "apply account outer\n2008/12/07 Two\n aigh $-2\n bee $2\n" <>
"end apply account\n2008/12/07 Five\n foo $-5\n bar $5\n" "apply account inner\n2008/12/07 Three\n gamma $-3\n delta $3\n" <>
) "end apply account\n2008/12/07 Four\n why $-4\n zed $4\n" <>
("2008/12/07 One\n alpha $-1\n beta $1\n" <> "end apply account\n2008/12/07 Five\n foo $-5\n bar $5\n"
"2008/12/07 Two\n outer:aigh $-2\n outer:bee $2\n" <> )
"2008/12/07 Three\n outer:inner:gamma $-3\n outer:inner:delta $3\n" <> ("2008/12/07 One\n alpha $-1\n beta $1\n" <>
"2008/12/07 Four\n outer:why $-4\n outer:zed $4\n" <> "2008/12/07 Two\n outer:aigh $-2\n outer:bee $2\n" <>
"2008/12/07 Five\n foo $-5\n bar $5\n" "2008/12/07 Three\n outer:inner:gamma $-3\n outer:inner:delta $3\n" <>
) "2008/12/07 Four\n outer:why $-4\n outer:zed $4\n" <>
"2008/12/07 Five\n foo $-5\n bar $5\n"
)
,testCaseSteps "apply account directive should preserve \"virtual\" posting type" $ \_step -> do ,testCase "preserves \"virtual\" posting type" $ do
j <- readJournal def Nothing "apply account test\n2008/12/07 One\n (from) $-1\n (to) $1\n" >>= either error' return j <- readJournal def Nothing "apply account test\n2008/12/07 One\n (from) $-1\n (to) $1\n" >>= either error' return
let p = head $ tpostings $ head $ jtxns j let p = head $ tpostings $ head $ jtxns j
paccount p @?= "test:from" paccount p @?= "test:from"
ptype p @?= VirtualPosting ptype p @?= VirtualPosting
]
,testCaseSteps "account aliases" $ \_step -> do ,testCase "alias directive" $ do
j <- readJournal def Nothing "!alias expenses = equity:draw:personal\n1/1\n (expenses:food) 1\n" >>= either error' return j <- readJournal def Nothing "!alias expenses = equity:draw:personal\n1/1\n (expenses:food) 1\n" >>= either error' return
let p = head $ tpostings $ head $ jtxns j let p = head $ tpostings $ head $ jtxns j
paccount p @?= "equity:draw:personal:food" paccount p @?= "equity:draw:personal:food"
,testCase "Y default year directive" $ do
j <- readJournal def Nothing defaultyear_journal_txt >>= either error' return
tdate (head $ jtxns j) @?= fromGregorian 2009 1 1
,testCase "ledgerAccountNames" $ ,testCase "ledgerAccountNames" $
(ledgerAccountNames ledger7) (ledgerAccountNames ledger7)
@?= @?=
@ -331,10 +338,6 @@ tests_Commands = tests "Commands" [
-- (elideAccountName 20 "aaaaaaaaaaaaaaaaaaaa:aaaaaaaaaaaaaaaaaaaa:aaaaaaaaaaaaaaaaaaaa" -- (elideAccountName 20 "aaaaaaaaaaaaaaaaaaaa:aaaaaaaaaaaaaaaaaaaa:aaaaaaaaaaaaaaaaaaaa"
-- @?= "aa:aa:aaaaaaaaaaaaaa") -- @?= "aa:aa:aaaaaaaaaaaaaa")
,testCaseSteps "default year" $ \_step -> do
j <- readJournal def Nothing defaultyear_journal_txt >>= either error' return
tdate (head $ jtxns j) @?= fromGregorian 2009 1 1
,testCase "show dollars" $ showAmount (usd 1) @?= "$1.00" ,testCase "show dollars" $ showAmount (usd 1) @?= "$1.00"
,testCase "show hours" $ showAmount (hrs 1) @?= "1.00h" ,testCase "show hours" $ showAmount (hrs 1) @?= "1.00h"

9
hledger/Hledger/Cli/Commands/Balance.hs
View File

@ -640,16 +640,17 @@ balanceReportTableAsText ropts = tableAsText ropts showamt
tests_Balance = tests "Balance" [ tests_Balance = tests "Balance" [
tests "balanceReportAsText" [ tests "balanceReportAsText" [
testCaseSteps "unicode in balance layout" $ \_step -> do testCase "unicode in balance layout" $ do
j <- readJournal' "2009/01/01 * медвежья шкура\n расходы:покупки 100\n актив:наличные\n" j <- readJournal' "2009/01/01 * медвежья шкура\n расходы:покупки 100\n актив:наличные\n"
let opts = defreportopts let opts = defreportopts
balanceReportAsText opts (balanceReport opts (queryFromOpts (parsedate "2008/11/26") opts) j) @?= balanceReportAsText opts (balanceReport opts (queryFromOpts (parsedate "2008/11/26") opts) j)
@?=
unlines unlines
[" -100 актив:наличные" [" -100 актив:наличные"
," 100 расходы:покупки" ," 100 расходы:покупки"
,"--------------------" ,"--------------------"
," 0" ," 0"
] ]
] ]
] ]

6
hledger/Hledger/Cli/Commands/Register.hs
View File

@ -194,10 +194,12 @@ postingsReportItemAsText opts preferredamtwidth preferredbalwidth (mdate, mendda
tests_Register = tests "Register" [ tests_Register = tests "Register" [
tests "postingsReportAsText" [ tests "postingsReportAsText" [
testCaseSteps "unicode in register layout" $ \_step -> do testCase "unicode in register layout" $ do
j <- readJournal' "2009/01/01 * медвежья шкура\n расходы:покупки 100\n актив:наличные\n" j <- readJournal' "2009/01/01 * медвежья шкура\n расходы:покупки 100\n актив:наличные\n"
let opts = defreportopts let opts = defreportopts
(postingsReportAsText defcliopts $ postingsReport opts (queryFromOpts (parsedate "2008/11/26") opts) j) @?= unlines (postingsReportAsText defcliopts $ postingsReport opts (queryFromOpts (parsedate "2008/11/26") opts) j)
@?=
unlines
["2009/01/01 медвежья шкура расходы:покупки 100 100" ["2009/01/01 медвежья шкура расходы:покупки 100 100"
," актив:наличные -100 0"] ," актив:наличные -100 0"]
] ]