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

another parse test helper, use the IO variant always, port more tests

Browse Source
This commit is contained in:
Simon Michael 2018-08-19 19:01:20 +01:00
parent 3e6159e632
commit 89357bb7b6
2 changed files with 94 additions and 67 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -541,21 +541,22 @@ transactionp = do
return $ txnTieKnot $ Transaction 0 sourcepos date edate status code description comment tags postings "" return $ txnTieKnot $ Transaction 0 sourcepos date edate status code description comment tags postings ""
-- old HUnit tests -- old HUnit tests
test_transactionp = TestCase $ do test_transactionp =
let s `gives` t = do let s `gives` t = do
let p = runIdentity $ parseWithState mempty transactionp s let p = runIdentity $ parseWithState mempty transactionp s
assertBool "Parse success" (isRight p) assertBool "Parse success" (isRight p)
let Right t2 = p let Right t2 = p
-- same f = assertEqual (f t) (f t2) -- same f = assertEqual (f t) (f t2)
assertEqual "Equal date" (tdate t) (tdate t2) assertEqual "Equal date" (tdate t) (tdate t2)
assertEqual "Equal date2" (tdate2 t) (tdate2 t2) assertEqual "Equal date2" (tdate2 t) (tdate2 t2)
assertEqual "Equal status" (tstatus t) (tstatus t2) assertEqual "Equal status" (tstatus t) (tstatus t2)
assertEqual "Equal code" (tcode t) (tcode t2) assertEqual "Equal code" (tcode t) (tcode t2)
assertEqual "Equal description" (tdescription t) (tdescription t2) assertEqual "Equal description" (tdescription t) (tdescription t2)
assertEqual "Equal comment" (tcomment t) (tcomment t2) assertEqual "Equal comment" (tcomment t) (tcomment t2)
assertEqual "Equal tags" (ttags t) (ttags t2) assertEqual "Equal tags" (ttags t) (ttags t2)
assertEqual "Equal preceding comments" (tpreceding_comment_lines t) (tpreceding_comment_lines t2) assertEqual "Equal preceding comments" (tpreceding_comment_lines t) (tpreceding_comment_lines t2)
assertEqual "Equal postings" (tpostings t) (tpostings t2) assertEqual "Equal postings" (tpostings t) (tpostings t2)
in TestCase $ do
T.unlines ["2015/1/1"] `gives` nulltransaction{ tdate=parsedate "2015/01/01" } T.unlines ["2015/1/1"] `gives` nulltransaction{ tdate=parsedate "2015/01/01" }
@ -622,7 +623,7 @@ test_transactionp = TestCase $ do
assertBool "transactionp parses parses comments anywhere" (isRight p) assertBool "transactionp parses parses comments anywhere" (isRight p)
assertEqual "Has 2 postings" 2 (let Right t = p in length $ tpostings t) assertEqual "Has 2 postings" 2 (let Right t = p in length $ tpostings t)
-- new easytest tests, for comparison -- the above as easytests, just for comparison
transactionp_tests = tests "transactionp" [ transactionp_tests = tests "transactionp" [
test "just-a-date" $ expectParseEq transactionp "2015/1/1\n" nulltransaction{tdate=parsedate "2015/01/01"} test "just-a-date" $ expectParseEq transactionp "2015/1/1\n" nulltransaction{tdate=parsedate "2015/01/01"}
@ -661,35 +662,36 @@ transactionp_tests = tests "transactionp" [
] ]
} }
,it "parses a well-formed transaction" $ ,test "parses a well-formed transaction" $
expect $ isRight $ rjp transactionp $ T.unlines expect $ 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"
,"" ,""
] ]
-- ,it "does not parse a following comment as part of the description" ,test "does not parse a following comment as part of the description" $
-- let p = runIdentity $ parseWithState mempty transactionp "2009/1/1 a ;comment\n b 1\n" expectParseEqOn transactionp "2009/1/1 a ;comment\n b 1\n" tdescription "a"
-- (Right "a") (tdescription <$> p)
-- assertBool "transactionp parses a following whitespace line" $ ,test "transactionp parses a following whitespace line" $
-- isRight . runIdentity . parseWithState mempty transactionp $ T.unlines expect $ isRight $ rjp transactionp $ T.unlines
-- ["2012/1/1" ["2012/1/1"
-- ," a 1" ," a 1"
-- ," b" ," b"
-- ," " ," "
-- ] ]
--
-- let p = runIdentity . parseWithState mempty transactionp $ T.unlines ,test "comments everywhere, two postings parsed" $
-- ["2009/1/1 x ; transaction comment" expectParseEqOn transactionp
-- ," a 1 ; posting 1 comment" (T.unlines
-- ," ; posting 1 comment 2" ["2009/1/1 x ; transaction comment"
-- ," b" ," a 1 ; posting 1 comment"
-- ," ; posting 2 comment" ," ; posting 1 comment 2"
-- ] ," b"
-- assertBool "transactionp parses parses comments anywhere" (isRight p) ," ; posting 2 comment"
-- assertEqual "Has 2 postings" 2 (let Right t = p in length $ tpostings t) ])
(length . tpostings)
2
] ]
@ -870,18 +872,21 @@ tests_Hledger_Read_JournalReader = TestList [
] ]
easytests = tests "JournalReader" [ easytests = tests "JournalReader" [
tests "transactionmodifierp" [ tests "transactionmodifierp" [
test "transactionmodifierp" $ expectParseEqIO transactionmodifierp
test "basic" $ expectParseEq 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)"
,tmpostings = [nullposting{paccount="some:postings", pamount=Mixed[num 1]}] ,tmpostings = [nullposting{paccount="some:postings", pamount=Mixed[num 1]}]
} }
] ]
,tests "periodictransactionp" [ ,tests "periodictransactionp" [
-- tests from #807 -- tests from #807
test "more-period-text-in-comment-after-one-space" $ expectParseEqIO periodictransactionp test "more-period-text-in-comment-after-one-space" $ expectParseEq 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"
@ -895,7 +900,7 @@ easytests = tests "JournalReader" [
,ptpostings = [] ,ptpostings = []
} }
,_test "more-period-text-in-description-after-two-spaces" $ expectParseEqIO periodictransactionp -- TODO ,_test "more-period-text-in-description-after-two-spaces" $ expectParseEq periodictransactionp -- TODO
"~ 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"
@ -904,7 +909,7 @@ easytests = tests "JournalReader" [
,ptdescription = "In 2019 we will change this\n" ,ptdescription = "In 2019 we will change this\n"
} }
,_test "more-period-text-in-description-after-one-space" $ expectParseEqIO periodictransactionp -- TODO ,_test "more-period-text-in-description-after-one-space" $ expectParseEq periodictransactionp -- TODO
"~ 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"
@ -913,7 +918,7 @@ easytests = tests "JournalReader" [
,ptdescription = "In 2019 we will change this\n" ,ptdescription = "In 2019 we will change this\n"
} }
,_test "Next-year-in-description" $ expectParseEqIO periodictransactionp -- TODO read error ,_test "Next-year-in-description" $ expectParseEq periodictransactionp -- TODO read error
"~ monthly Next year blah blah\n" "~ monthly Next year blah blah\n"
nullperiodictransaction { nullperiodictransaction {
ptperiodexpr = "monthly" ptperiodexpr = "monthly"
@ -923,5 +928,6 @@ easytests = tests "JournalReader" [
} }
,transactionp_tests ,transactionp_tests
] ]
] ]

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

