Restructure code base.
[packages/pretty.git] / test / Test.hs
1 {-# OPTIONS -XStandaloneDeriving -XDeriveDataTypeable -XPackageImports #-}
2 -----------------------------------------------------------------------------
3 -- Module : HughesPJQuickCheck
4 -- Copyright : (c) 2008 Benedikt Huber
5 -- License : BSD-style
6 --
7 -- QuickChecks for HughesPJ pretty printer.
8 --
9 -- 1) Testing laws (blackbox)
10 -- - CDoc (combinator datatype)
11 -- 2) Testing invariants (whitebox)
12 -- 3) Testing bug fixes (whitebox)
13 --
14 -----------------------------------------------------------------------------
15 import {- whitebox -} PrettyTestVersion
16
17 import Test.QuickCheck
18 import Control.Monad
19 import Debug.Trace
20 import Data.Char (isSpace)
21 import Data.List (intersperse)
22
23 -- tweaked to perform many small tests
24 myConfig :: Int -> Int -> Config
25 myConfig d n = defaultConfig { configMaxTest = n, configMaxFail = n*5, configSize = (+2) . (`div` n) . (*d) }
26
27 myTest :: (Testable a) => String -> a -> IO ()
28 myTest = myTest' 15 maxTests
29 maxTests = 1000
30 myTest' :: (Testable a) => Int -> Int -> String -> a -> IO ()
31 myTest' d k msg t = putStrLn (" * "++msg) >> check (myConfig d k) t
32
33 myAssert :: String -> Bool -> IO ()
34 myAssert msg b = putStrLn $ (if b then "Ok, passed " else "Failed test:\n ")++msg
35
36 main :: IO ()
37 main = do
38 check_laws
39 check_invariants
40 check_improvements
41 check_non_prims -- hpc full coverage
42 check_rendering
43 check_list_def
44
45
46 -- Additional HPC misses:
47 -- mkNest _ NoDoc = NoDoc
48
49
50 -- Quickcheck tests
51
52 -- Equalities on Documents
53 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
54
55 -- compare text details
56 tdEq :: TextDetails -> TextDetails -> Bool
57 tdEq td1 td2 = (tdToStr td1) == (tdToStr td2)
58
59 -- algebraic equality on reduced docs
60 docEq :: RDoc -> RDoc -> Bool
61 docEq rd1 rd2 = case (rd1, rd2) of
62 (Empty, Empty) -> True
63 (NoDoc, NoDoc) -> True
64 (NilAbove ds1, NilAbove ds2) -> docEq ds1 ds2
65 (TextBeside td1 l1 ds1, TextBeside td2 l2 ds2) | td1 `tdEq` td2 -> docEq ds1 ds2
66 (Nest k1 d1, Nest k2 d2) | k1 == k2 -> docEq d1 d2
67 (Union d11 d12, Union d21 d22) -> docEq d11 d21 && docEq d12 d22
68 (d1,d2) -> False
69
70 -- algebraic equality, with text reduction
71 deq :: Doc -> Doc -> Bool
72 deq d1 d2 = docEq (reduceDoc' d1) (reduceDoc' d2) where
73 reduceDoc' = mergeTexts . reduceDoc
74 deqs :: [Doc] -> [Doc] -> Bool
75 deqs ds1 ds2 =
76 case zipE ds1 ds2 of
77 Nothing -> False
78 (Just zds) -> all (uncurry deq) zds
79
80
81 zipLayouts :: Doc -> Doc -> Maybe [(Doc,Doc)]
82 zipLayouts d1 d2 = zipE (reducedDocs d1) (reducedDocs d2)
83 where
84 reducedDocs = map mergeTexts . flattenDoc
85 zipE l1 l2 | length l1 == length l2 = Just $ zip l1 l2
86 | otherwise = Nothing
87
88 -- algebraic equality for layouts (without permutations)
89 lseq :: Doc -> Doc -> Bool
90 lseq d1 d2 = maybe False id . fmap (all (uncurry docEq)) $ zipLayouts d1 d2
91
92 -- abstract render equality for layouts
93 -- should only be performed if the number of layouts is reasonably small
94 rdeq :: Doc -> Doc -> Bool
95 rdeq d1 d2 =
96 maybe False id . fmap (all (uncurry layoutEq)) $ zipLayouts d1 d2
97 where
98 layoutEq d1 d2 = (abstractLayout d1) == (abstractLayout d2)
99
100 layoutsCountBounded :: Int -> [Doc] -> Bool
101 layoutsCountBounded k docs = isBoundedBy k (concatMap flattenDoc docs) where
102 isBoundedBy k [] = True
103 isBoundedBy 0 (x:xs) = False
104 isBoundedBy k (x:xs) = isBoundedBy (k-1) xs
105 layoutCountBounded :: Int -> Doc -> Bool
106 layoutCountBounded k doc = layoutsCountBounded k [doc]
107 maxLayouts :: Int
108 maxLayouts = 64
109
110 infix 4 `deq`
111 infix 4 `lseq`
112 infix 4 `rdeq`
113
114 debugRender :: Int -> Doc -> IO ()
115 debugRender k = putStr . visibleSpaces . renderStyle (Style PageMode k 1)
116 visibleSpaces = unlines . map (map visibleSpace) . lines
117
118 visibleSpace :: Char -> Char
119 visibleSpace ' ' = '.'
120 visibleSpace '.' = error "dot in visibleSpace (avoid confusion, please)"
121 visibleSpace c = c
122
123 -- shorthands debug functions
124 pd = (print.prettyDoc)
125 pds = mapM_ pd
126 rds = (map mergeTexts.flattenDoc)
127
128
129 -- (1) QuickCheck Properties: Laws
130 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~
131
132 {-
133 Monoid laws for <>,<+>,$$,$+$
134 ~~~~~~~~~~~~~
135 <a,b 1> (x * y) * z = x * (y * z)
136 <a,b 2> empty * x = x
137 <a,b 3> x * empty = x
138 -}
139 prop_1 op x y z = classify (any isEmpty [x,y,z]) "empty x, y or z" $
140 ((x `op` y) `op` z) `deq` (x `op` (y `op` z))
141 prop_2 op x = classify (isEmpty x) "empty" $ (empty `op` x) `deq` x
142 prop_3 op x = classify (isEmpty x) "empty" $ x `deq` (empty `op` x)
143
144 check_monoid = do
145 putStrLn " = Monoid Laws ="
146 mapM_ (myTest' 5 maxTests "Associativity") [ liftDoc3 (prop_1 op) | op <- allops ]
147 mapM_ (myTest "Left neutral") [ prop_2 op . buildDoc | op <- allops ]
148 mapM_ (myTest "Right neutral") [ prop_3 op . buildDoc | op <- allops ]
149 where
150 allops = [ (<>), (<+>) ,($$) , ($+$) ]
151
152 {-
153 Laws for text
154 ~~~~~~~~~~~~~
155 <t1> text s <> text t = text (s++t)
156 <t2> text "" <> x = x, if x non-empty [only true if x does not start with nest, because of <n6> ]
157 -}
158 prop_t1 s t = text' s <> text' t `deq` text (unText s ++ unText t)
159 prop_t2 x = not (isEmpty x) ==> text "" <> x `deq` x
160 prop_t2_a x = not (isEmpty x) && not (isNest x) ==> text "" <> x `deq` x
161
162 isNest :: Doc -> Bool
163 isNest d = case reduceDoc d of
164 (Nest _ _) -> True
165 (Union d1 d2) -> isNest d1 || isNest d2
166 _ -> False
167
168 check_t = do
169 putStrLn " = Text laws ="
170 myTest "t1" prop_t1
171 myTest "t2_a (precondition: x does not start with nest)" (prop_t2_a . buildDoc)
172 myTest "t_2 (Known to fail)" (prop_t2 . buildDoc)
173
174 {-
175 Laws for nest
176 ~~~~~~~~~~~~~
177 <n1> nest 0 x = x
178 <n2> nest k (nest k' x) = nest (k+k') x
179 <n3> nest k (x <> y) = nest k z <> nest k y
180 <n4> nest k (x $$ y) = nest k x $$ nest k y
181 <n5> nest k empty = empty
182 <n6> x <> nest k y = x <> y, if x non-empty
183 -}
184 prop_n1 x = nest 0 x `deq` x
185 prop_n2 k k' x = nest k (nest k' x) `deq` nest (k+k') x
186 prop_n3 k k' x = nest k (nest k' x) `deq` nest (k+k') x
187 prop_n4 k x y = nest k (x $$ y) `deq` nest k x $$ nest k y
188 prop_n5 k = nest k empty `deq` empty
189 prop_n6 x k y = not (isEmpty x) ==>
190 x <> nest k y `deq` x <> y
191 check_n = do
192 putStrLn "Nest laws"
193 myTest "n1" (prop_n1 . buildDoc)
194 myTest "n2" (\k k' -> prop_n2 k k' . buildDoc)
195 myTest "n3" (\k k' -> prop_n3 k k' . buildDoc)
196 myTest "n4" (\k -> liftDoc2 (prop_n4 k))
197 myTest "n5" prop_n5
198 myTest "n6" (\k -> liftDoc2 (\x -> prop_n6 x k))
199
200 {-
201 <m1> (text s <> x) $$ y = text s <> ((text "" <> x)) $$
202 nest (-length s) y)
203
204 <m2> (x $$ y) <> z = x $$ (y <> z)
205 if y non-empty
206 -}
207 prop_m1 s x y = (text' s <> x) $$ y `deq` text' s <> ((text "" <> x) $$
208 nest (-length (unText s)) y)
209 prop_m2 x y z = not (isEmpty y) ==>
210 (x $$ y) <> z `deq` x $$ (y <> z)
211 check_m = do
212 putStrLn "Misc laws"
213 myTest "m1" (\s -> liftDoc2 (prop_m1 s))
214 myTest' 10 maxTests "m2" (liftDoc3 prop_m2)
215
216
217 {-
218 Laws for list versions
219 ~~~~~~~~~~~~~~~~~~~~~~
220 <l1> sep (ps++[empty]++qs) = sep (ps ++ qs)
221 ...ditto hsep, hcat, vcat, fill...
222 [ Fails for fill ! ]
223 <l2> nest k (sep ps) = sep (map (nest k) ps)
224 ...ditto hsep, hcat, vcat, fill...
225 -}
226 prop_l1 sp ps qs =
227 sp (ps++[empty]++qs) `rdeq` sp (ps ++ qs)
228 prop_l2 sp k ps = nest k (sep ps) `deq` sep (map (nest k) ps)
229
230
231 prop_l1' sp cps cqs =
232 let [ps,qs] = map buildDocList [cps,cqs] in
233 layoutCountBounded maxLayouts (sp (ps++qs)) ==> prop_l1 sp ps qs
234 prop_l2' sp k ps = prop_l2 sp k (buildDocList ps)
235 check_l = do
236 allCats $ myTest "l1" . prop_l1'
237 allCats $ myTest "l2" . prop_l2'
238 where
239 allCats = flip mapM_ [ sep, hsep, cat, hcat, vcat, fsep, fcat ]
240 prop_l1_fail_1 = [ text "a" ]
241 prop_l1_fail_2 = [ text "a" $$ text "b" ]
242
243 {-
244 Laws for oneLiner
245 ~~~~~~~~~~~~~~~~~
246 <o1> oneLiner (nest k p) = nest k (oneLiner p)
247 <o2> oneLiner (x <> y) = oneLiner x <> oneLiner y
248
249 [One liner only takes reduced arguments]
250 -}
251 oneLinerR = oneLiner . reduceDoc
252 prop_o1 k p = oneLinerR (nest k p) `deq` nest k (oneLinerR p)
253 prop_o2 x y = oneLinerR (x <> y) `deq` oneLinerR x <> oneLinerR y
254
255 check_o = do
256 putStrLn "oneliner laws"
257 myTest "o1 (RDoc arg)" (\k p -> prop_o1 k (buildDoc p))
258 myTest "o2 (RDoc arg)" (liftDoc2 prop_o2)
259
260 {-
261 Definitions of list versions
262 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
263 <ldef1> vcat = foldr ($$) empty
264 <ldef2> hcat = foldr (<>) empty
265 <ldef3> hsep = foldr (<+>) empty
266 -}
267 prop_hcat :: [Doc] -> Bool
268 prop_hcat ds = hcat ds `deq` (foldr (<>) empty) ds
269 prop_hsep :: [Doc] -> Bool
270 prop_hsep ds = hsep ds `deq` (foldr (<+>) empty) ds
271 prop_vcat :: [Doc] -> Bool
272 prop_vcat ds = vcat ds `deq` (foldr ($$) empty) ds
273
274 {-
275 Update (pretty-1.1.0):
276 *failing* definition of sep: oneLiner (hsep ps) `union` vcat ps
277 <ldef4> ?
278 -}
279 prop_sep :: [Doc] -> Bool
280 prop_sep ds = sep ds `rdeq` (sepDef ds)
281 sepDef :: [Doc] -> Doc
282 sepDef docs = let ds = filter (not . isEmpty) docs in
283 case ds of
284 [] -> empty
285 [d] -> d
286 ds -> reduceDoc (oneLiner (reduceDoc $ hsep ds)
287 `Union`
288 (reduceDoc $ foldr ($+$) empty ds))
289
290 check_list_def = do
291 myTest "hcat def" (prop_hcat . buildDocList)
292 myTest "hsep def" (prop_hsep . buildDocList)
293 myTest "vcat def" (prop_vcat . buildDocList)
294 myTest "sep def" (prop_sep . buildDocList)
295 {-
296 Definition of fill (fcat/fsep)
297 -- Specification:
298 -- fill [] = empty
299 -- fill [p] = p
300 -- fill (p1:p2:ps) = oneLiner p1 <#> nest (length p1)
301 -- (fill (oneLiner p2 : ps))
302 -- `union`
303 -- p1 $$ fill ps
304 -- Revised Specification:
305 -- fill g docs = fillIndent 0 docs
306 --
307 -- fillIndent k [] = []
308 -- fillIndent k [p] = p
309 -- fillIndent k (p1:p2:ps) =
310 -- oneLiner p1 <g> fillIndent (k + length p1 + g ? 1 : 0) (remove_nests (oneLiner p2) : ps)
311 -- `Union`
312 -- (p1 $*$ nest (-k) (fillIndent 0 ps))
313 --
314 -- $*$ is defined for layouts (not Docs) as
315 -- layout1 $*$ layout2 | isOneLiner layout1 = layout1 $+$ layout2
316 -- | otherwise = layout1 $$ layout2
317 --
318 -- Old implementation ambiguities/problems:
319 -- ========================================
320 -- Preserving nesting:
321 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
322 -- fcat [cat[ text "b", text "a"], nest 2 ( text "" $$ text "a")]
323 -- ==> fcat [ text "b" $$ text "a", nest 2 (text "" $$ text "a")] // cat: union right
324 -- ==> (text "b" $$ text "a" $$ nest 2 (text "" $$ text "a")) // fcat: union right with overlap
325 -- ==> (text "ab" $$ nest 2 (text "" $$ text "a"))
326 -- ==> "b\na\n..a"
327 -- Bug #1337:
328 -- ~~~~~~~~~~
329 -- > fcat [ nest 1 $ text "a", nest 2 $ text "b", text "c"]
330 -- ==> [second alternative] roughly (a <#> b $#$ c)
331 -- " ab"
332 -- "c "
333 -- expected: (nest 1; text "a"; text "b"; nest -3; "c")
334 -- actual : (nest 1; text "a"; text "b"; nest -5; "c")
335 -- === (nest 1; text a) <> (fill (-2) (p2:ps))
336 -- ==> (nest 2 (text "b") $+$ text "c")
337 -- ==> (nest 2 (text "b") `nilabove` nest (-3) (text "c"))
338 -- ==> (nest 1; text a; text b; nest -5 c)
339
340 -}
341 prop_fcat_vcat :: [Doc] -> Bool
342 prop_fcat_vcat ds = last (flattenDoc $ fcat ds) `deq` last (flattenDoc $ vcat ds)
343 prop_fcat :: [Doc] -> Bool
344 prop_fcat ds = fcat ds `rdeq` fillDef False (filter (not . isEmpty) ds)
345 prop_fsep :: [Doc] -> Bool
346 prop_fsep ds = fsep ds `rdeq` fillDef True (filter (not . isEmpty) ds)
347 prop_fcat_old :: [Doc] -> Bool
348 prop_fcat_old ds = fillOld2 False ds `rdeq` fillDef False (filter (not . isEmpty) ds)
349 prop_fcat_old_old :: [Doc] -> Bool
350 prop_fcat_old_old ds = fillOld2 False ds `rdeq` fillDefOld False (filter (not . isEmpty) ds)
351
352 prop_restrict_sz :: (Testable a) => Int -> ([Doc] -> a) -> ([Doc] -> Property)
353 prop_restrict_sz k p ds = layoutCountBounded k (fsep ds) ==> p ds
354 prop_restrict_ol :: (Testable a) => ([Doc] -> a) -> ([Doc] -> Property)
355 prop_restrict_ol p ds = (all isOneLiner . map normalize $ ds) ==> p ds
356 prop_restrict_no_nest_start :: (Testable a) => ([Doc] -> a) -> ([Doc] -> Property)
357 prop_restrict_no_nest_start p ds = (all (not .isNest) ds) ==> p ds
358
359 fillDef :: Bool -> [Doc] -> Doc
360 fillDef g = normalize . fill' 0 . filter (not.isEmpty) . map reduceDoc where
361 fill' _ [] = Empty
362 fill' _ [x] = x
363 fill' k (p1:p2:ps) =
364 reduceDoc (oneLiner p1 `append` (fill' (k + firstLineLength p1 + (if g then 1 else 0)) $ (oneLiner' p2) : ps))
365 `union`
366 reduceDoc (p1 $*$ (nest (-k) (fillDef g (p2:ps))))
367 union = Union
368 append = if g then (<+>) else (<>)
369 oneLiner' (Nest k d) = oneLiner' d
370 oneLiner' d = oneLiner d
371 ($*$) :: RDoc -> RDoc -> RDoc
372 ($*$) p ps = case flattenDoc p of
373 [] -> NoDoc
374 ls -> foldr1 Union (map combine ls)
375 where
376 combine p | isOneLiner p = p $+$ ps
377 | otherwise = p $$ ps
378
379 fillDefOld :: Bool -> [Doc] -> Doc
380 fillDefOld g = normalize . fill' . filter (not.isEmpty) . map normalize where
381 fill' [] = Empty
382 fill' [p1] = p1
383 fill' (p1:p2:ps) = (normalize (oneLiner p1 `append` nest (firstLineLength p1)
384 (fill' (oneLiner p2 : ps))))
385 `union`
386 (p1 $$ fill' (p2:ps))
387 append = if g then (<+>) else (<>)
388 union = Union
389
390 check_fill_prop msg p = myTest msg (prop_restrict_sz maxLayouts p . buildDocList)
391 check_fill_def_fail = do
392 check_fill_prop "fcat defOld vs fcatOld (ol)" (prop_restrict_ol prop_fcat_old_old)
393 check_fill_prop "fcat defOld vs fcatOld" prop_fcat_old_old
394
395 check_fill_prop "fcat def (ol) vs fcatOld" (prop_restrict_ol prop_fcat_old)
396 check_fill_prop "fcat def vs fcatOld" prop_fcat_old
397 check_fill_def_ok = do
398 check_fill_prop "fcat def (not nest start) vs fcatOld" (prop_restrict_no_nest_start prop_fcat_old)
399
400 check_fill_prop "fcat def (not nest start) vs fcat" (prop_restrict_no_nest_start prop_fcat)
401 check_fill_prop "fcat def (ol) vs fcat" (prop_restrict_ol prop_fcat)
402 check_fill_prop "fcat def vs fcat" prop_fcat
403 check_fill_prop "fsep def vs fsep" prop_fsep
404 check_fill_def_laws = do
405 check_fill_prop "lastLayout (fcat ps) == vcat ps" prop_fcat_vcat
406 check_fill_def = check_fill_def_fail >> check_fill_def_ok
407 {-
408 text "ac"; nilabove; nest -1; text "a"; empty
409 text "ac"; nilabove; nest -2; text "a"; empty
410 -}
411
412 {-
413 Zero width text (Neil)
414
415 Here it would be convenient to generate functions (or replace empty / text bz z-w-t)
416 -}
417 -- TODO
418 {-
419 All laws: monoid, text, nest, misc, list versions, oneLiner, list def
420 -}
421 check_laws = do
422 check_fill_def_ok
423 check_monoid
424 check_t
425 check_n
426 check_m
427 check_l
428 check_o
429 check_list_def
430
431 -- (2) QuickCheck Properties: Invariants (whitebox)
432 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
433
434 -- strategies: synthesize with stop condition
435 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
436 stop :: a -> (a, Bool)
437 stop a = (a,False)
438 recurse :: a -> (a, Bool)
439 recurse a = (a,True)
440 -- strategy: generic synthesize with stop condition
441 -- terms are combined top-down, left-right (latin text order)
442 genericProp :: (a -> a -> a) -> (Doc -> (a,Bool)) -> Doc -> a
443 genericProp c q doc =
444 case q doc of
445 (v,False) -> v
446 (v,True) -> foldl c v (subs doc)
447 where
448 rec = genericProp c q
449 subs d = case d of
450 Empty -> []
451 NilAbove d -> [rec d]
452 TextBeside _ _ d -> [rec d]
453 Nest _ d -> [rec d]
454 Union d1 d2 -> [rec d1, rec d2]
455 NoDoc -> []
456 Beside d1 _ d2 -> subs (reduceDoc d)
457 Above d1 _ d2 -> subs (reduceDoc d)
458
459
460 {-
461 * The argument of NilAbove is never Empty. Therefore
462 a NilAbove occupies at least two lines.
463 -}
464 prop_inv1 :: Doc -> Bool
465 prop_inv1 d = genericProp (&&) nilAboveNotEmpty d where
466 nilAboveNotEmpty (NilAbove Empty) = stop False
467 nilAboveNotEmpty _ = recurse True
468
469 {-
470 * The argument of @TextBeside@ is never @Nest@.
471 -}
472 prop_inv2 :: Doc -> Bool
473 prop_inv2 = genericProp (&&) textBesideNotNest where
474 textBesideNotNest (TextBeside _ _ (Nest _ _)) = stop False
475 textBesideNotNest _ = recurse True
476 {-
477 * The layouts of the two arguments of @Union@ both flatten to the same
478 string
479 -}
480 prop_inv3 :: Doc -> Bool
481 prop_inv3 = genericProp (&&) unionsFlattenSame where
482 unionsFlattenSame (Union d1 d2) = stop (pairwiseEqual (extractTexts d1 ++ extractTexts d2))
483 unionsFlattenSame _ = recurse True
484 pairwiseEqual (x:y:zs) = x==y && pairwiseEqual (y:zs)
485 pairwiseEqual _ = True
486
487
488 {-
489 * The arguments of @Union@ are either @TextBeside@, or @NilAbove@.
490 -}
491 prop_inv4 :: Doc -> Bool
492 prop_inv4 = genericProp (&&) unionArgs where
493 unionArgs (Union d1 d2) | goodUnionArg d1 && goodUnionArg d2 = recurse True
494 | otherwise = stop False
495 unionArgs _ = recurse True
496 goodUnionArg (TextBeside _ _ _) = True
497 goodUnionArg (NilAbove _) = True
498 goodUnionArg _ = False
499
500 {-
501 * A @NoDoc@ may only appear on the first line of the left argument of
502 an union. Therefore, the right argument of an union can never be equivalent
503 to the empty set.
504 -}
505 prop_inv5 :: Doc -> Bool
506 prop_inv5 = genericProp (&&) unionArgs . reduceDoc where
507 unionArgs NoDoc = stop False
508 unionArgs (Union d1 d2) = stop $ genericProp (&&) noDocIsFirstLine d1 && nonEmptySet (reduceDoc d2)
509 unionArgs _ = (True,True) -- recurse
510 noDocIsFirstLine (NilAbove d) = stop $ genericProp (&&) unionArgs d
511 noDocIsFirstLine _ = recurse True
512
513 {-
514 * An empty document is always represented by @Empty@. It can't be
515 hidden inside a @Nest@, or a @Union@ of two @Empty@s.
516 -}
517 prop_inv6 :: Doc -> Bool
518 prop_inv6 d | not (prop_inv1 d) || not (prop_inv2 d) = False
519 | not (isEmptyDoc d) = True
520 | otherwise = case d of Empty -> True ; _ -> False
521
522 isEmptyDoc :: Doc -> Bool
523 isEmptyDoc d = case emptyReduction d of Empty -> True; _ -> False
524
525 {-
526 * Consistency
527 If all arguments of one of the list versions are empty documents, the list is an empty document
528 -}
529 prop_inv6a :: ([Doc] -> Doc) -> [Doc] -> Property
530 prop_inv6a sep ds = all isEmptyDoc ds ==> isEmptyRepr (sep ds) where
531 isEmptyRepr Empty = True
532 isEmptyRepr _ = False
533
534 {-
535 * The first line of every layout in the left argument of @Union@ is
536 longer than the first line of any layout in the right argument.
537 (1) ensures that the left argument has a first line. In view of
538 (3), this invariant means that the right argument must have at
539 least two lines.
540 -}
541 counterexample_inv7 = cat [ text " ", nest 2 ( text "a") ]
542
543 prop_inv7 :: Doc -> Bool
544 prop_inv7 = genericProp (&&) firstLonger where
545 firstLonger (Union d1 d2) = (firstLineLength d1 >= firstLineLength d2, True)
546 firstLonger _ = (True, True)
547
548 {-
549 * If we take as precondition: the arguments of cat,sep,fill do not start with Nest, invariant 7 holds
550 -}
551 prop_inv7_pre :: CDoc -> Bool
552 prop_inv7_pre cdoc = nestStart True cdoc where
553 nestStart nestOk doc =
554 case doc of
555 CList sep ds -> all (nestStart False) ds
556 CBeside _ d1 d2 -> nestStart nestOk d1 && nestStart (not . isEmpty $ buildDoc d1) d2
557 CAbove _ d1 d2 -> nestStart nestOk d1 && nestStart (not . isEmpty $ buildDoc d1) d2
558 CNest _ d | not nestOk -> False
559 | otherwise -> nestStart True d
560 _empty_or_text -> True
561
562 {-
563 inv7_pre ==> inv7
564 -}
565 prop_inv7_a :: CDoc -> Property
566 prop_inv7_a cdoc = prop_inv7_pre cdoc ==> prop_inv7 (buildDoc cdoc)
567
568 check_invariants :: IO ()
569 check_invariants = do
570 myTest "Invariant 1" (prop_inv1 . buildDoc)
571 myTest "Invariant 2" (prop_inv2 . buildDoc)
572 myTest "Invariant 3" (prop_inv3 . buildDoc)
573 myTest "Invariant 4" (prop_inv4 . buildDoc)
574 myTest "Invariant 5+" (prop_inv5 . buildDoc)
575 myTest "Invariant 6" (prop_inv6 . buildDoc)
576 mapM_ (\sp -> myTest "Invariant 6a" (prop_inv6a sp . buildDocList)) [ cat, sep, fcat, fsep, vcat, hcat, hsep ]
577 myTest "Invariant 7 (fails in HughesPJ:20080621)" (prop_inv7 . buildDoc)
578
579 -- `negative indent'
580 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
581
582 {-
583 In the documentation we have:
584
585 (spaces n) generates a list of n spaces
586 It should never be called with 'n' < 0, but that can happen for reasons I don't understand
587
588 This is easy to explain:
589 Suppose we have layout1 <> layout2
590 length of last line layout1 is k1
591 indentation of first line of layout2 is k2
592 indentation of some other line of layout2 is k2'
593 Now layout1 <> nest k2 (line1 $$ nest k2' lineK)
594 ==> layout1 <> (line1 $$ nest k2' lineK)
595 When k1 - k2' < 0, we need to layout lineK with negative indentation
596
597 Here is a quick check property to ducment this.
598 -}
599 prop_negative_indent :: CDoc -> Property
600 prop_negative_indent cdoc = noNegNest cdoc ==> noNegSpaces (buildDoc cdoc)
601 noNegNest = genericCProp (&&) notIsNegNest where
602 notIsNegNest (CNest k _) | k < 0 = stop False
603 notIsNegNest _ = recurse True
604 noNegSpaces = go 0 . reduceDoc where
605 go k Empty = True
606 go k (NilAbove d) = go k d
607 go k (TextBeside _ s d) | k < 0 = False
608 go k (TextBeside _ s d) = go (k+s) d
609 go k (Nest k' d) = go (k+k') d
610 go k (Union d1 d2) = (if nonEmptySet d1 then (&&) (go k d1) else id) (go k d2)
611 go k NoDoc = True
612
613 counterexample_fail9 :: Doc
614 counterexample_fail9 = text "a" <> ( nest 2 ( text "b") $$ text "c")
615 -- reduces to textb "a" ; textb "b" ; nilabove ; nest -3 ; textb "c" ; empty
616
617 {-
618 This cannot be fixed with violating the "intuitive property of layouts", described by John Hughes:
619 "Composing layouts should preserve the layouts themselves (i.e. translation)"
620
621 Consider the following example:
622 It is the user's fault to use <+> in t2.
623 -}
624
625 tstmt = (nest 6 $ text "/* double indented comment */") $+$
626 (nest 3 $ text "/* indented comment */") $+$
627 text "skip;"
628
629 t1 = text "while(true)" $+$ (nest 2) tstmt
630 {-
631 while(true)
632 /* double indented comment */
633 /* indented comment */
634 skip;
635 -}
636 t2 = text "while(true)" $+$ (nest 2 $ text "//" <+> tstmt)
637 {-
638 while(true)
639 // /* double indented comment */
640 /* indented comment */
641 skip;
642 -}
643
644 -- (3) Touching non-prims
645 -- ~~~~~~~~~~~~~~~~~~~~~~
646
647 check_non_prims :: IO ()
648 check_non_prims = do
649 myTest "Non primitive: show = renderStyle style" $ \cd -> let d = buildDoc cd in
650 show ((zeroWidthText "a") <> d) /= renderStyle style d
651 myAssert "symbols" $
652 (semi <> comma <> colon <> equals <> lparen <> rparen <> lbrack <> rbrack <> lbrace <> rbrace)
653 `deq`
654 (text ";,:=()[]{}")
655 myAssert "quoting" $
656 (quotes . doubleQuotes . parens . brackets .braces $ (text "a" $$ text "b"))
657 `deq`
658 (text "'\"([{" <> (text "a" $$ text "b") <> text "}])\"'")
659 myAssert "numbers" $
660 fsep [int 42, integer 42, float 42, double 42, rational 42]
661 `rdeq`
662 (fsep . map text)
663 [show (42 :: Int), show (42 :: Integer), show (42 :: Float), show (42 :: Double), show (42 :: Rational)]
664 myTest "Definition of <+>" $ \cd1 cd2 ->
665 let (d1,d2) = (buildDoc cd1, buildDoc cd2) in
666 layoutsCountBounded maxLayouts [d1,d2] ==>
667 not (isEmpty d1) && not (isEmpty d2) ==>
668 d1 <+> d2 `rdeq` d1 <> space <> d2
669
670 myTest "hang" $ liftDoc2 (\d1 d2 -> hang d1 2 d2 `deq` sep [d1, nest 2 d2])
671
672 let pLift f cp cds = f (buildDoc cp) (buildDocList cds)
673 myTest "punctuate" $ pLift (\p ds -> (punctuate p ds) `deqs` (punctuateDef p ds))
674
675 check_rendering = do
676 myTest' 20 10000 "one - line rendering" $ \cd ->
677 let d = buildDoc cd in
678 (renderStyle (Style OneLineMode undefined undefined) d) == oneLineRender d
679 myTest' 20 10000 "left-mode rendering" $ \cd ->
680 let d = buildDoc cd in
681 extractText (renderStyle (Style LeftMode undefined undefined) d) == extractText (oneLineRender d)
682 myTest' 20 10000 "page mode rendering" $ \cd ->
683 let d = buildDoc cd in
684 extractText (renderStyle (Style PageMode 6 1.7) d) == extractText (oneLineRender d)
685 myTest' 20 10000 "zigzag mode rendering" $ \cd ->
686 let d = buildDoc cd in
687 extractTextZZ (renderStyle (Style ZigZagMode 6 1.7) d) == extractText (oneLineRender d)
688
689 extractText :: String -> String
690 extractText = filter (not . isSpace)
691 extractTextZZ :: String -> String
692 extractTextZZ = filter (\c -> not (isSpace c) && c /= '/' && c /= '\\')
693
694 punctuateDef :: Doc -> [Doc] -> [Doc]
695 punctuateDef p [] = []
696 punctuateDef p ps =
697 let (dsInit,dLast) = (init ps, last ps) in
698 map (\d -> d <> p) dsInit ++ [dLast]
699
700 -- (4) QuickChecking improvments and bug fixes
701 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
702
703 {-
704 putStrLn $ render' $ fill True [ text "c", text "c",empty, text "c", text "b"]
705 c c c
706 b
707 putStrLn $ render' $ fillOld True [ text "c", text "c",empty, text "c", text "b"]
708 c c c
709 b
710 -}
711 prop_fill_empty_reduce :: [Doc] -> Bool
712 prop_fill_empty_reduce ds = fill True ds `deq` fillOld True (filter (not.isEmpty.reduceDoc) ds)
713
714 check_improvements :: IO ()
715 check_improvements = do
716 myTest "fill = fillOld . filter (not.isEmpty) [if no argument starts with nest]"
717 (prop_fill_empty_reduce . filter (not .isNest) . buildDocList)
718
719 -- old implementation of fill
720 fillOld :: Bool -> [Doc] -> RDoc
721 fillOld _ [] = empty
722 fillOld g (p:ps) = fill1 g (reduceDoc p) 0 ps where
723 fill1 :: Bool -> RDoc -> Int -> [Doc] -> Doc
724 fill1 _ _ k _ | k `seq` False = undefined
725 fill1 _ NoDoc _ _ = NoDoc
726 fill1 g (p `Union` q) k ys = fill1 g p k ys
727 `union_`
728 (aboveNest q False k (fillOld g ys))
729
730 fill1 g Empty k ys = mkNest k (fillOld g ys)
731 fill1 g (Nest n p) k ys = nest_ n (fill1 g p (k - n) ys)
732
733 fill1 g (NilAbove p) k ys = nilAbove_ (aboveNest p False k (fillOld g ys))
734 fill1 g (TextBeside s sl p) k ys = textBeside_ s sl (fillNB g p (k - sl) ys)
735 fill1 _ (Above {}) _ _ = error "fill1 Above"
736 fill1 _ (Beside {}) _ _ = error "fill1 Beside"
737 -- fillNB gap textBesideArgument space_left docs
738 fillNB :: Bool -> Doc -> Int -> [Doc] -> Doc
739 fillNB _ _ k _ | k `seq` False = undefined
740 fillNB g (Nest _ p) k ys = fillNB g p k ys
741 fillNB _ Empty _ [] = Empty
742 fillNB g Empty k (y:ys) = nilBeside g (fill1 g (oneLiner (reduceDoc y)) k1 ys)
743 `mkUnion`
744 nilAboveNest False k (fillOld g (y:ys))
745 where
746 k1 | g = k - 1
747 | otherwise = k
748 fillNB g p k ys = fill1 g p k ys
749
750
751 -- Specification:
752 -- fill [] = empty
753 -- fill [p] = p
754 -- fill (p1:p2:ps) = oneLiner p1 <#> nest (length p1)
755 -- (fill (oneLiner p2 : ps))
756 -- `union`
757 -- p1 $$ fill ps
758 fillOld2 :: Bool -> [Doc] -> RDoc
759 fillOld2 _ [] = empty
760 fillOld2 g (p:ps) = fill1 g (reduceDoc p) 0 ps where
761 fill1 :: Bool -> RDoc -> Int -> [Doc] -> Doc
762 fill1 _ _ k _ | k `seq` False = undefined
763 fill1 _ NoDoc _ _ = NoDoc
764 fill1 g (p `Union` q) k ys = fill1 g p k ys
765 `union_`
766 (aboveNest q False k (fill g ys))
767
768 fill1 g Empty k ys = mkNest k (fill g ys)
769 fill1 g (Nest n p) k ys = nest_ n (fill1 g p (k - n) ys)
770
771 fill1 g (NilAbove p) k ys = nilAbove_ (aboveNest p False k (fill g ys))
772 fill1 g (TextBeside s sl p) k ys = textBeside_ s sl (fillNB g p (k - sl) ys)
773 fill1 _ (Above {}) _ _ = error "fill1 Above"
774 fill1 _ (Beside {}) _ _ = error "fill1 Beside"
775
776 fillNB :: Bool -> Doc -> Int -> [Doc] -> Doc
777 fillNB _ _ k _ | k `seq` False = undefined
778 fillNB g (Nest _ p) k ys = fillNB g p k ys
779 fillNB _ Empty _ [] = Empty
780 fillNB g Empty k (Empty:ys) = fillNB g Empty k ys
781 fillNB g Empty k (y:ys) = fillNBE g k y ys
782 fillNB g p k ys = fill1 g p k ys
783
784 fillNBE g k y ys = nilBeside g (fill1 g (oneLiner (reduceDoc y)) k1 ys)
785 `mkUnion`
786 nilAboveNest True k (fill g (y:ys))
787 where
788 k1 | g = k - 1
789 | otherwise = k
790
791 -- (5) Pretty printing RDocs and RDOC properties
792 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
793 prettyDoc :: Doc -> Doc
794 prettyDoc d =
795 case reduceDoc d of
796 Empty -> text "empty"
797 NilAbove d -> (text "nilabove") <> semi <+> (prettyDoc d)
798 TextBeside s sl d -> (text ("text \""++tdToStr s ++ "\"" ++ show sl)) <> semi <+> (prettyDoc d)
799 Nest k d -> text "nest" <+> integer (fromIntegral k) <> semi <+> prettyDoc d
800 Union d1 d2 -> sep [text "union", parens (prettyDoc d1), parens (prettyDoc d2)]
801 NoDoc -> text "nodoc"
802
803 -- TODO: map strategy for Docs to avoid code duplication
804 -- Debug: Doc -> [Layout]
805 flattenDoc :: Doc -> [RDoc]
806 flattenDoc d = flatten (reduceDoc d) where
807 flatten NoDoc = []
808 flatten Empty = return Empty
809 flatten (NilAbove d) = map NilAbove (flatten d)
810 flatten (TextBeside s sl d) = map (TextBeside s sl) (flatten d)
811 flatten (Nest k d) = map (Nest k) (flatten d)
812 flatten (Union d1 d2) = flattenDoc d1 ++ flattenDoc d2
813 flatten (Beside d1 b d2) = error $ "flattenDoc Beside"
814 flatten (Above d1 b d2) = error $ "flattenDoc Above"
815
816 normalize :: Doc -> RDoc
817 normalize d = norm d where
818 norm NoDoc = NoDoc
819 norm Empty = Empty
820 norm (NilAbove d) = NilAbove (norm d)
821 norm (TextBeside s sl (Nest k d)) = norm (TextBeside s sl d)
822 norm (TextBeside s sl d) = (TextBeside s sl) (norm d)
823 norm (Nest k (Nest k' d)) = norm $ Nest (k+k') d
824 norm (Nest 0 d) = norm d
825 norm (Nest k d) = (Nest k) (norm d)
826 -- * The arguments of @Union@ are either @TextBeside@, or @NilAbove@.
827 norm (Union d1 d2) = normUnion (norm d1) (norm d2)
828 norm d@(Beside d1 b d2) = norm (reduceDoc d)
829 norm d@(Above d1 b d2) = norm (reduceDoc d)
830 normUnion d0@(Nest k d) (Union d1 d2) = norm (Union d0 (normUnion d1 d2))
831 normUnion (Union d1 d2) d3@(Nest k d) = norm (Union (normUnion d1 d2) d3)
832 normUnion (Nest k d1) (Nest k' d2) | k == k' = Nest k $ Union (norm d1) (norm d2)
833 | otherwise = error "normalize: Union Nest length mismatch ?"
834 normUnion (Nest _ _) d2 = error$ "normUnion Nest "++topLevelCTor d2
835 normUnion d1 (Nest _ _) = error$ "normUnion Nset "++topLevelCTor d1
836 normUnion p1 p2 = Union p1 p2
837 topLevelCTor :: Doc -> String
838 topLevelCTor d = tlc d where
839 tlc NoDoc = "NoDoc"
840 tlc Empty = "Empty"
841 tlc (NilAbove d) = "NilAbove"
842 tlc (TextBeside s sl d) = "TextBeside"
843 tlc (Nest k d) = "Nest"
844 tlc (Union d1 d2) = "Union"
845 tlc (Above _ _ _) = "Above"
846 tlc (Beside _ _ _) = "Beside"
847
848 -- normalize TextBeside (and consequently apply some laws for simplification)
849 mergeTexts :: RDoc -> RDoc
850 mergeTexts = merge where
851 merge NoDoc = NoDoc
852 merge Empty = Empty
853 merge (NilAbove d) = NilAbove (merge d)
854 merge (TextBeside t1 l1 (TextBeside t2 l2 doc)) = (merge.normalize) (TextBeside (mergeText t1 t2) (l1 +l2) doc)
855 merge (TextBeside s sl d) = TextBeside s sl (merge d)
856 merge (Nest k d) = Nest k (merge d)
857 merge (Union d1 d2) = Union (merge d1) (merge d2)
858 mergeText t1 t2 = Str $ tdToStr t1 ++ tdToStr t2
859
860 isOneLiner :: RDoc -> Bool
861 isOneLiner = genericProp (&&) iol where
862 iol (NilAbove _) = stop False
863 iol (Union _ _) = stop False
864 iol NoDoc = stop False
865 iol _ = recurse True
866 hasOneLiner :: RDoc -> Bool
867 hasOneLiner = genericProp (&&) iol where
868 iol (NilAbove _) = stop False
869 iol (Union d1 _) = stop $ hasOneLiner d1
870 iol NoDoc = stop False
871 iol _ = recurse True
872
873 -- use elementwise concatenation as generic combinator
874 extractTexts :: Doc -> [String]
875 extractTexts = map normWS . genericProp combine go where
876 combine xs ys = [ a ++ b | a <- xs, b <- ys ]
877 go (TextBeside s _ _ ) = recurse [tdToStr s]
878 go (Union d1 d2) = stop $ extractTexts d1 ++ extractTexts d2
879 go NoDoc = stop []
880 go _ = recurse [""]
881 -- modulo whitespace
882 normWS txt = filter (not . isWS) txt where
883 isWS ws | ws == ' ' || ws == '\n' || ws == '\t' = True
884 | otherwise = False
885
886 emptyReduction :: Doc -> Doc
887 emptyReduction doc =
888 case doc of
889 Empty -> Empty
890 NilAbove d -> case emptyReduction d of Empty -> Empty ; d' -> NilAbove d'
891 TextBeside s sl d -> TextBeside s sl (emptyReduction d)
892 Nest k d -> case emptyReduction d of Empty -> Empty; d -> Nest k d
893 Union d1 d2 -> case emptyReduction d2 of Empty -> Empty; _ -> Union d1 d2 -- if d2 is empty, both have to be
894 NoDoc -> NoDoc
895 Beside d1 _ d2 -> emptyReduction (reduceDoc doc)
896 Above d1 _ d2 -> emptyReduction (reduceDoc doc)
897
898 firstLineLength :: Doc -> Int
899 firstLineLength = genericProp (+) fll . reduceDoc where
900 fll (NilAbove d) = stop 0
901 fll (TextBeside _ l d) = recurse l
902 fll (Nest k d) = recurse k
903 fll (Union d1 d2) = stop (firstLineLength d1) -- inductively assuming inv7
904 fll (Above _ _ _) = error "Above"
905 fll (Beside _ _ _) = error "Beside"
906 fll _ = (0,True)
907
908 abstractLayout :: Doc -> [(Int,String)]
909 abstractLayout d = cal 0 Nothing (reduceDoc d) where
910 -- current column -> this line -> doc -> [(indent,line)]
911 cal :: Int -> (Maybe (Int,String)) -> Doc -> [(Int,String)]
912 cal k cur Empty = [ addTextEOL k (Str "") cur ]
913 cal k cur (NilAbove d) = (addTextEOL k (Str "") cur) : cal k Nothing d
914 cal k cur (TextBeside s sl d) = cal (k+sl) (addText k s cur) d
915 cal k cur (Nest n d) = cal (k+n) cur d
916 cal _ _ (Union d1 d2) = error "abstractLayout: Union"
917 cal _ _ NoDoc = error "NoDoc"
918 cal _ _ (Above _ _ _) = error "Above"
919 cal _ _ (Beside _ _ _) = error "Beside"
920 addTextEOL k str Nothing = (k,tdToStr str)
921 addTextEOL _ str (Just (k,pre)) = (k,pre++ tdToStr str)
922 addText k str = Just . addTextEOL k str
923 docifyLayout :: [(Int,String)] -> Doc
924 docifyLayout = vcat . map (\(k,t) -> nest k (text t))
925
926 oneLineRender :: Doc -> String
927 oneLineRender = olr . abstractLayout . last . flattenDoc where
928 olr = concat . intersperse " " . map snd
929
930 -- because of invariant 4, we do not have to expand to layouts here
931 -- but it is easier, so for now we use abstractLayout
932 firstLineIsLeftMost :: Doc -> Bool
933 firstLineIsLeftMost = all (firstIsLeftMost . abstractLayout) . flattenDoc where
934 firstIsLeftMost ((k,_):xs@(_:_)) = all ( (>= k) . fst) xs
935 firstIsLeftMost _ = True
936 noNegativeIndent :: Doc -> Bool
937 noNegativeIndent = all (noNegIndent . abstractLayout) . flattenDoc where
938 noNegIndent = all ( (>= 0) . fst)
939
940 -- (6) Datatypes for law QuickChecks
941 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
942
943 -- User visible combinators
944 -- The tests are performed on pretty printing terms which are constructable using the public combinators.
945 -- We need to have a datatype for those combinators, otherwise it becomes almost impossible to reconstruct failing tests.
946
947 data CDoc = CEmpty -- empty
948 | CText String -- text s
949 | CList CList [CDoc] -- cat,sep,fcat,fsep ds
950 | CBeside Bool CDoc CDoc -- a <> b and a <+> b
951 | CAbove Bool CDoc CDoc -- a $$ b and a $+$ b
952 | CNest Int CDoc -- nest k d
953 -- | ZText String -- zeroWidthText s
954 deriving (Eq,Ord)
955
956 data CList = CCat | CSep | CFCat | CFSep deriving (Eq,Ord)
957 listComb :: CList -> ([Doc] -> Doc)
958 listComb cs = case cs of CCat -> cat ; CSep -> sep ; CFCat -> fcat ; CFSep -> fsep
959 instance Show CList where
960 show cs = case cs of CCat -> "cat" ; CSep -> "sep" ; CFCat -> "fcat" ; CFSep -> "fsep"
961
962 buildDoc :: CDoc -> Doc
963 buildDoc CEmpty = empty
964 buildDoc (CText s) = text s
965 --buildDoc (ZText s) = zeroWidthText s
966 buildDoc (CList sp ds) = (listComb sp) $ map buildDoc ds
967 buildDoc (CBeside sep d1 d2) = (if sep then (<+>) else (<>)) (buildDoc d1) (buildDoc d2)
968 buildDoc (CAbove noOvlap d1 d2) = (if noOvlap then ($+$) else ($$)) (buildDoc d1) (buildDoc d2)
969 buildDoc (CNest k d) = nest k $ buildDoc d
970
971 liftDoc2 :: (Doc -> Doc -> a) -> (CDoc -> CDoc -> a)
972 liftDoc2 f cd1 cd2 = f (buildDoc cd1) (buildDoc cd2)
973 liftDoc3 :: (Doc -> Doc -> Doc -> a) -> (CDoc -> CDoc -> CDoc -> a)
974 liftDoc3 f cd1 cd2 cd3 = f (buildDoc cd1) (buildDoc cd2) (buildDoc cd3)
975
976 instance Show CDoc where
977 showsPrec k CEmpty = showString "empty"
978 showsPrec k (CText s) = showParen (k >= 10) (showString " text " . shows s)
979 -- showsPrec k (ZText s) = showParen (k >= 10) (showString " zeroWidthText " . shows s)
980 showsPrec k (CList sp ds) = showParen (k >= 10) $ (shows sp . showList ds)
981 showsPrec k (CBeside sep d1 d2) = showParen (k >= 6) $
982 (showsPrec 6 d1) . showString (if sep then " <+> " else " <> ") . (showsPrec 6 d2)
983 showsPrec k (CAbove noOvlap d1 d2) = showParen (k >= 5) $
984 (showsPrec 5 d1) . showString (if noOvlap then " $+$ " else " $$ ") . (showsPrec 5 d2)
985 showsPrec k (CNest n d) = showParen (k >= 10) $ showString " nest " . showsPrec 10 n . showString " ". showsPrec 10 d
986
987 instance Arbitrary CDoc where
988 arbitrary = sized arbDoc
989 where
990 -- TODO: finetune frequencies
991 arbDoc k | k <= 1 = frequency [
992 (1,return CEmpty)
993 , (2,return (CText . unText) `ap` arbitrary)
994 -- , (1,return (ZText "&"))
995 ]
996 arbDoc n = frequency [
997 (1, return CList `ap` arbitrary `ap` (liftM unDocList $ resize (pred n) arbitrary))
998 ,(1, binaryComb n CBeside)
999 ,(1, binaryComb n CAbove)
1000 ,(1, choose (0,10) >>= \k -> return (CNest k) `ap` (resize (pred n) arbitrary))
1001 ]
1002 binaryComb n f =
1003 split2 (n-1) >>= \(n1,n2) ->
1004 return f `ap` arbitrary `ap` (resize n1 arbitrary) `ap` (resize n2 arbitrary)
1005 split2 n = flip liftM ( choose (0,n) ) $ \sz -> (sz, n - sz)
1006 coarbitrary CEmpty = variant 0
1007 coarbitrary (CText t) = variant 1 . coarbitrary (length t)
1008 coarbitrary (CList f list) = variant 2 . coarbitrary f . coarbitrary list
1009 coarbitrary (CBeside b d1 d2) = variant 3 . coarbitrary b . coarbitrary d1 . coarbitrary d2
1010 coarbitrary (CAbove b d1 d2) = variant 4 . coarbitrary b . coarbitrary d1 . coarbitrary d2
1011 coarbitrary (CNest k d) = variant 5 . coarbitrary k . coarbitrary d
1012
1013 instance Arbitrary CList where
1014 arbitrary = oneof $ map return [ CCat, CSep, CFCat, CFSep ]
1015 coarbitrary cl = variant (case cl of CCat -> 0; CSep -> 1; CFCat -> 2; CFSep -> 3)
1016
1017 newtype CDocList = CDocList { unDocList :: [CDoc] }
1018 instance Show CDocList where show = show . unDocList
1019
1020 -- we assume that the list itself has no size, so that
1021 -- sizeof (a $$ b) = sizeof (sep [a,b]) = sizeof(a)+sizeof(b)+1
1022 instance Arbitrary CDocList where
1023 arbitrary = liftM CDocList $ sized $ \n -> arbDocList n where
1024 arbDocList 0 = return []
1025 arbDocList n = do
1026 listSz <- choose (1,n)
1027 let elems = take listSz $ repeat (n `div` listSz) -- approximative
1028 mapM (\sz -> resize sz arbitrary) elems
1029 coarbitrary (CDocList ds) = coarbitrary ds
1030
1031 buildDocList :: CDocList -> [Doc]
1032 buildDocList = map buildDoc . unDocList
1033
1034 -- wrapper for String argument of `text'
1035 newtype Text = Text { unText :: String } deriving (Eq,Ord,Show)
1036 instance Arbitrary Text where
1037 arbitrary = liftM Text $ sized $ \n -> mapM (const arbChar) [1..n]
1038 where arbChar = oneof (map return ['a'..'c'])
1039 coarbitrary (Text str) = coarbitrary (length str)
1040
1041 text' :: Text -> Doc
1042 text' (Text str) = text str
1043 -- convert text details to string
1044 tdToStr :: TextDetails -> String
1045 tdToStr (Chr c) = [c]
1046 tdToStr (Str s) = s
1047 tdToStr (PStr s) = s
1048
1049 -- synthesize with stop for cdoc
1050 -- constructor order
1051 genericCProp :: (a -> a -> a) -> (CDoc -> (a, Bool)) -> CDoc -> a
1052 genericCProp c q cdoc =
1053 case q cdoc of
1054 (v,False) -> v
1055 (v,True) -> foldl c v subs
1056 where
1057 rec = genericCProp c q
1058 subs = case cdoc of
1059 CEmpty -> []
1060 CText _ -> []
1061 -- ZText _ -> []
1062 CList _ ds -> map rec ds
1063 CBeside _ d1 d2 -> [rec d1, rec d2]
1064 CAbove b d1 d2 -> [rec d1, rec d2]
1065 CNest k d -> [rec d]
1066