@@ -1,39 +1,74 @@
1−{-# LANGUAGE TypeSynonymInstances #-}
1+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, TemplateHaskell #-}
22-- Utility functions for the test suite.
33
44module Tests.Helpers where
55
6−import Text.Pandoc
7−import Text.Pandoc.Builder
6+import Text.Pandoc.Definition
7+import Text.Pandoc.Builder (Inlines, Blocks, doc, plain)
88import Test.Framework
99import Test.Framework.Providers.HUnit
1010import Test.HUnit hiding (Test)
11+import Text.Pandoc.Shared (normalize, defaultWriterOptions,
12+ WriterOptions(..), removeTrailingSpace)
13+import Text.Pandoc.Writers.Native (writeNative)
14+import Language.Haskell.TH.Quote
1115
12−infix 8 -->
16+lit :: QuasiQuoter
17+lit = QuasiQuoter ((\a -> let b = rnl a in [|b|]) . filter (/= '\r')) $
18+ error "Cannot use lit as a pattern"
19+ where rnl ('\n':xs) = xs
20+ rnl xs = xs
1321
14−(-->) :: (Eq a, Show a, Show b) => (b, a) -> a -> Assertion
15−(b,a) --> e = assertEqual (show b) e a
22+test :: (ToString a, ToString b, ToString c)
23+ => (a -> b) -- ^ function to test
24+ -> String -- ^ name of test case
25+ -> (a, c) -- ^ (input, expected value)
26+ -> Test
27+test fn name (input, expected) =
28+ testCase name $ assertBool msg (actual' == expected')
29+ where msg = dashes "input" ++ input' ++
30+ dashes "expected" ++ expected' ++
31+ dashes "got" ++ actual' ++
32+ dashes ""
33+ input' = toString input
34+ actual' = toString $ fn input
35+ expected' = toString expected
36+ dashes "" = '\n' : replicate 72 '-'
37+ dashes x = '\n' : replicate (72 - length x - 5) '-' ++ " " ++
38+ x ++ " ---\n"
1639
17−-- In the first argument, the String is the input, and the Pandoc
18−-- the output, of a pandoc reader. The input is shown in case
19−-- the test fails.
20−class Expect a where
21− (=?>) :: (String, Pandoc) -> a -> Assertion
40+infix 6 =?>
41+(=?>) :: a -> b -> (a,b)
42+x =?> y = (x, y)
2243
23−infix 8 =?>
44+class ToString a where
45+ toString :: a -> String
2446
25−(=:) :: TestName -> Assertion -> Test
26−(=:) = testCase
47+instance ToString Pandoc where
48+ toString d = writeNative defaultWriterOptions{ writerStandalone = s }
49+ $ toPandoc d
50+ where s = case d of
51+ (Pandoc (Meta [] [] []) _) -> False
52+ _ -> True
2753
28−infix 6 =:
54+instance ToString Blocks where
55+ toString = writeNative defaultWriterOptions . toPandoc
2956
30−instance Expect Inlines where
31− (s, Pandoc _ [Para ils]) =?> e = assertEqual (show s) (toList e) ils
32− (s, g) =?> e = assertEqual (show s) (doc $ para e) g
57+instance ToString Inlines where
58+ toString = removeTrailingSpace . writeNative defaultWriterOptions .
59+ toPandoc
3360
34−instance Expect Blocks where
35− (s, Pandoc _ bls) =?> e = assertEqual (show s) (toList e) bls
61+instance ToString String where
62+ toString = id
3663
37−instance Expect Pandoc where
38− (s, g) =?> e = assertEqual (show s) e g
64+class ToPandoc a where
65+ toPandoc :: a -> Pandoc
3966
67+instance ToPandoc Pandoc where
68+ toPandoc = normalize
69+
70+instance ToPandoc Blocks where
71+ toPandoc = normalize . doc
72+
73+instance ToPandoc Inlines where
74+ toPandoc = normalize . doc . plain