@ -13,7 +13,9 @@ module Hledger.Utils.Test (
,it ,it
,_it ,_it
,expectParseEq ,expectParseEq
,expectParseEqIO ,expectParseEqOn
-- ,expectParseEq
-- ,expectParseEqOnIO
-- * HUnit -- * HUnit
,module Test.HUnit ,module Test.HUnit
,runHunitTests ,runHunitTests
@ -47,7 +49,6 @@ import Test.HUnit hiding (Test, test) -- reexported
import qualified Test.HUnit as U -- used here import qualified Test.HUnit as U -- used here
import Hledger.Utils.Debug (pshow) import Hledger.Utils.Debug (pshow)
import Hledger.Utils.Parse (parseWithState)
import Hledger.Utils.UTF8IOCompat (error') import Hledger.Utils.UTF8IOCompat (error')
-- * easytest helpers -- * easytest helpers
@ -94,27 +95,47 @@ runEasyTests args easytests = (do
) )
`catch` (\(_::ExitCode) -> return True) `catch` (\(_::ExitCode) -> return True)
-- | Given a stateful, runnable-in-Identity-monad parser, input text, and expected parse result, -- | Like easytest's expectEq, but pretty-prints the values in the failure output.
-- make an easytest Test that parses the text and compares the result,
-- showing a nice failure message if either step fails.
expectParseEq :: (Monoid st, Eq a, Show a) => StateT st (ParsecT CustomErr T.Text Identity) a -> T.Text -> a -> E.Test ()
expectParseEq parser input expected = do
let ep = runIdentity $ parseWithState mempty parser input
either (fail.("parse error at "++).parseErrorPretty) (expectEq' expected) ep
-- | Given a stateful, runnable-in-IO-monad parser, input text, and expected parse result,
-- make an easytest Test that parses the text and compares the result,
-- showing a nice failure message if either step fails.
expectParseEqIO :: (Monoid st, Eq a, Show a) => StateT st (ParsecT CustomErr T.Text IO) a -> T.Text -> a -> E.Test ()
expectParseEqIO parser input expected = do
ep <- E.io $ runParserT (evalStateT parser mempty) "" input
either (fail.("parse error at "++).parseErrorPretty) (expectEq' expected) ep
-- | Like easytest's expectEq, but pretty-prints the values in failure output.
expectEq' :: (Eq a, Show a, HasCallStack) => a -> a -> E.Test () expectEq' :: (Eq a, Show a, HasCallStack) => a -> a -> E.Test ()
expectEq' x y = if x == y then E.ok else E.crash $ expectEq' x y = if x == y then E.ok else E.crash $
"expected:\n" <> T.pack (pshow x) <> "\nbut got:\n" <> T.pack (pshow y) <> "\n" "expected:\n" <> T.pack (pshow x) <> "\nbut got:\n" <> T.pack (pshow y) <> "\n"
-- XXX unnecessary ?
-- | Given a stateful, runnable-in-Identity-monad parser, input text, and
-- expected parse result, make a Test that parses the text and compares
-- the result, showing a nice failure message if either step fails.
--expectParseEq :: (Monoid st, Eq a, Show a, HasCallStack) =>
-- StateT st (ParsecT CustomErr T.Text Identity) a -> T.Text -> a -> E.Test ()
--expectParseEq parser input expected = expectParseEqOn parser input id expected
--
-- | Like expectParseEq, but also takes a transform function
-- to call on the parse result before comparing it.
--expectParseEqOn :: (Monoid st, Eq b, Show b, HasCallStack) =>
-- StateT st (ParsecT CustomErr T.Text Identity) a -> T.Text -> (a -> b) -> b -> E.Test ()
--expectParseEqOn parser input f expected = do
-- let ep = runIdentity $ parseWithState mempty parser input
-- either (fail.("parse error at "++).parseErrorPretty) (expectEq' expected . f) ep
--
expectParseEq :: (Monoid st, Eq a, Show a, HasCallStack) =>
StateT st (ParsecT CustomErr T.Text IO) a -> T.Text -> a -> E.Test ()
expectParseEq = expectParseEqIO
expectParseEqOn :: (Monoid st, Eq b, Show b, HasCallStack) =>
StateT st (ParsecT CustomErr T.Text IO) a -> T.Text -> (a -> b) -> b -> E.Test ()
expectParseEqOn = expectParseEqOnIO
-- | Like expectParseEq, but takes a parser runnable in the IO monad.
expectParseEqIO :: (Monoid st, Eq a, Show a, HasCallStack) =>
StateT st (ParsecT CustomErr T.Text IO) a -> T.Text -> a -> E.Test ()
expectParseEqIO parser input expected = expectParseEqOnIO parser input id expected
-- | Like expectParseEqOn, but takes a parser runnable in the IO monad.
expectParseEqOnIO :: (Monoid st, Eq b, Show b, HasCallStack) =>
StateT st (ParsecT CustomErr T.Text IO) a -> T.Text -> (a -> b) -> b -> E.Test ()
expectParseEqOnIO parser input f expected = do
ep <- E.io $ runParserT (evalStateT parser mempty) "" input
either (fail.("parse error at "++).parseErrorPretty) (expectEq' expected . f) ep
-- * HUnit helpers -- * HUnit helpers
-- | Get a Test's label, or the empty string. -- | Get a Test's label, or the empty string.