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
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, ScopedTypeVariables #-}
-- provides Arbitrary instance for Pandoc types
module Tests.Arbitrary ()
where
import Prelude
import Test.QuickCheck.Gen
import Test.QuickCheck.Arbitrary
import Control.Monad (liftM, liftM2)
import Text.Pandoc.Definition
import Text.Pandoc.Shared (normalize, escapeURI)
import Text.Pandoc.Builder
realString :: Gen String
realString = resize 8 $ listOf $ frequency [ (9, elements [' '..'\127'])
, (1, elements ['\128'..'\9999']) ]
arbAttr :: Gen Attr
arbAttr = do
id' <- elements ["","loc"]
classes <- elements [[],["haskell"],["c","numberLines"]]
keyvals <- elements [[],[("start","22")],[("a","11"),("b_2","a b c")]]
return (id',classes,keyvals)
instance Arbitrary Inlines where
arbitrary = liftM (fromList :: [Inline] -> Inlines) arbitrary
instance Arbitrary Blocks where
arbitrary = liftM (fromList :: [Block] -> Blocks) arbitrary
instance Arbitrary Inline where
arbitrary = resize 3 $ arbInline 2
arbInlines :: Int -> Gen [Inline]
arbInlines n = listOf1 (arbInline n) `suchThat` (not . startsWithSpace)
where startsWithSpace (Space:_) = True
startsWithSpace _ = False
-- restrict to 3 levels of nesting max; otherwise we get
-- bogged down in indefinitely large structures
arbInline :: Int -> Gen Inline
arbInline n = frequency $ [ (60, liftM Str realString)
, (60, return Space)
, (10, liftM2 Code arbAttr realString)
, (5, elements [ RawInline (Format "html") "<a id=\"eek\">"
, RawInline (Format "latex") "\\my{command}" ])
] ++ [ x | x <- nesters, n > 1]
where nesters = [ (10, liftM Emph $ arbInlines (n-1))
, (10, liftM Strong $ arbInlines (n-1))
, (10, liftM Strikeout $ arbInlines (n-1))
, (10, liftM Superscript $ arbInlines (n-1))
, (10, liftM Subscript $ arbInlines (n-1))
, (10, liftM SmallCaps $ arbInlines (n-1))
, (10, do x1 <- arbitrary
x2 <- arbInlines (n-1)
return $ Quoted x1 x2)
, (10, do x1 <- arbitrary
x2 <- realString
return $ Math x1 x2)
, (10, do x1 <- arbInlines (n-1)
x3 <- realString
x2 <- liftM escapeURI realString
return $ Link x1 (x2,x3))
, (10, do x1 <- arbInlines (n-1)
x3 <- realString
x2 <- liftM escapeURI realString
return $ Image x1 (x2,x3))
, (2, liftM2 Cite arbitrary (arbInlines 1))
, (2, liftM Note $ resize 3 $ listOf1 $ arbBlock (n-1))
]
instance Arbitrary Block where
arbitrary = resize 3 $ arbBlock 2
arbBlock :: Int -> Gen Block
arbBlock n = frequency $ [ (10, liftM Plain $ arbInlines (n-1))
, (15, liftM Para $ arbInlines (n-1))
, (5, liftM2 CodeBlock arbAttr realString)
, (2, elements [ RawBlock (Format "html")
"<div>\n*&*\n</div>"
, RawBlock (Format "latex")
"\\begin[opt]{env}\nhi\n{\\end{env}"
])
, (5, do x1 <- choose (1 :: Int, 6)
x2 <- arbInlines (n-1)
return (Header x1 nullAttr x2))
, (2, return HorizontalRule)
] ++ [x | x <- nesters, n > 0]
where nesters = [ (5, liftM BlockQuote $ listOf1 $ arbBlock (n-1))
, (5, do x2 <- arbitrary
x3 <- arbitrary
x1 <- arbitrary `suchThat` (> 0)
x4 <- listOf1 $ listOf1 $ arbBlock (n-1)
return $ OrderedList (x1,x2,x3) x4 )
, (5, liftM BulletList $ (listOf1 $ listOf1 $ arbBlock (n-1)))
, (5, do items <- listOf1 $ do
x1 <- listOf1 $ listOf1 $ arbBlock (n-1)
x2 <- arbInlines (n-1)
return (x2,x1)
return $ DefinitionList items)
, (2, do rs <- choose (1 :: Int, 4)
cs <- choose (1 :: Int, 4)
x1 <- arbInlines (n-1)
x2 <- vector cs
x3 <- vectorOf cs $ elements [0, 0.25]
x4 <- vectorOf cs $ listOf $ arbBlock (n-1)
x5 <- vectorOf rs $ vectorOf cs
$ listOf $ arbBlock (n-1)
return (Table x1 x2 x3 x4 x5))
]
instance Arbitrary Pandoc where
arbitrary = resize 8 $ liftM normalize
$ liftM2 Pandoc arbitrary arbitrary
instance Arbitrary CitationMode where
arbitrary
= do x <- choose (0 :: Int, 2)
case x of
0 -> return AuthorInText
1 -> return SuppressAuthor
2 -> return NormalCitation
_ -> error "FATAL ERROR: Arbitrary instance, logic bug"
instance Arbitrary Citation where
arbitrary
= do x1 <- listOf $ elements $ ['a'..'z'] ++ ['0'..'9'] ++ ['_']
x2 <- arbInlines 1
x3 <- arbInlines 1
x4 <- arbitrary
x5 <- arbitrary
x6 <- arbitrary
return (Citation x1 x2 x3 x4 x5 x6)
instance Arbitrary MathType where
arbitrary
= do x <- choose (0 :: Int, 1)
case x of
0 -> return DisplayMath
1 -> return InlineMath
_ -> error "FATAL ERROR: Arbitrary instance, logic bug"
instance Arbitrary QuoteType where
arbitrary
= do x <- choose (0 :: Int, 1)
case x of
0 -> return SingleQuote
1 -> return DoubleQuote
_ -> error "FATAL ERROR: Arbitrary instance, logic bug"
instance Arbitrary Meta where
arbitrary
= do (x1 :: Inlines) <- arbitrary
(x2 :: [Inlines]) <- liftM (filter (not . isNull)) arbitrary
(x3 :: Inlines) <- arbitrary
return $ setMeta "title" x1
$ setMeta "author" x2
$ setMeta "date" x3
$ nullMeta
instance Arbitrary Alignment where
arbitrary
= do x <- choose (0 :: Int, 3)
case x of
0 -> return AlignLeft
1 -> return AlignRight
2 -> return AlignCenter
3 -> return AlignDefault
_ -> error "FATAL ERROR: Arbitrary instance, logic bug"
instance Arbitrary ListNumberStyle where
arbitrary
= do x <- choose (0 :: Int, 6)
case x of
0 -> return DefaultStyle
1 -> return Example
2 -> return Decimal
3 -> return LowerRoman
4 -> return UpperRoman
5 -> return LowerAlpha
6 -> return UpperAlpha
_ -> error "FATAL ERROR: Arbitrary instance, logic bug"
instance Arbitrary ListNumberDelim where
arbitrary
= do x <- choose (0 :: Int, 3)
case x of
0 -> return DefaultDelim
1 -> return Period
2 -> return OneParen
3 -> return TwoParens
_ -> error "FATAL ERROR: Arbitrary instance, logic bug"
|
