1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
|
{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, TemplateHaskell #-}
-- Utility functions for the test suite.
module Tests.Helpers ( lit
, file
, test
, (=?>)
, property
, ToString(..)
, ToPandoc(..)
)
where
import Text.Pandoc.Definition
import Text.Pandoc.Builder (Inlines, Blocks, doc, plain)
import Test.Framework
import Test.Framework.Providers.HUnit
import Test.Framework.Providers.QuickCheck2
import Test.HUnit (assertBool)
import Text.Pandoc.Shared (normalize, defaultWriterOptions,
WriterOptions(..), removeTrailingSpace)
import Text.Pandoc.Writers.Native (writeNative)
import Language.Haskell.TH.Quote (QuasiQuoter(..))
import Language.Haskell.TH.Syntax (Q, runIO)
import qualified Test.QuickCheck.Property as QP
import System.Console.ANSI
import Data.Algorithm.Diff
lit :: QuasiQuoter
lit = QuasiQuoter {
quoteExp = (\a -> let b = rnl a in [|b|]) . filter (/= '\r')
, quotePat = error "Cannot use lit as a pattern"
}
where rnl ('\n':xs) = xs
rnl xs = xs
file :: QuasiQuoter
file = quoteFile lit
-- adapted from TH 2.5 code
quoteFile :: QuasiQuoter -> QuasiQuoter
quoteFile (QuasiQuoter { quoteExp = qe, quotePat = qp }) =
QuasiQuoter { quoteExp = get qe, quotePat = get qp }
where
get :: (String -> Q a) -> String -> Q a
get old_quoter file_name = do { file_cts <- runIO (readFile file_name)
; old_quoter file_cts }
test :: (ToString a, ToString b, ToString c)
=> (a -> b) -- ^ function to test
-> String -- ^ name of test case
-> (a, c) -- ^ (input, expected value)
-> Test
test fn name (input, expected) =
testCase name $ assertBool msg (actual' == expected')
where msg = nl ++ dashes "input" ++ nl ++ input' ++ nl ++
dashes "expected" ++ nl ++ expected'' ++
dashes "got" ++ nl ++ actual'' ++
dashes ""
nl = "\n"
input' = toString input
actual' = toString $ fn input
expected' = toString expected
diff = getDiff (lines expected') (lines actual')
expected'' = unlines $ map vividize $ filter (\(d,_) -> d /= S) diff
actual'' = unlines $ map vividize $ filter (\(d,_) -> d /= F) diff
dashes "" = replicate 72 '-'
dashes x = replicate (72 - length x - 5) '-' ++ " " ++ x ++ " ---"
vividize :: (DI,String) -> String
vividize (B,s) = s
vividize (_,s) = vivid s
property :: QP.Testable a => TestName -> a -> Test
property = testProperty
vivid :: String -> String
vivid s = setSGRCode [SetColor Background Dull Red
, SetColor Foreground Vivid White] ++ s
++ setSGRCode [Reset]
infix 6 =?>
(=?>) :: a -> b -> (a,b)
x =?> y = (x, y)
class ToString a where
toString :: a -> String
instance ToString Pandoc where
toString d = writeNative defaultWriterOptions{ writerStandalone = s }
$ toPandoc d
where s = case d of
(Pandoc (Meta [] [] []) _) -> False
_ -> True
instance ToString Blocks where
toString = writeNative defaultWriterOptions . toPandoc
instance ToString Inlines where
toString = removeTrailingSpace . writeNative defaultWriterOptions .
toPandoc
instance ToString String where
toString = id
class ToPandoc a where
toPandoc :: a -> Pandoc
instance ToPandoc Pandoc where
toPandoc = normalize
instance ToPandoc Blocks where
toPandoc = normalize . doc
instance ToPandoc Inlines where
toPandoc = normalize . doc . plain
|
