Restructure code base.
authorDavid Terei <davidterei@gmail.com>
Mon, 5 Mar 2012 19:53:17 +0000 (11:53 -0800)
committerDavid Terei <davidterei@gmail.com>
Tue, 6 Mar 2012 04:16:14 +0000 (20:16 -0800)
CHANGELOG [new file with mode: 0644]
README.md
Setup.hs
pretty.cabal
src/Text/PrettyPrint.hs [moved from Text/PrettyPrint.hs with 100% similarity]
src/Text/PrettyPrint/HughesPJ.hs [moved from Text/PrettyPrint/HughesPJ.hs with 95% similarity]
test/Bench1.hs [new file with mode: 0644]
test/BugSep.hs [new file with mode: 0644]
test/PrettyTestVersion.hs [new file with mode: 0644]
test/Test.hs [new file with mode: 0644]

diff --git a/CHANGELOG b/CHANGELOG
new file mode 100644 (file)
index 0000000..71dbc98
--- /dev/null
+++ b/CHANGELOG
@@ -0,0 +1,169 @@
+======== CHANGE LOG ==========
+
+Pretty library change log.
+
+========= Version 4.0, 24 August 2011 ==========
+
+* Big change to the structure of the library. Now we don't have a fixed
+  TextDetails data type for storing the various String types that we
+  support. Instead we have changed that to be a type class that just
+  provides a way to convert String and Chars to an arbitary type. This
+  arbitary type is now provided by the user of the library so that they
+  can implement support very easily for any String type they want.
+
+  This new code lives in Text.PrettyPrint.Core and the Text.PrettyPrint
+  module uses it to implement the old API. The Text.PrettyPrint.HughesPJ
+  module has been left unchanged for a compatability module but deprecated.
+
+========= Version 3.0, 28 May 1987 ==========
+
+* Cured massive performance bug. If you write:
+
+    foldl <> empty (map (text.show) [1..10000])
+
+  You get quadratic behaviour with V2.0. Why? For just the same
+  reason as you get quadratic behaviour with left-associated (++)
+  chains.
+
+  This is really bad news. One thing a pretty-printer abstraction
+  should certainly guarantee is insensitivity to associativity. It
+  matters: suddenly GHC's compilation times went up by a factor of
+  100 when I switched to the new pretty printer.
+  
+  I fixed it with a bit of a hack (because I wanted to get GHC back
+  on the road). I added two new constructors to the Doc type, Above
+  and Beside:
+  
+    <> = Beside
+    $$ = Above
+  
+  Then, where I need to get to a "TextBeside" or "NilAbove" form I
+  "force" the Doc to squeeze out these suspended calls to Beside and
+  Above; but in so doing I re-associate. It's quite simple, but I'm
+  not satisfied that I've done the best possible job. I'll send you
+  the code if you are interested.
+
+* Added new exports:
+    punctuate, hang
+    int, integer, float, double, rational,
+    lparen, rparen, lbrack, rbrack, lbrace, rbrace,
+
+* fullRender's type signature has changed. Rather than producing a
+  string it now takes an extra couple of arguments that tells it how
+  to glue fragments of output together:
+
+    fullRender :: Mode
+               -> Int                       -- Line length
+               -> Float                     -- Ribbons per line
+               -> (TextDetails -> a -> a)   -- What to do with text
+               -> a                         -- What to do at the end
+               -> Doc
+               -> a                         -- Result
+
+  The "fragments" are encapsulated in the TextDetails data type:
+
+    data TextDetails = Chr  Char
+                     | Str  String
+                     | PStr FAST_STRING
+
+  The Chr and Str constructors are obvious enough. The PStr
+  constructor has a packed string (FAST_STRING) inside it. It's
+  generated by using the new "ptext" export.
+
+  An advantage of this new setup is that you can get the renderer to
+  do output directly (by passing in a function of type (TextDetails
+  -> IO () -> IO ()), rather than producing a string that you then
+  print.
+
+
+
+========= Version 3.0, 28 May 1987 ==========
+
+* Made empty into a left unit for <> as well as a right unit;
+  it is also now true that
+    nest k empty = empty
+  which wasn't true before.
+
+* Fixed an obscure bug in sep that occasionally gave very weird behaviour
+
+* Added $+$
+
+* Corrected and tidied up the laws and invariants
+
+
+
+========= Version 1.0 ==========
+
+Relative to John's original paper, there are the following new features:
+
+1. There's an empty document, "empty". It's a left and right unit for
+   both <> and $$, and anywhere in the argument list for
+   sep, hcat, hsep, vcat, fcat etc.
+
+   It is Really Useful in practice.
+
+2. There is a paragraph-fill combinator, fsep, that's much like sep,
+   only it keeps fitting things on one line until it can't fit any more.
+
+3. Some random useful extra combinators are provided.
+     <+> puts its arguments beside each other with a space between them,
+         unless either argument is empty in which case it returns the other
+
+
+     hcat is a list version of <>
+     hsep is a list version of <+>
+     vcat is a list version of $$
+
+     sep (separate) is either like hsep or like vcat, depending on what fits
+
+     cat  behaves like sep,  but it uses <> for horizontal composition
+     fcat behaves like fsep, but it uses <> for horizontal composition
+
+     These new ones do the obvious things:
+       char, semi, comma, colon, space,
+       parens, brackets, braces,
+       quotes, doubleQuotes
+
+4. The "above" combinator, $$, now overlaps its two arguments if the
+   last line of the top argument stops before the first line of the
+   second begins.
+
+     For example:  text "hi" $$ nest 5 (text "there")
+     lays out as
+                   hi   there
+     rather than
+                   hi
+                        there
+
+   There are two places this is really useful
+
+     a) When making labelled blocks, like this:
+            Left ->   code for left
+            Right ->  code for right
+            LongLongLongLabel ->
+                      code for longlonglonglabel
+        The block is on the same line as the label if the label is
+        short, but on the next line otherwise.
+
+     b) When laying out lists like this:
+            [ first
+            , second
+            , third
+            ]
+        which some people like. But if the list fits on one line you
+        want [first, second, third]. You can't do this with John's
+        original combinators, but it's quite easy with the new $$.
+
+   The combinator $+$ gives the original "never-overlap" behaviour.
+
+5. Several different renderers are provided:
+     * a standard one
+     * one that uses cut-marks to avoid deeply-nested documents
+       simply piling up in the right-hand margin
+     * one that ignores indentation (fewer chars output; good for machines)
+     * one that ignores indentation and newlines (ditto, only more so)
+
+6. Numerous implementation tidy-ups
+   Use of unboxed data types to speed up the implementation
+
+
index b07e76c..1aa98de 100644 (file)
--- a/README.md
+++ b/README.md
@@ -6,6 +6,10 @@ choosing. This is useful for compilers and related tools. The library was
 originally designed by John Hughes's and has since been heavily modified by
 Simon Peyton Jones.
 
 originally designed by John Hughes's and has since been heavily modified by
 Simon Peyton Jones.
 
+It is based on the pretty-printer outlined in the  paper 'The Design of a
+Pretty-printing Library' in Advanced Functional Programming, Johan Jeuring and
+Erik Meijer (eds), LNCS 925 <http://www.cs.chalmers.se/~rjmh/Papers/pretty.ps>
+
 The library uses the Cabal build system, so building is simply a matter of
 running 'cabal install' or 'cabal configure && cabal build'.
 
 The library uses the Cabal build system, so building is simply a matter of
 running 'cabal install' or 'cabal configure && cabal build'.
 
index 6fa548c..fae177c 100644 (file)
--- a/Setup.hs
+++ b/Setup.hs
@@ -4,3 +4,4 @@ import Distribution.Simple
 
 main :: IO ()
 main = defaultMain
 
 main :: IO ()
 main = defaultMain
+
index d717dc1..ccc13e2 100644 (file)
@@ -18,14 +18,35 @@ homepage:      http://github.com/haskell/pretty
 bug-reports:   http://hackage.haskell.org/trac/ghc/newticket?component=libraries/pretty
 stability:     Stable
 build-type:    Simple
 bug-reports:   http://hackage.haskell.org/trac/ghc/newticket?component=libraries/pretty
 stability:     Stable
 build-type:    Simple
+Extra-Source-Files: README CHANGELOG
 Cabal-Version: >= 1.6
 
 Library
 Cabal-Version: >= 1.6
 
 Library
+    hs-source-dirs: src
     exposed-modules:
         Text.PrettyPrint
         Text.PrettyPrint.HughesPJ
     build-depends: base >= 3 && < 5
     extensions: CPP
     exposed-modules:
         Text.PrettyPrint
         Text.PrettyPrint.HughesPJ
     build-depends: base >= 3 && < 5
     extensions: CPP
+    ghc-options: -Wall -Werror -O -fwarn-tabs
+
+Test-Suite test-pretty
+    type: exitcode-stdio-1.0
+    hs-source-dirs: test
+                    src
+    build-depends: base >= 3 && < 5,
+                   QuickCheck == 1.*
+    main-is: Test.hs
+    extensions: CPP
+    include-dirs: src/Text/PrettyPrint
+
+-- Executable Bench1
+--     Main-Is: Bench1.hs
+--     Other-Modules:
+--         Text.PrettyPrint
+--         Text.PrettyPrint.HughesPJ
+--         Text.PrettyPrint.Core
+--     ghc-options: -Wall -Werror -O -fwarn-tabs
 
 source-repository head
     type:     git
 
 source-repository head
     type:     git
similarity index 100%
rename from Text/PrettyPrint.hs
rename to src/Text/PrettyPrint.hs
similarity index 95%
rename from Text/PrettyPrint/HughesPJ.hs
rename to src/Text/PrettyPrint/HughesPJ.hs
index 96c4d13..2b271e4 100644 (file)
@@ -21,8 +21,6 @@
 -- Johan Jeuring and Erik Meijer (eds), LNCS 925
 -- <http://www.cs.chalmers.se/~rjmh/Papers/pretty.ps>
 --
 -- Johan Jeuring and Erik Meijer (eds), LNCS 925
 -- <http://www.cs.chalmers.se/~rjmh/Papers/pretty.ps>
 --
--- Heavily modified by Simon Peyton Jones (December 1996).
---
 -----------------------------------------------------------------------------
 module Text.PrettyPrint.HughesPJ (
 
 -----------------------------------------------------------------------------
 module Text.PrettyPrint.HughesPJ (
 
@@ -79,8 +77,6 @@ import Data.String ( IsString(fromString) )
 -- ---------------------------------------------------------------------------
 -- The Doc calculus
 
 -- ---------------------------------------------------------------------------
 -- The Doc calculus
 
--- The Doc combinators satisfy the following laws:
-
 {-
 Laws for $$
 ~~~~~~~~~~~
 {-
 Laws for $$
 ~~~~~~~~~~~
@@ -177,36 +173,36 @@ data Doc
   | Above Doc Bool Doc                               -- True <=> never overlap
 
 {-
   | Above Doc Bool Doc                               -- True <=> never overlap
 
 {-
-  Here are the invariants:
+Here are the invariants:
 
 
-  1) The argument of NilAbove is never Empty. Therefore
-     a NilAbove occupies at least two lines.
+1) The argument of NilAbove is never Empty. Therefore
+   a NilAbove occupies at least two lines.
 
 
-  2) The argument of @TextBeside@ is never @Nest@.
+2) The argument of @TextBeside@ is never @Nest@.
 
 
-  3) The layouts of the two arguments of @Union@ both flatten to the same
-     string.
+3) The layouts of the two arguments of @Union@ both flatten to the same
+   string.
 
 
-  4) The arguments of @Union@ are either @TextBeside@, or @NilAbove@.
+4) The arguments of @Union@ are either @TextBeside@, or @NilAbove@.
 
 
-  5) A @NoDoc@ may only appear on the first line of the left argument of an
-     union. Therefore, the right argument of an union can never be equivalent
-     to the empty set (@NoDoc@).
+5) A @NoDoc@ may only appear on the first line of the left argument of an
+   union. Therefore, the right argument of an union can never be equivalent
+   to the empty set (@NoDoc@).
 
 
-  6) An empty document is always represented by @Empty@.  It can't be
-     hidden inside a @Nest@, or a @Union@ of two @Empty@s.
+6) An empty document is always represented by @Empty@.  It can't be
+   hidden inside a @Nest@, or a @Union@ of two @Empty@s.
 
 
-  7) The first line of every layout in the left argument of @Union@ is
-     longer than the first line of any layout in the right argument.
-     (1) ensures that the left argument has a first line.  In view of
-     (3), this invariant means that the right argument must have at
-     least two lines.
+7) The first line of every layout in the left argument of @Union@ is
+   longer than the first line of any layout in the right argument.
+   (1) ensures that the left argument has a first line.  In view of
+   (3), this invariant means that the right argument must have at
+   least two lines.
 
 
- Notice the difference between
-         * NoDoc (no documents)
-         * Empty (one empty document; no height and no width)
-         * text "" (a document containing the empty string;
-                    one line high, but has no width)
+Notice the difference between
+   * NoDoc (no documents)
+   * Empty (one empty document; no height and no width)
+   * text "" (a document containing the empty string;
+              one line high, but has no width)
 -}
 
 
 -}
 
 
@@ -331,7 +327,6 @@ lbrack :: Doc -- ^ A '[' character
 rbrack :: Doc -- ^ A ']' character
 lbrace :: Doc -- ^ A '{' character
 rbrace :: Doc -- ^ A '}' character
 rbrack :: Doc -- ^ A ']' character
 lbrace :: Doc -- ^ A '{' character
 rbrace :: Doc -- ^ A '}' character
-semi   = char ';'
 comma  = char ','
 colon  = char ':'
 space  = char ' '
 comma  = char ','
 colon  = char ':'
 space  = char ' '
@@ -503,9 +498,8 @@ above (Above p g1 q1)  g2 q2 = above p g1 (above q1 g2 q2)
 above p@(Beside _ _ _) g  q  = aboveNest (reduceDoc p) g 0 (reduceDoc q)
 above p g q                  = aboveNest p             g 0 (reduceDoc q)
 
 above p@(Beside _ _ _) g  q  = aboveNest (reduceDoc p) g 0 (reduceDoc q)
 above p g q                  = aboveNest p             g 0 (reduceDoc q)
 
-aboveNest :: RDoc a -> Bool -> Int -> RDoc a -> RDoc a
 -- Specfication: aboveNest p g k q = p $g$ (nest k q)
 -- Specfication: aboveNest p g k q = p $g$ (nest k q)
-
+aboveNest :: RDoc a -> Bool -> Int -> RDoc a -> RDoc a
 aboveNest _                   _ k _ | k `seq` False = undefined
 aboveNest NoDoc               _ _ _ = NoDoc
 aboveNest (p1 `Union` p2)     g k q = aboveNest p1 g k q `union_`
 aboveNest _                   _ k _ | k `seq` False = undefined
 aboveNest NoDoc               _ _ _ = NoDoc
 aboveNest (p1 `Union` p2)     g k q = aboveNest p1 g k q `union_`
@@ -525,15 +519,13 @@ aboveNest (TextBeside s sl p) g k q = textBeside_ s sl rest
 aboveNest (Above {})          _ _ _ = error "aboveNest Above"
 aboveNest (Beside {})         _ _ _ = error "aboveNest Beside"
 
 aboveNest (Above {})          _ _ _ = error "aboveNest Above"
 aboveNest (Beside {})         _ _ _ = error "aboveNest Beside"
 
-nilAboveNest :: Bool -> Int -> RDoc a -> RDoc a
 -- Specification: text s <> nilaboveNest g k q
 --              = text s <> (text "" $g$ nest k q)
 -- Specification: text s <> nilaboveNest g k q
 --              = text s <> (text "" $g$ nest k q)
-
+nilAboveNest :: Bool -> Int -> RDoc a -> RDoc a
 nilAboveNest _ k _           | k `seq` False = undefined
 nilAboveNest _ _ Empty       = Empty
                                -- Here's why the "text s <>" is in the spec!
 nilAboveNest g k (Nest k1 q) = nilAboveNest g (k + k1) q
 nilAboveNest _ k _           | k `seq` False = undefined
 nilAboveNest _ _ Empty       = Empty
                                -- Here's why the "text s <>" is in the spec!
 nilAboveNest g k (Nest k1 q) = nilAboveNest g (k + k1) q
-
 nilAboveNest g k q           | not g && k > 0      -- No newline if no overlap
                              = textBeside_ (Str (indent k)) k q
                              | otherwise           -- Put them really above
 nilAboveNest g k q           | not g && k > 0      -- No newline if no overlap
                              = textBeside_ (Str (indent k)) k q
                              | otherwise           -- Put them really above
@@ -562,9 +554,8 @@ beside_ p _ Empty = p
 beside_ Empty _ q = q
 beside_ p g q     = Beside p g q
 
 beside_ Empty _ q = q
 beside_ p g q     = Beside p g q
 
-beside :: Doc -> Bool -> RDoc a -> RDoc a
 -- Specification: beside g p q = p <g> q
 -- Specification: beside g p q = p <g> q
-
+beside :: Doc -> Bool -> RDoc a -> RDoc a
 beside NoDoc               _ _   = NoDoc
 beside (p1 `Union` p2)     g q   = beside p1 g q `union_` beside p2 g q
 beside Empty               _ q   = q
 beside NoDoc               _ _   = NoDoc
 beside (p1 `Union` p2)     g q   = beside p1 g q `union_` beside p2 g q
 beside Empty               _ q   = q
@@ -580,10 +571,9 @@ beside (TextBeside s sl p) g q   = textBeside_ s sl $! rest
                                            Empty -> nilBeside g q
                                            _     -> beside p g q
 
                                            Empty -> nilBeside g q
                                            _     -> beside p g q
 
-nilBeside :: Bool -> RDoc a -> RDoc a
 -- Specification: text "" <> nilBeside g p
 --              = text "" <g> p
 -- Specification: text "" <> nilBeside g p
 --              = text "" <g> p
-
+nilBeside :: Bool -> RDoc a -> RDoc a
 nilBeside _ Empty         = Empty -- Hence the text "" in the spec
 nilBeside g (Nest _ p)    = nilBeside g p
 nilBeside g p | g         = textBeside_ space_text 1 p
 nilBeside _ Empty         = Empty -- Hence the text "" in the spec
 nilBeside g (Nest _ p)    = nilBeside g p
 nilBeside g p | g         = textBeside_ space_text 1 p
@@ -613,7 +603,6 @@ sepX x (p:ps) = sep1 x (reduceDoc p) 0 ps
 -- Specification: sep1 g k ys = sep (x : map (nest k) ys)
 --                            = oneLiner (x <g> nest k (hsep ys))
 --                              `union` x $$ nest k (vcat ys)
 -- Specification: sep1 g k ys = sep (x : map (nest k) ys)
 --                            = oneLiner (x <g> nest k (hsep ys))
 --                              `union` x $$ nest k (vcat ys)
-
 sep1 :: Bool -> RDoc a -> Int -> [Doc] -> RDoc a
 sep1 _ _                   k _  | k `seq` False = undefined
 sep1 _ NoDoc               _ _  = NoDoc
 sep1 :: Bool -> RDoc a -> Int -> [Doc] -> RDoc a
 sep1 _ _                   k _  | k `seq` False = undefined
 sep1 _ NoDoc               _ _  = NoDoc
@@ -629,16 +618,15 @@ sep1 g (TextBeside s sl p) k ys = textBeside_ s sl (sepNB g p (k - sl) ys)
 sep1 _ (Above {})          _ _  = error "sep1 Above"
 sep1 _ (Beside {})         _ _  = error "sep1 Beside"
 
 sep1 _ (Above {})          _ _  = error "sep1 Above"
 sep1 _ (Beside {})         _ _  = error "sep1 Beside"
 
-sepNB :: Bool -> Doc -> Int -> [Doc] -> Doc
 -- Specification: sepNB p k ys = sep1 (text "" <> p) k ys
 -- Called when we have already found some text in the first item
 -- We have to eat up nests
 -- Specification: sepNB p k ys = sep1 (text "" <> p) k ys
 -- Called when we have already found some text in the first item
 -- We have to eat up nests
-
+sepNB :: Bool -> Doc -> Int -> [Doc] -> Doc
 sepNB g (Nest _ p) k ys
   = sepNB g p k ys -- Never triggered, because of invariant (2)
 sepNB g Empty k ys
   = oneLiner (nilBeside g (reduceDoc rest)) `mkUnion`
 sepNB g (Nest _ p) k ys
   = sepNB g p k ys -- Never triggered, because of invariant (2)
 sepNB g Empty k ys
   = oneLiner (nilBeside g (reduceDoc rest)) `mkUnion`
--- XXX: PRETTY: Used True here
+    -- XXX: TODO: PRETTY: Used True here
     nilAboveNest False k (reduceDoc (vcat ys))
   where
     rest | g         = hsep ys
     nilAboveNest False k (reduceDoc (vcat ys))
   where
     rest | g         = hsep ys
@@ -703,7 +691,7 @@ fillNB g p k ys             = fill1 g p k ys
 fillNBE :: Bool -> Int -> Doc -> [Doc] -> Doc
 fillNBE g k y ys
   = nilBeside g (fill1 g ((elideNest . oneLiner . reduceDoc) y) k' ys)
 fillNBE :: Bool -> Int -> Doc -> [Doc] -> Doc
 fillNBE g k y ys
   = nilBeside g (fill1 g ((elideNest . oneLiner . reduceDoc) y) k' ys)
--- XXX: PRETTY: Used True here
+    -- XXX: TODO: PRETTY: Used True here
     `mkUnion` nilAboveNest False k (fill g (y:ys))
   where k' = if g then k - 1 else k
 
     `mkUnion` nilAboveNest False k (fill g (y:ys))
   where k' = if g then k - 1 else k
 
diff --git a/test/Bench1.hs b/test/Bench1.hs
new file mode 100644 (file)
index 0000000..c3a0661
--- /dev/null
@@ -0,0 +1,56 @@
+module Main where
+
+import Text.PrettyPrint.HughesPJ
+-- import Pretty
+
+stuff :: String -> String -> Double -> Rational -> Int -> Int -> Int -> Doc
+stuff s1 s2 d1 r1 i1 i2 i3 =
+    let a = nest i1 $ text s1
+        b = double d1
+        c = rational r1
+        d = replicate i1 (text s2 <> b <> c <+> a)
+        e = cat d $+$ cat d $$ (c <> b <+> a)
+        f = parens e <> brackets c <> hcat d
+        g = lparen <> f <> rparen
+        h = text $ s2 ++ s1
+        i = map rational ([1..(toRational i2)]::[Rational])
+        j = punctuate comma i
+        k = nest i3 h <> (nest (i1 + i3) $ sep i) $+$ g <> cat j
+        l = cat $ punctuate (comma <> b <> comma) $ replicate i3 k
+    in l
+
+doc1 :: Doc
+doc1 = stuff "Adsas ads" "dassdab weeaa xxxxx" 123.231321 ((-1)/5) 30 300 20
+
+doc2 :: Doc
+doc2 = stuff "aDSAS ADS asdasdsa sdsda xx" "SDAB WEEAA" 1333.212 ((-4)/5) 31 301 30
+
+doc3 :: Doc
+doc3 = stuff "ADsAs --____ aDS" "DasSdAB weEAA" 2533.21299 ((-4)/999) 39 399 60
+
+{-
+txt :: TextDetails -> String -> String
+txt (Chr c)   s  = c:s
+txt (Str s1)  s2 = s1 ++ s2
+-}
+
+main :: IO ()
+main = do
+    putStrLn "==================================================="
+    putStrLn $ render doc1
+{-
+    putStrLn "==================================================="
+    putStrLn $ fullRender PageMode 1000 4 txt "" doc2
+    putStrLn "==================================================="
+    putStrLn $ fullRender PageMode 100 1.5 txt "" doc2
+    putStrLn "==================================================="
+    putStrLn $ fullRender ZigZagMode 1000 4 txt "" doc2
+    putStrLn "==================================================="
+    putStrLn $ fullRender LeftMode 1000 4 txt "" doc2
+    putStrLn "==================================================="
+    putStrLn $ fullRender OneLineMode 1000 4 txt "" doc3
+    putStrLn "==================================================="
+-}
+    putStrLn $ render doc3
+
+
diff --git a/test/BugSep.hs b/test/BugSep.hs
new file mode 100644 (file)
index 0000000..6b343c6
--- /dev/null
@@ -0,0 +1,30 @@
+--
+import Text.PrettyPrint.HughesPJ
+main :: IO ()
+main = do
+    putStrLn ""
+    putStrLn "Note that the correct definition of sep is currently unclear"
+    putStrLn "It is neither foldr ($+$) empty nor foldr ($$) empty"    
+    putStrLn "------------------------------------------------------------"
+    let test1 = [ text "" $+$  text "c", nest 3 ( text "a") ]
+    let test2 = [ text "c", nest 3 ( text "b") ]
+    putStrLn "--------------------------Test 1----------------------------"
+    putStrLn "[ text \"\" $+$  text \"c\", nest 3 ( text \"a\") ]"
+    putStrLn "-----------------------------sep----------------------------"
+    print $ renderStyle style{lineLength=1} $ sep test1
+    putStrLn "-----------------------------<+>----------------------------"
+    print $ renderStyle style{lineLength=1} $ foldr (<+>) empty test1
+    putStrLn "-----------------------------$+$----------------------------"
+    print $ renderStyle style{lineLength=1} $ foldr ($+$) empty test1
+    putStrLn "------------------------------$$----------------------------"
+    print $ renderStyle style{lineLength=1} $ foldr ($$)  empty test1
+    putStrLn "--------------------------Test 2----------------------------"
+    putStrLn "[ text \"c\", nest 3 ( text \"b\") ]"
+    putStrLn "-----------------------------sep----------------------------"
+    print $ renderStyle style{lineLength=1} $ sep test2
+    putStrLn "-----------------------------<+>----------------------------"
+    print $ renderStyle style{lineLength=1} $ foldr (<+>) empty test2
+    putStrLn "-----------------------------$+$----------------------------"
+    print $ renderStyle style{lineLength=1} $ foldr ($+$) empty test2
+    putStrLn "------------------------------$$----------------------------"
+    print $ renderStyle style{lineLength=1} $ foldr ($$)  empty test2
diff --git a/test/PrettyTestVersion.hs b/test/PrettyTestVersion.hs
new file mode 100644 (file)
index 0000000..4a7cf6b
--- /dev/null
@@ -0,0 +1,10 @@
+{-# LANGUAGE CPP #-}
+
+#define TESTING
+
+-- | Here we use some CPP hackery to get a whitebox
+-- version of HughesPJ for testing purposes.
+module PrettyTestVersion where
+
+#include "HughesPJ.hs"
+
diff --git a/test/Test.hs b/test/Test.hs
new file mode 100644 (file)
index 0000000..4053471
--- /dev/null
@@ -0,0 +1,1066 @@
+{-# OPTIONS -XStandaloneDeriving -XDeriveDataTypeable -XPackageImports #-}
+-----------------------------------------------------------------------------
+-- Module      :  HughesPJQuickCheck
+-- Copyright   :  (c) 2008 Benedikt Huber
+-- License     :  BSD-style
+--
+-- QuickChecks for HughesPJ pretty printer.
+-- 
+-- 1) Testing laws (blackbox)
+--    - CDoc (combinator datatype)
+-- 2) Testing invariants (whitebox)
+-- 3) Testing bug fixes (whitebox)
+--
+-----------------------------------------------------------------------------
+import {- whitebox -} PrettyTestVersion
+
+import Test.QuickCheck
+import Control.Monad
+import Debug.Trace
+import Data.Char (isSpace)
+import Data.List (intersperse)
+
+-- tweaked to perform many small tests
+myConfig :: Int -> Int -> Config
+myConfig d n = defaultConfig { configMaxTest = n, configMaxFail = n*5, configSize =  (+2) . (`div` n) . (*d)  }
+
+myTest :: (Testable a) => String -> a -> IO ()
+myTest = myTest' 15 maxTests
+maxTests = 1000
+myTest' :: (Testable a) => Int -> Int -> String -> a -> IO ()
+myTest' d k msg t = putStrLn (" * "++msg) >> check (myConfig d k) t
+
+myAssert :: String -> Bool -> IO ()
+myAssert msg b = putStrLn $ (if b then "Ok, passed " else "Failed test:\n  ")++msg
+
+main :: IO ()
+main = do
+    check_laws 
+    check_invariants
+    check_improvements
+    check_non_prims -- hpc full coverage
+    check_rendering
+    check_list_def
+
+
+-- Additional HPC misses:
+-- mkNest _       NoDoc       = NoDoc
+
+
+-- Quickcheck tests
+
+-- Equalities on Documents
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+-- compare text details
+tdEq :: TextDetails -> TextDetails -> Bool
+tdEq td1 td2 = (tdToStr td1) == (tdToStr td2)
+
+-- algebraic equality on reduced docs
+docEq :: RDoc -> RDoc -> Bool
+docEq rd1 rd2 = case (rd1, rd2) of
+    (Empty, Empty) -> True
+    (NoDoc, NoDoc) -> True
+    (NilAbove ds1, NilAbove ds2) -> docEq ds1 ds2
+    (TextBeside td1 l1 ds1, TextBeside td2 l2 ds2) | td1 `tdEq` td2 -> docEq ds1 ds2
+    (Nest k1 d1, Nest k2 d2) | k1 == k2 -> docEq d1 d2
+    (Union d11 d12, Union d21 d22) -> docEq d11 d21 && docEq d12 d22
+    (d1,d2) -> False
+    
+-- algebraic equality, with text reduction
+deq :: Doc -> Doc -> Bool
+deq d1 d2 = docEq (reduceDoc' d1) (reduceDoc' d2) where
+    reduceDoc' = mergeTexts . reduceDoc
+deqs :: [Doc] -> [Doc] -> Bool
+deqs ds1 ds2 = 
+    case zipE ds1 ds2 of
+        Nothing    -> False
+        (Just zds) -> all (uncurry deq) zds
+
+        
+zipLayouts :: Doc -> Doc -> Maybe [(Doc,Doc)]
+zipLayouts d1 d2 = zipE (reducedDocs d1) (reducedDocs d2)
+    where        
+    reducedDocs = map mergeTexts . flattenDoc
+zipE l1 l2 | length l1 == length l2 = Just $ zip l1 l2
+           | otherwise              = Nothing
+
+-- algebraic equality for layouts (without permutations)
+lseq :: Doc -> Doc -> Bool
+lseq d1 d2 = maybe False id . fmap (all (uncurry docEq)) $ zipLayouts d1 d2
+
+-- abstract render equality for layouts
+-- should only be performed if the number of layouts is reasonably small
+rdeq :: Doc -> Doc -> Bool
+rdeq d1 d2 = 
+    maybe False id . fmap (all (uncurry layoutEq)) $ zipLayouts d1 d2
+    where
+        layoutEq d1 d2 = (abstractLayout d1) == (abstractLayout d2)
+
+layoutsCountBounded :: Int -> [Doc] -> Bool
+layoutsCountBounded k docs = isBoundedBy k (concatMap flattenDoc docs) where
+    isBoundedBy k [] = True
+    isBoundedBy 0 (x:xs) = False
+    isBoundedBy k (x:xs) = isBoundedBy (k-1) xs
+layoutCountBounded :: Int -> Doc -> Bool
+layoutCountBounded k doc = layoutsCountBounded k [doc]
+maxLayouts :: Int
+maxLayouts = 64
+
+infix 4 `deq`
+infix 4 `lseq`
+infix 4 `rdeq`
+
+debugRender :: Int -> Doc -> IO ()
+debugRender k = putStr . visibleSpaces . renderStyle (Style PageMode k 1)
+visibleSpaces = unlines . map (map visibleSpace) . lines
+
+visibleSpace :: Char -> Char
+visibleSpace ' ' = '.'
+visibleSpace '.' = error "dot in visibleSpace (avoid confusion, please)"
+visibleSpace  c  = c
+
+-- shorthands debug functions
+pd = (print.prettyDoc)
+pds = mapM_ pd
+rds = (map mergeTexts.flattenDoc)
+
+
+-- (1) QuickCheck Properties: Laws
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+{-
+Monoid laws for <>,<+>,$$,$+$
+~~~~~~~~~~~~~
+<a,b 1> (x * y) * z   = x * (y * z)
+<a,b 2> empty * x     = x
+<a,b 3> x * empty     = x
+-}
+prop_1 op x y z = classify (any isEmpty [x,y,z]) "empty x, y or z" $
+                   ((x `op` y) `op` z) `deq` (x `op` (y `op` z))
+prop_2 op x     = classify (isEmpty x) "empty" $ (empty `op` x) `deq` x
+prop_3 op x     = classify (isEmpty x) "empty" $ x `deq` (empty `op` x)
+
+check_monoid = do
+    putStrLn " = Monoid Laws ="
+    mapM_ (myTest' 5 maxTests "Associativity") [ liftDoc3 (prop_1 op) | op <- allops ]
+    mapM_ (myTest "Left neutral") [ prop_2 op . buildDoc | op <- allops ]
+    mapM_ (myTest "Right neutral") [ prop_3 op . buildDoc | op <- allops ]
+    where
+    allops = [ (<>), (<+>) ,($$) , ($+$) ]
+
+{-
+Laws for text
+~~~~~~~~~~~~~
+<t1>    text s <> text t        = text (s++t)
+<t2>    text "" <> x            = x, if x non-empty [only true if x does not start with nest, because of <n6> ]
+-}
+prop_t1 s t = text' s <> text' t `deq` text (unText s ++  unText t)
+prop_t2  x   = not (isEmpty x) ==> text "" <> x `deq` x
+prop_t2_a x   = not (isEmpty x) && not (isNest x) ==> text "" <> x `deq` x
+
+isNest :: Doc -> Bool
+isNest d = case reduceDoc d of
+    (Nest _ _) -> True
+    (Union d1 d2) -> isNest d1 || isNest d2
+    _ -> False
+
+check_t = do
+    putStrLn " = Text laws ="
+    myTest "t1" prop_t1
+    myTest "t2_a (precondition: x does not start with nest)" (prop_t2_a . buildDoc)
+    myTest "t_2 (Known to fail)" (prop_t2 . buildDoc)
+
+{-
+Laws for nest
+~~~~~~~~~~~~~
+<n1>    nest 0 x                = x
+<n2>    nest k (nest k' x)      = nest (k+k') x
+<n3>    nest k (x <> y)         = nest k z <> nest k y
+<n4>    nest k (x $$ y)         = nest k x $$ nest k y
+<n5>    nest k empty            = empty
+<n6>    x <> nest k y           = x <> y, if x non-empty
+-}
+prop_n1 x      = nest 0 x                `deq` x
+prop_n2 k k' x = nest k (nest k' x)      `deq` nest (k+k') x
+prop_n3 k k' x  = nest k (nest k' x)      `deq` nest (k+k') x 
+prop_n4 k x y  = nest k (x $$ y)         `deq` nest k x $$ nest k y
+prop_n5 k     =  nest k empty            `deq` empty
+prop_n6 x k y =  not (isEmpty x) ==>  
+                 x <> nest k y           `deq` x <> y
+check_n = do
+    putStrLn "Nest laws"
+    myTest "n1" (prop_n1 . buildDoc)
+    myTest "n2" (\k k' -> prop_n2 k k' . buildDoc)
+    myTest "n3" (\k k' -> prop_n3 k k' . buildDoc)
+    myTest "n4" (\k -> liftDoc2 (prop_n4 k))
+    myTest "n5" prop_n5
+    myTest "n6" (\k -> liftDoc2 (\x -> prop_n6 x k))
+
+{-
+<m1>    (text s <> x) $$ y = text s <> ((text "" <> x)) $$ 
+                                         nest (-length s) y)
+
+<m2>    (x $$ y) <> z = x $$ (y <> z)
+        if y non-empty
+-}    
+prop_m1 s x y = (text' s <> x) $$ y `deq` text' s <> ((text "" <> x) $$ 
+                 nest (-length (unText s)) y)
+prop_m2 x y z = not (isEmpty y) ==>
+                (x $$ y) <> z      `deq` x $$ (y <> z)
+check_m = do
+    putStrLn "Misc laws"
+    myTest "m1" (\s -> liftDoc2 (prop_m1 s))
+    myTest' 10 maxTests "m2" (liftDoc3 prop_m2)
+
+
+{-
+Laws for list versions
+~~~~~~~~~~~~~~~~~~~~~~
+<l1>    sep (ps++[empty]++qs)   = sep (ps ++ qs)
+        ...ditto hsep, hcat, vcat, fill...
+[ Fails for fill ! ]
+<l2>    nest k (sep ps) = sep (map (nest k) ps)
+        ...ditto hsep, hcat, vcat, fill...
+-}    
+prop_l1 sp ps qs = 
+    sp (ps++[empty]++qs)   `rdeq` sp (ps ++ qs)
+prop_l2 sp k ps  = nest k (sep ps)        `deq` sep (map (nest k) ps)
+
+
+prop_l1' sp cps cqs =
+    let [ps,qs] = map buildDocList [cps,cqs] in 
+    layoutCountBounded maxLayouts (sp (ps++qs)) ==> prop_l1 sp ps qs
+prop_l2' sp k  ps = prop_l2 sp k (buildDocList ps)
+check_l = do
+    allCats $ myTest "l1" . prop_l1'
+    allCats $ myTest "l2" . prop_l2'
+    where
+    allCats = flip mapM_ [ sep, hsep, cat, hcat, vcat, fsep, fcat ]
+prop_l1_fail_1 = [ text "a" ]
+prop_l1_fail_2 = [ text "a" $$  text "b" ]
+
+{-
+Laws for oneLiner
+~~~~~~~~~~~~~~~~~
+<o1>    oneLiner (nest k p) = nest k (oneLiner p)
+<o2>    oneLiner (x <> y)   = oneLiner x <> oneLiner y 
+
+[One liner only takes reduced arguments]
+-}    
+oneLinerR = oneLiner . reduceDoc
+prop_o1 k p = oneLinerR (nest k p) `deq` nest k (oneLinerR p)
+prop_o2 x y = oneLinerR (x <> y) `deq` oneLinerR x <> oneLinerR y 
+
+check_o = do
+    putStrLn "oneliner laws"
+    myTest "o1 (RDoc arg)" (\k p -> prop_o1 k (buildDoc p))
+    myTest "o2 (RDoc arg)" (liftDoc2 prop_o2)
+
+{-
+Definitions of list versions
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+<ldef1> vcat = foldr ($$) empty
+<ldef2> hcat = foldr (<>) empty
+<ldef3> hsep = foldr (<+>) empty
+-}
+prop_hcat :: [Doc] -> Bool
+prop_hcat ds = hcat ds `deq` (foldr (<>) empty) ds
+prop_hsep :: [Doc] -> Bool
+prop_hsep ds = hsep ds `deq` (foldr (<+>) empty) ds
+prop_vcat :: [Doc] -> Bool
+prop_vcat ds = vcat ds `deq` (foldr ($$) empty) ds
+
+{-
+Update (pretty-1.1.0):
+*failing* definition of sep: oneLiner (hsep ps) `union` vcat ps
+<ldef4> ?
+-}
+prop_sep :: [Doc] -> Bool
+prop_sep ds = sep ds `rdeq` (sepDef ds)
+sepDef :: [Doc] -> Doc
+sepDef docs = let ds = filter (not . isEmpty) docs in
+              case ds of
+                  [] -> empty
+                  [d] -> d
+                  ds -> reduceDoc (oneLiner (reduceDoc $ hsep ds) 
+                                    `Union`
+                                  (reduceDoc $ foldr ($+$) empty ds))
+
+check_list_def = do 
+    myTest "hcat def" (prop_hcat . buildDocList) 
+    myTest "hsep def" (prop_hsep . buildDocList) 
+    myTest "vcat def" (prop_vcat . buildDocList) 
+    myTest "sep def" (prop_sep . buildDocList)
+{-
+Definition of fill (fcat/fsep)
+-- Specification: 
+--   fill []  = empty
+--   fill [p] = p
+--   fill (p1:p2:ps) = oneLiner p1 <#> nest (length p1) 
+--                                          (fill (oneLiner p2 : ps))
+--                     `union`
+--                      p1 $$ fill ps
+-- Revised Specification:
+--   fill g docs = fillIndent 0 docs
+--
+--   fillIndent k [] = []
+--   fillIndent k [p] = p
+--   fillIndent k (p1:p2:ps) =
+--      oneLiner p1 <g> fillIndent (k + length p1 + g ? 1 : 0) (remove_nests (oneLiner p2) : ps)
+--       `Union`
+--      (p1 $*$ nest (-k) (fillIndent 0 ps)) 
+--
+-- $*$ is defined for layouts (not Docs) as 
+-- layout1 $*$ layout2 | isOneLiner layout1 = layout1 $+$ layout2
+--                     | otherwise          = layout1 $$ layout2
+--
+-- Old implementation ambiguities/problems:
+-- ========================================
+-- Preserving nesting:
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- fcat [cat[ text "b", text "a"], nest 2 ( text "" $$  text "a")]
+-- ==> fcat [ text "b" $$ text "a", nest 2 (text "" $$ text "a")]   // cat: union right
+-- ==> (text "b" $$ text "a" $$ nest 2 (text "" $$ text "a"))       // fcat: union right with overlap
+-- ==> (text "ab" $$ nest 2 (text "" $$ text "a"))
+-- ==> "b\na\n..a"
+-- Bug #1337:
+-- ~~~~~~~~~~
+-- > fcat [ nest 1 $ text "a", nest 2 $ text "b", text "c"]
+-- ==> [second alternative] roughly (a <#> b $#$ c)
+-- " ab"
+-- "c  "
+-- expected: (nest 1; text "a"; text "b"; nest -3; "c")
+-- actual  : (nest 1; text "a"; text "b"; nest -5; "c")
+-- === (nest 1; text a) <> (fill (-2) (p2:ps))
+-- ==>                     (nest 2 (text "b") $+$ text "c")    
+-- ==>                     (nest 2 (text "b") `nilabove` nest (-3) (text "c"))
+-- ==> (nest 1; text a; text b; nest -5 c)
+
+-}
+prop_fcat_vcat :: [Doc] -> Bool
+prop_fcat_vcat ds = last (flattenDoc $ fcat ds) `deq` last (flattenDoc $ vcat ds)
+prop_fcat :: [Doc] -> Bool
+prop_fcat ds = fcat ds `rdeq` fillDef False (filter (not . isEmpty) ds)
+prop_fsep :: [Doc] -> Bool
+prop_fsep ds = fsep ds `rdeq` fillDef True (filter (not . isEmpty) ds)
+prop_fcat_old :: [Doc] -> Bool
+prop_fcat_old ds = fillOld2 False ds `rdeq` fillDef False (filter (not . isEmpty) ds)
+prop_fcat_old_old :: [Doc] -> Bool
+prop_fcat_old_old ds = fillOld2 False ds `rdeq` fillDefOld False (filter (not . isEmpty) ds)
+
+prop_restrict_sz :: (Testable a) => Int -> ([Doc] -> a) -> ([Doc] -> Property) 
+prop_restrict_sz k p ds = layoutCountBounded k (fsep ds) ==> p ds
+prop_restrict_ol :: (Testable a) => ([Doc] -> a) -> ([Doc] -> Property)
+prop_restrict_ol p ds = (all isOneLiner . map normalize $ ds) ==> p ds
+prop_restrict_no_nest_start :: (Testable a) => ([Doc] -> a) -> ([Doc] -> Property)
+prop_restrict_no_nest_start p ds = (all (not .isNest) ds) ==> p ds
+
+fillDef :: Bool -> [Doc] -> Doc
+fillDef g = normalize . fill' 0 . filter (not.isEmpty) . map reduceDoc where
+    fill' _ [] = Empty
+    fill' _ [x] = x    
+    fill' k (p1:p2:ps) =
+        reduceDoc (oneLiner p1 `append` (fill' (k + firstLineLength p1 + (if g then 1 else 0)) $ (oneLiner' p2) : ps))
+            `union`
+        reduceDoc (p1 $*$ (nest (-k) (fillDef g (p2:ps))))
+    union = Union
+    append = if g then (<+>) else (<>)    
+    oneLiner' (Nest k d) = oneLiner' d
+    oneLiner' d = oneLiner d
+($*$) :: RDoc -> RDoc -> RDoc
+($*$) p ps = case flattenDoc p of
+    [] -> NoDoc
+    ls -> foldr1 Union (map combine ls) 
+    where
+    combine p | isOneLiner p = p $+$ ps
+              | otherwise    = p $$  ps
+
+fillDefOld :: Bool -> [Doc] -> Doc
+fillDefOld g = normalize . fill' . filter (not.isEmpty) . map normalize where 
+    fill' [] = Empty
+    fill' [p1] = p1
+    fill' (p1:p2:ps) = (normalize (oneLiner p1 `append` nest (firstLineLength p1) 
+                                         (fill' (oneLiner p2 : ps))))
+                    `union`
+                     (p1 $$ fill' (p2:ps))
+    append = if g then (<+>) else (<>)
+    union = Union
+
+check_fill_prop msg p = myTest msg (prop_restrict_sz maxLayouts p . buildDocList)
+check_fill_def_fail = do 
+    check_fill_prop "fcat defOld vs fcatOld (ol)" (prop_restrict_ol prop_fcat_old_old)
+    check_fill_prop "fcat defOld vs fcatOld" prop_fcat_old_old
+
+    check_fill_prop "fcat def (ol) vs fcatOld" (prop_restrict_ol prop_fcat_old)
+    check_fill_prop "fcat def vs fcatOld" prop_fcat_old 
+check_fill_def_ok = do
+    check_fill_prop "fcat def (not nest start) vs fcatOld" (prop_restrict_no_nest_start prop_fcat_old)
+
+    check_fill_prop "fcat def (not nest start) vs fcat" (prop_restrict_no_nest_start prop_fcat)
+    check_fill_prop "fcat def (ol) vs fcat" (prop_restrict_ol prop_fcat)
+    check_fill_prop "fcat def vs fcat" prop_fcat 
+    check_fill_prop "fsep def vs fsep" prop_fsep 
+check_fill_def_laws = do
+    check_fill_prop "lastLayout (fcat ps) == vcat ps" prop_fcat_vcat
+check_fill_def = check_fill_def_fail >> check_fill_def_ok
+{-
+text "ac"; nilabove; nest -1; text "a"; empty
+text "ac"; nilabove; nest -2; text "a"; empty
+-}
+
+{-
+Zero width text (Neil)
+
+Here it would be convenient to generate functions (or replace empty / text bz z-w-t)
+-}
+-- TODO
+{- 
+All laws: monoid, text, nest, misc, list versions, oneLiner, list def
+-}
+check_laws = do
+    check_fill_def_ok
+    check_monoid
+    check_t
+    check_n
+    check_m
+    check_l
+    check_o
+    check_list_def
+
+-- (2) QuickCheck Properties: Invariants (whitebox)
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+-- strategies: synthesize with stop condition
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+stop :: a -> (a, Bool)
+stop a = (a,False)
+recurse :: a -> (a, Bool)
+recurse a = (a,True)
+-- strategy: generic synthesize with stop condition 
+-- terms are combined top-down, left-right (latin text order)
+genericProp :: (a -> a -> a) -> (Doc -> (a,Bool)) -> Doc -> a
+genericProp c q doc =
+    case q doc of
+        (v,False) -> v
+        (v,True)  -> foldl c v (subs doc)
+    where
+        rec = genericProp c q
+        subs d = case d of
+            Empty            -> []
+            NilAbove d       -> [rec d]
+            TextBeside _ _ d -> [rec d]
+            Nest _ d         -> [rec d]
+            Union d1 d2      -> [rec d1, rec d2]
+            NoDoc            -> []
+            Beside d1 _ d2   -> subs (reduceDoc d)
+            Above d1 _ d2    -> subs (reduceDoc d)
+
+
+{-
+ * The argument of NilAbove is never Empty. Therefore
+    a NilAbove occupies at least two lines.
+-}
+prop_inv1 :: Doc -> Bool
+prop_inv1 d = genericProp (&&) nilAboveNotEmpty d where
+    nilAboveNotEmpty (NilAbove Empty) = stop False
+    nilAboveNotEmpty _ = recurse True
+
+{-
+  * The argument of @TextBeside@ is never @Nest@.  
+-}
+prop_inv2 :: Doc -> Bool
+prop_inv2 = genericProp (&&) textBesideNotNest where
+    textBesideNotNest (TextBeside _ _ (Nest _ _)) = stop False
+    textBesideNotNest _ = recurse True
+{-
+  * The layouts of the two arguments of @Union@ both flatten to the same 
+    string 
+-}
+prop_inv3 :: Doc -> Bool
+prop_inv3 = genericProp (&&) unionsFlattenSame where
+    unionsFlattenSame (Union d1 d2) = stop (pairwiseEqual (extractTexts d1 ++ extractTexts d2))
+    unionsFlattenSame _ = recurse True
+pairwiseEqual (x:y:zs) = x==y && pairwiseEqual (y:zs)
+pairwiseEqual _ = True
+
+
+{-
+  * The arguments of @Union@ are either @TextBeside@, or @NilAbove@.
+-}
+prop_inv4 :: Doc -> Bool
+prop_inv4 = genericProp (&&) unionArgs where
+    unionArgs (Union d1 d2) | goodUnionArg d1 && goodUnionArg d2 = recurse True
+                            | otherwise = stop False
+    unionArgs _ = recurse True
+    goodUnionArg (TextBeside _ _ _) = True
+    goodUnionArg (NilAbove _) = True
+    goodUnionArg _ = False
+  
+{-
+  * A @NoDoc@ may only appear on the first line of the left argument of
+    an union. Therefore, the right argument of an union can never be equivalent
+    to the empty set.
+-}
+prop_inv5 :: Doc -> Bool
+prop_inv5 = genericProp (&&) unionArgs . reduceDoc where
+    unionArgs NoDoc = stop False
+    unionArgs (Union d1 d2) = stop $ genericProp (&&) noDocIsFirstLine d1 && nonEmptySet (reduceDoc d2)
+    unionArgs _ = (True,True) -- recurse
+    noDocIsFirstLine (NilAbove d)    = stop $ genericProp (&&) unionArgs d
+    noDocIsFirstLine _               = recurse True
+
+{-
+  * An empty document is always represented by @Empty@.  It can't be
+    hidden inside a @Nest@, or a @Union@ of two @Empty@s.
+-}
+prop_inv6 :: Doc -> Bool
+prop_inv6 d | not (prop_inv1 d) || not (prop_inv2 d) = False
+            | not (isEmptyDoc d) = True
+            | otherwise = case d of Empty -> True ; _ -> False
+
+isEmptyDoc :: Doc -> Bool
+isEmptyDoc d = case emptyReduction d of Empty -> True; _ -> False
+
+{-
+  * Consistency
+  If all arguments of one of the list versions are empty documents, the list is an empty document
+-}
+prop_inv6a :: ([Doc] -> Doc) -> [Doc] -> Property
+prop_inv6a sep ds = all isEmptyDoc ds ==> isEmptyRepr (sep ds) where
+    isEmptyRepr Empty = True
+    isEmptyRepr _ = False
+
+{-
+  * The first line of every layout in the left argument of @Union@ is
+    longer than the first line of any layout in the right argument.
+    (1) ensures that the left argument has a first line.  In view of
+    (3), this invariant means that the right argument must have at
+    least two lines.
+-}
+counterexample_inv7 = cat [ text " ", nest 2 ( text "a") ]
+
+prop_inv7 :: Doc -> Bool
+prop_inv7 = genericProp (&&) firstLonger where
+    firstLonger (Union d1 d2) = (firstLineLength d1 >= firstLineLength d2, True)
+    firstLonger _ = (True, True)
+
+{- 
+   * If we take as precondition: the arguments of cat,sep,fill do not start with Nest, invariant 7 holds
+-}
+prop_inv7_pre :: CDoc -> Bool
+prop_inv7_pre cdoc = nestStart True cdoc where
+  nestStart nestOk doc = 
+    case doc of
+        CList sep ds     -> all (nestStart False) ds
+        CBeside _ d1 d2  -> nestStart nestOk d1 && nestStart (not . isEmpty $ buildDoc d1) d2
+        CAbove _ d1 d2   -> nestStart nestOk d1 && nestStart (not . isEmpty $ buildDoc d1) d2
+        CNest _ d  | not nestOk -> False
+                   | otherwise  -> nestStart True d
+        _empty_or_text   -> True
+
+{-
+   inv7_pre ==> inv7
+-}
+prop_inv7_a :: CDoc -> Property
+prop_inv7_a cdoc = prop_inv7_pre cdoc ==> prop_inv7 (buildDoc cdoc)
+    
+check_invariants :: IO ()
+check_invariants = do
+    myTest "Invariant 1" (prop_inv1 . buildDoc)
+    myTest "Invariant 2" (prop_inv2 . buildDoc)
+    myTest "Invariant 3" (prop_inv3 . buildDoc)
+    myTest "Invariant 4" (prop_inv4 . buildDoc)
+    myTest "Invariant 5+" (prop_inv5 . buildDoc)
+    myTest "Invariant 6" (prop_inv6 . buildDoc)
+    mapM_ (\sp -> myTest "Invariant 6a" (prop_inv6a sp . buildDocList)) [ cat, sep, fcat, fsep, vcat, hcat, hsep ]
+    myTest "Invariant 7 (fails in HughesPJ:20080621)" (prop_inv7 . buildDoc)
+
+-- `negative indent' 
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 
+
+{-  
+   In the documentation we have:
+   
+   (spaces n) generates a list of n spaces
+   It should never be called with 'n' < 0, but that can happen for reasons I don't understand
+
+   This is easy to explain:
+   Suppose we have layout1 <> layout2
+                   length of last line layout1 is k1
+                   indentation of first line  of layout2 is k2
+                   indentation of some other line of layout2 is k2'
+   Now   layout1 <> nest k2 (line1 $$ nest k2' lineK)
+    ==>  layout1 <> (line1 $$ nest k2' lineK)
+   When k1 - k2' < 0, we need to layout lineK with negative indentation
+
+   Here is a quick check property to ducment this.
+-}
+prop_negative_indent :: CDoc -> Property
+prop_negative_indent cdoc = noNegNest cdoc ==> noNegSpaces (buildDoc cdoc)
+noNegNest = genericCProp (&&) notIsNegNest where
+    notIsNegNest (CNest k _) | k < 0 = stop False
+    notIsNegNest  _                  = recurse True
+noNegSpaces = go 0 . reduceDoc where 
+    go k Empty = True
+    go k (NilAbove d) = go k d
+    go k (TextBeside _ s d) | k < 0 = False
+    go k (TextBeside _ s d) = go (k+s) d
+    go k (Nest k' d) = go (k+k') d
+    go k (Union d1 d2) = (if nonEmptySet d1 then (&&) (go k d1) else id) (go k d2)
+    go k NoDoc = True
+
+counterexample_fail9 :: Doc
+counterexample_fail9 =  text "a" <> ( nest 2 ( text "b") $$  text "c")
+-- reduces to           textb "a" ; textb "b" ; nilabove ; nest -3 ; textb "c" ; empty
+
+{-
+This cannot be fixed with violating the "intuitive property of layouts", described by John Hughes:
+"Composing layouts should preserve the layouts themselves (i.e. translation)"
+
+Consider the following example:
+It is the user's fault to use <+> in t2.
+-}
+
+tstmt =  (nest 6 $ text "/* double indented comment */") $+$
+         (nest 3 $ text "/* indented comment */") $+$
+         text "skip;"
+
+t1 = text "while(true)" $+$ (nest 2) tstmt
+{-
+while(true)
+        /* double indented comment */
+     /* indented comment */
+  skip;
+-}
+t2 = text "while(true)" $+$ (nest 2 $ text "//" <+> tstmt)
+{-
+while(true)
+  // /* double indented comment */
+  /* indented comment */
+skip;
+-}
+                        
+-- (3) Touching non-prims
+-- ~~~~~~~~~~~~~~~~~~~~~~
+
+check_non_prims :: IO ()
+check_non_prims = do
+    myTest "Non primitive: show = renderStyle style" $ \cd -> let d = buildDoc cd in 
+        show ((zeroWidthText "a") <> d) /= renderStyle style d
+    myAssert "symbols" $
+        (semi <> comma <> colon <> equals <> lparen <> rparen <> lbrack <> rbrack <> lbrace <> rbrace)
+            `deq` 
+        (text ";,:=()[]{}")
+    myAssert "quoting" $
+        (quotes . doubleQuotes . parens . brackets .braces $ (text "a" $$ text "b"))
+            `deq`
+        (text "'\"([{" <> (text "a" $$ text "b") <> text "}])\"'")
+    myAssert "numbers" $
+        fsep [int 42, integer 42, float 42, double 42, rational 42]
+        `rdeq`
+        (fsep . map text) 
+            [show (42 :: Int), show (42 :: Integer), show (42 :: Float), show (42 :: Double), show (42 :: Rational)]
+    myTest "Definition of <+>" $ \cd1 cd2 -> 
+        let (d1,d2) = (buildDoc cd1, buildDoc cd2) in 
+        layoutsCountBounded maxLayouts [d1,d2] ==>
+        not (isEmpty d1) && not (isEmpty d2)   ==>
+        d1 <+> d2 `rdeq` d1 <> space <> d2 
+        
+    myTest "hang" $ liftDoc2 (\d1 d2 -> hang d1 2 d2 `deq` sep [d1, nest 2 d2])
+    
+    let pLift f cp cds = f (buildDoc cp) (buildDocList cds)
+    myTest "punctuate" $ pLift (\p ds -> (punctuate p ds) `deqs` (punctuateDef p ds))
+
+check_rendering = do
+    myTest' 20 10000 "one - line rendering" $ \cd -> 
+        let d = buildDoc cd in        
+        (renderStyle (Style OneLineMode undefined undefined) d) == oneLineRender d
+    myTest' 20 10000 "left-mode rendering" $ \cd ->
+        let d = buildDoc cd in
+        extractText (renderStyle (Style LeftMode undefined undefined) d) == extractText (oneLineRender d)
+    myTest' 20 10000 "page mode rendering" $ \cd ->
+        let d = buildDoc cd in
+        extractText (renderStyle (Style PageMode 6 1.7) d) == extractText (oneLineRender d)
+    myTest' 20 10000 "zigzag mode rendering" $ \cd ->
+        let d = buildDoc cd in
+        extractTextZZ (renderStyle (Style ZigZagMode 6 1.7) d) == extractText (oneLineRender d)
+        
+extractText :: String -> String
+extractText = filter (not . isSpace)
+extractTextZZ :: String -> String
+extractTextZZ = filter (\c -> not (isSpace c) && c /= '/' && c /= '\\')
+
+punctuateDef :: Doc -> [Doc] -> [Doc]
+punctuateDef p [] = []
+punctuateDef p ps = 
+    let (dsInit,dLast) = (init ps, last ps) in
+    map (\d -> d <> p) dsInit ++ [dLast]
+       
+-- (4) QuickChecking improvments and bug fixes
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+{-
+putStrLn $ render' $ fill True [ text "c", text "c",empty, text "c", text "b"]
+c c c
+b
+putStrLn $ render' $ fillOld True [ text "c", text "c",empty, text "c", text "b"]
+c c c
+    b
+-}
+prop_fill_empty_reduce :: [Doc] -> Bool
+prop_fill_empty_reduce ds = fill True ds `deq` fillOld True (filter (not.isEmpty.reduceDoc) ds)
+
+check_improvements :: IO ()
+check_improvements = do
+    myTest "fill = fillOld . filter (not.isEmpty) [if no argument starts with nest]" 
+           (prop_fill_empty_reduce . filter (not .isNest) . buildDocList)
+
+-- old implementation of fill
+fillOld :: Bool -> [Doc] -> RDoc
+fillOld _ []     = empty
+fillOld g (p:ps) = fill1 g (reduceDoc p) 0 ps where
+    fill1 :: Bool -> RDoc -> Int -> [Doc] -> Doc
+    fill1 _ _                   k _  | k `seq` False = undefined
+    fill1 _ NoDoc               _ _  = NoDoc
+    fill1 g (p `Union` q)       k ys = fill1 g p k ys
+                                       `union_`
+                                       (aboveNest q False k (fillOld g ys))
+
+    fill1 g Empty               k ys = mkNest k (fillOld g ys)
+    fill1 g (Nest n p)          k ys = nest_ n (fill1 g p (k - n) ys)
+
+    fill1 g (NilAbove p)        k ys = nilAbove_ (aboveNest p False k (fillOld g ys))
+    fill1 g (TextBeside s sl p) k ys = textBeside_ s sl (fillNB g p (k - sl) ys)
+    fill1 _ (Above {})          _ _  = error "fill1 Above"
+    fill1 _ (Beside {})         _ _  = error "fill1 Beside"
+        -- fillNB gap textBesideArgument space_left docs
+    fillNB :: Bool -> Doc -> Int -> [Doc] -> Doc
+    fillNB _ _           k _  | k `seq` False = undefined
+    fillNB g (Nest _ p)  k ys  = fillNB g p k ys
+    fillNB _ Empty _ []        = Empty
+    fillNB g Empty k (y:ys)    = nilBeside g (fill1 g (oneLiner (reduceDoc y)) k1 ys)
+                                 `mkUnion` 
+                                 nilAboveNest False k (fillOld g (y:ys))
+                               where
+                                 k1 | g         = k - 1
+                                    | otherwise = k
+    fillNB g p k ys            = fill1 g p k ys
+
+
+-- Specification: 
+--   fill []  = empty
+--   fill [p] = p
+--   fill (p1:p2:ps) = oneLiner p1 <#> nest (length p1) 
+--                                          (fill (oneLiner p2 : ps))
+--                     `union`
+--                      p1 $$ fill ps
+fillOld2 :: Bool -> [Doc] -> RDoc
+fillOld2 _ []     = empty
+fillOld2 g (p:ps) = fill1 g (reduceDoc p) 0 ps where
+    fill1 :: Bool -> RDoc -> Int -> [Doc] -> Doc
+    fill1 _ _                   k _  | k `seq` False = undefined
+    fill1 _ NoDoc               _ _  = NoDoc
+    fill1 g (p `Union` q)       k ys = fill1 g p k ys
+                                       `union_`
+                                       (aboveNest q False k (fill g ys))
+
+    fill1 g Empty               k ys = mkNest k (fill g ys)
+    fill1 g (Nest n p)          k ys = nest_ n (fill1 g p (k - n) ys)
+
+    fill1 g (NilAbove p)        k ys = nilAbove_ (aboveNest p False k (fill g ys))
+    fill1 g (TextBeside s sl p) k ys = textBeside_ s sl (fillNB g p (k - sl) ys)
+    fill1 _ (Above {})          _ _  = error "fill1 Above"
+    fill1 _ (Beside {})         _ _  = error "fill1 Beside"
+
+    fillNB :: Bool -> Doc -> Int -> [Doc] -> Doc
+    fillNB _ _           k _  | k `seq` False = undefined
+    fillNB g (Nest _ p)  k ys  = fillNB g p k ys
+    fillNB _ Empty _ []        = Empty
+    fillNB g Empty k (Empty:ys)  = fillNB g Empty k ys
+    fillNB g Empty k (y:ys)    = fillNBE g k y ys
+    fillNB g p k ys            = fill1 g p k ys
+
+    fillNBE g k y ys           = nilBeside g (fill1 g (oneLiner (reduceDoc y)) k1 ys)
+                                 `mkUnion` 
+                                 nilAboveNest True k (fill g (y:ys))
+                               where
+                                 k1 | g         = k - 1
+                                    | otherwise = k
+
+-- (5) Pretty printing RDocs and RDOC properties
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+prettyDoc :: Doc -> Doc
+prettyDoc d = 
+    case reduceDoc d of 
+        Empty            -> text "empty"
+        NilAbove d       -> (text "nilabove") <> semi <+> (prettyDoc d)
+        TextBeside s sl d  -> (text ("text \""++tdToStr s ++ "\"" ++ show sl)) <> semi <+> (prettyDoc d)
+        Nest k d           -> text "nest" <+> integer (fromIntegral k) <> semi <+> prettyDoc d
+        Union d1 d2        -> sep [text "union", parens (prettyDoc d1), parens (prettyDoc d2)]
+        NoDoc              -> text "nodoc"
+
+-- TODO: map strategy for Docs to avoid code duplication
+-- Debug: Doc -> [Layout]
+flattenDoc :: Doc -> [RDoc]
+flattenDoc d = flatten (reduceDoc d) where
+    flatten NoDoc = []
+    flatten Empty = return Empty
+    flatten (NilAbove d) = map NilAbove (flatten d)
+    flatten (TextBeside s sl d) = map (TextBeside s sl) (flatten d)
+    flatten (Nest k d) = map (Nest k) (flatten d)
+    flatten (Union d1 d2) = flattenDoc d1 ++ flattenDoc d2
+    flatten (Beside d1 b d2) = error $ "flattenDoc Beside"
+    flatten (Above d1 b d2) = error $ "flattenDoc Above"
+  
+normalize :: Doc -> RDoc
+normalize d = norm d where
+    norm NoDoc = NoDoc
+    norm Empty = Empty
+    norm (NilAbove d) = NilAbove (norm d)
+    norm (TextBeside s sl (Nest k d)) = norm (TextBeside s sl d)
+    norm (TextBeside s sl d) = (TextBeside s sl) (norm d)
+    norm (Nest k (Nest k' d)) = norm $ Nest (k+k') d
+    norm (Nest 0 d) = norm d
+    norm (Nest k d) = (Nest k) (norm d)  
+    --   * The arguments of @Union@ are either @TextBeside@, or @NilAbove@.
+    norm (Union d1 d2) = normUnion (norm d1) (norm d2)
+    norm d@(Beside d1 b d2) = norm (reduceDoc d)
+    norm d@(Above d1 b d2) = norm (reduceDoc d)
+    normUnion d0@(Nest k d) (Union d1 d2) = norm (Union d0 (normUnion d1 d2))
+    normUnion (Union d1 d2) d3@(Nest k d) = norm (Union (normUnion d1 d2) d3)
+    normUnion (Nest k d1) (Nest k' d2) | k == k' = Nest k $ Union (norm d1) (norm d2)
+                                       | otherwise = error "normalize: Union Nest length mismatch ?"
+    normUnion (Nest _ _) d2 = error$ "normUnion Nest "++topLevelCTor d2
+    normUnion d1 (Nest _ _) = error$ "normUnion Nset "++topLevelCTor d1
+    normUnion p1 p2  = Union p1 p2
+topLevelCTor :: Doc -> String
+topLevelCTor d = tlc d where
+    tlc NoDoc = "NoDoc"
+    tlc Empty = "Empty"
+    tlc (NilAbove d) = "NilAbove"
+    tlc (TextBeside s sl d) = "TextBeside"
+    tlc (Nest k d) = "Nest"
+    tlc (Union d1 d2) = "Union"
+    tlc (Above _ _ _) = "Above"
+    tlc (Beside _ _ _) = "Beside"
+    
+-- normalize TextBeside (and consequently apply some laws for simplification)
+mergeTexts :: RDoc -> RDoc
+mergeTexts = merge where
+    merge NoDoc = NoDoc
+    merge Empty = Empty
+    merge (NilAbove d) = NilAbove (merge d)
+    merge (TextBeside t1 l1 (TextBeside t2 l2 doc)) = (merge.normalize) (TextBeside (mergeText t1 t2) (l1 +l2) doc)
+    merge (TextBeside s sl d) = TextBeside s sl (merge d)
+    merge (Nest k d) = Nest k (merge d)
+    merge (Union d1 d2) = Union (merge d1) (merge d2)
+    mergeText t1 t2 = Str $ tdToStr t1 ++ tdToStr t2
+    
+isOneLiner :: RDoc -> Bool
+isOneLiner = genericProp (&&) iol where
+    iol (NilAbove _) = stop False
+    iol (Union _ _)  = stop False
+    iol  NoDoc = stop False
+    iol _ = recurse True
+hasOneLiner :: RDoc -> Bool
+hasOneLiner = genericProp (&&) iol where
+    iol (NilAbove _) = stop False
+    iol (Union d1 _) = stop $ hasOneLiner d1
+    iol  NoDoc = stop False
+    iol _ = recurse True
+
+-- use elementwise concatenation as generic combinator
+extractTexts :: Doc -> [String]
+extractTexts = map normWS . genericProp combine go where
+    combine xs ys = [ a ++ b | a <- xs, b <- ys ]
+    go (TextBeside s _ _ ) = recurse [tdToStr s]
+    go (Union d1 d2)       = stop $ extractTexts d1 ++ extractTexts d2
+    go NoDoc               = stop []
+    go _ = recurse [""]
+    -- modulo whitespace
+    normWS txt = filter (not . isWS) txt where
+        isWS ws | ws == ' ' || ws == '\n' || ws == '\t'  = True
+                | otherwise = False 
+                
+emptyReduction :: Doc -> Doc
+emptyReduction doc = 
+    case doc of
+            Empty             -> Empty
+            NilAbove d        -> case emptyReduction d of Empty -> Empty ; d' -> NilAbove d'
+            TextBeside s sl d -> TextBeside s sl (emptyReduction d)
+            Nest k d          -> case emptyReduction d of Empty -> Empty; d -> Nest k d
+            Union d1 d2       -> case emptyReduction d2 of Empty -> Empty; _ -> Union d1 d2 -- if d2 is empty, both have to be
+            NoDoc             -> NoDoc
+            Beside d1 _ d2    -> emptyReduction (reduceDoc doc)
+            Above d1 _ d2     -> emptyReduction (reduceDoc doc)
+
+firstLineLength :: Doc -> Int
+firstLineLength = genericProp (+) fll . reduceDoc where
+    fll (NilAbove d) = stop 0
+    fll (TextBeside _ l d) = recurse l
+    fll (Nest k d) = recurse k
+    fll (Union d1 d2) = stop (firstLineLength d1) -- inductively assuming inv7
+    fll (Above _ _ _) = error "Above"
+    fll (Beside _ _ _) = error "Beside"
+    fll _ = (0,True)
+
+abstractLayout :: Doc -> [(Int,String)]
+abstractLayout d = cal 0 Nothing (reduceDoc d) where
+    --   current column -> this line -> doc -> [(indent,line)]
+    cal :: Int -> (Maybe (Int,String)) -> Doc -> [(Int,String)]
+    cal k cur Empty = [ addTextEOL k (Str "") cur ]    
+    cal k cur (NilAbove d) = (addTextEOL k (Str "") cur) : cal k Nothing d
+    cal k cur (TextBeside s sl d) = cal (k+sl) (addText k s cur) d
+    cal k cur (Nest n d) = cal (k+n) cur d
+    cal _ _ (Union d1 d2) = error "abstractLayout: Union"
+    cal _ _ NoDoc = error "NoDoc"
+    cal _ _ (Above _ _ _) = error "Above"
+    cal _ _ (Beside _ _ _) = error "Beside"
+    addTextEOL k str Nothing = (k,tdToStr str)
+    addTextEOL _ str (Just (k,pre)) = (k,pre++ tdToStr str)
+    addText k str = Just . addTextEOL k str
+docifyLayout :: [(Int,String)] -> Doc
+docifyLayout = vcat . map (\(k,t) -> nest k (text t))
+    
+oneLineRender :: Doc -> String
+oneLineRender = olr . abstractLayout . last . flattenDoc where
+    olr = concat . intersperse " " . map snd
+
+-- because of invariant 4, we do not have to expand to layouts here
+-- but it is easier, so for now we use abstractLayout
+firstLineIsLeftMost :: Doc -> Bool
+firstLineIsLeftMost = all (firstIsLeftMost . abstractLayout) . flattenDoc where
+    firstIsLeftMost ((k,_):xs@(_:_)) = all ( (>= k) . fst) xs
+    firstIsLeftMost _ = True
+noNegativeIndent :: Doc -> Bool
+noNegativeIndent = all (noNegIndent . abstractLayout) . flattenDoc where
+    noNegIndent = all ( (>= 0) . fst)
+    
+-- (6) Datatypes for law QuickChecks
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+-- User visible combinators
+-- The tests are performed on pretty printing terms which are constructable using the public combinators.
+-- We need to have a datatype for those combinators, otherwise it becomes almost impossible to reconstruct failing tests.
+
+data CDoc = CEmpty           -- empty
+          | CText String     -- text s
+          | CList CList [CDoc] -- cat,sep,fcat,fsep ds
+          | CBeside Bool CDoc CDoc -- a <> b and a <+> b
+          | CAbove Bool CDoc CDoc  -- a $$ b and a $+$ b
+          | CNest Int CDoc   -- nest k d
+--          | ZText String     -- zeroWidthText s
+            deriving (Eq,Ord)
+
+data CList = CCat | CSep | CFCat | CFSep deriving (Eq,Ord)
+listComb :: CList -> ([Doc] -> Doc)
+listComb cs = case cs of CCat -> cat ;  CSep -> sep ; CFCat -> fcat  ; CFSep -> fsep
+instance Show CList where 
+    show cs = case cs of CCat -> "cat" ;  CSep -> "sep" ; CFCat -> "fcat"  ; CFSep -> "fsep" 
+
+buildDoc :: CDoc -> Doc
+buildDoc CEmpty = empty
+buildDoc (CText s) = text s
+--buildDoc (ZText s) = zeroWidthText s
+buildDoc (CList sp ds) = (listComb sp) $ map buildDoc ds
+buildDoc (CBeside sep d1 d2) = (if sep then (<+>) else (<>)) (buildDoc d1) (buildDoc d2) 
+buildDoc (CAbove noOvlap d1 d2) = (if noOvlap then ($+$) else ($$)) (buildDoc d1) (buildDoc d2) 
+buildDoc (CNest k d) = nest k $ buildDoc d
+
+liftDoc2 :: (Doc -> Doc -> a) -> (CDoc -> CDoc -> a)
+liftDoc2 f cd1 cd2 = f (buildDoc cd1) (buildDoc cd2)
+liftDoc3 :: (Doc -> Doc -> Doc -> a) -> (CDoc -> CDoc -> CDoc -> a)
+liftDoc3 f cd1 cd2 cd3 = f (buildDoc cd1) (buildDoc cd2) (buildDoc cd3)
+instance Show CDoc where
+    showsPrec k CEmpty = showString "empty"
+    showsPrec k (CText s) = showParen (k >= 10) (showString " text " . shows s)
+--    showsPrec k (ZText s) = showParen (k >= 10) (showString " zeroWidthText " . shows s)
+    showsPrec k (CList sp ds) = showParen (k >= 10) $ (shows sp . showList ds)
+    showsPrec k (CBeside sep d1 d2) = showParen (k >= 6) $ 
+        (showsPrec 6 d1) . showString (if sep then " <+> " else " <> ") . (showsPrec 6 d2) 
+    showsPrec k (CAbove noOvlap d1 d2) = showParen (k >= 5) $ 
+        (showsPrec 5 d1) . showString (if noOvlap then " $+$ " else " $$ ") . (showsPrec 5 d2) 
+    showsPrec k (CNest n d) = showParen (k >= 10) $ showString " nest " . showsPrec 10 n . showString " ". showsPrec 10 d
+
+instance Arbitrary CDoc where
+   arbitrary = sized arbDoc
+    where
+      -- TODO: finetune frequencies
+      arbDoc k | k <= 1 = frequency [
+               (1,return CEmpty)
+             , (2,return (CText . unText) `ap` arbitrary)
+--             , (1,return (ZText "&"))
+             ]
+      arbDoc n = frequency [
+             (1, return CList `ap` arbitrary `ap`  (liftM unDocList $ resize (pred n) arbitrary))
+            ,(1, binaryComb n CBeside)
+            ,(1, binaryComb n CAbove)
+            ,(1, choose (0,10) >>= \k -> return (CNest k) `ap` (resize (pred n) arbitrary)) 
+            ]
+      binaryComb n f = 
+        split2 (n-1) >>= \(n1,n2) ->
+        return f `ap` arbitrary `ap` (resize n1 arbitrary) `ap` (resize n2 arbitrary)
+      split2 n = flip liftM ( choose (0,n) ) $ \sz -> (sz, n - sz)
+   coarbitrary CEmpty = variant 0
+   coarbitrary (CText t) = variant 1 . coarbitrary (length t)
+   coarbitrary (CList f list) = variant 2 . coarbitrary f . coarbitrary list
+   coarbitrary (CBeside b d1 d2) = variant 3 . coarbitrary b . coarbitrary d1 . coarbitrary d2
+   coarbitrary (CAbove b d1 d2) = variant 4 . coarbitrary b . coarbitrary d1 . coarbitrary d2
+   coarbitrary (CNest k d) = variant 5 . coarbitrary k . coarbitrary d
+   
+instance Arbitrary CList where
+    arbitrary = oneof $ map return [ CCat, CSep, CFCat, CFSep ]
+    coarbitrary cl = variant (case cl of CCat -> 0; CSep -> 1; CFCat -> 2; CFSep -> 3)
+
+newtype CDocList = CDocList { unDocList :: [CDoc] } 
+instance Show CDocList where show = show . unDocList
+
+-- we assume that the list itself has no size, so that 
+-- sizeof (a $$ b) = sizeof (sep [a,b]) = sizeof(a)+sizeof(b)+1
+instance Arbitrary CDocList where
+    arbitrary = liftM CDocList $ sized $ \n -> arbDocList n where
+        arbDocList 0 = return []
+        arbDocList n = do
+          listSz <- choose (1,n)
+          let elems = take listSz $ repeat (n `div` listSz) -- approximative
+          mapM (\sz -> resize sz arbitrary) elems
+    coarbitrary (CDocList ds) = coarbitrary ds
+    
+buildDocList :: CDocList -> [Doc]
+buildDocList = map buildDoc . unDocList
+
+-- wrapper for String argument of `text'
+newtype Text = Text { unText :: String } deriving (Eq,Ord,Show)
+instance Arbitrary Text where
+    arbitrary = liftM Text $ sized $ \n -> mapM (const arbChar) [1..n]
+        where arbChar = oneof (map return ['a'..'c'])
+    coarbitrary (Text str) = coarbitrary (length str)
+
+text' :: Text -> Doc
+text' (Text str) = text str
+-- convert text details to string
+tdToStr :: TextDetails -> String
+tdToStr (Chr c) = [c]
+tdToStr (Str s) = s
+tdToStr (PStr s) = s
+
+-- synthesize with stop for cdoc
+-- constructor order
+genericCProp :: (a -> a -> a) -> (CDoc -> (a, Bool)) -> CDoc -> a
+genericCProp c q cdoc = 
+    case q cdoc of
+        (v,False) -> v
+        (v,True)  -> foldl c v subs
+    where
+        rec = genericCProp c q
+        subs = case cdoc of
+            CEmpty  -> []
+            CText _ -> []
+--            ZText _ -> []
+            CList _ ds -> map rec ds
+            CBeside _ d1 d2 -> [rec d1, rec d2]
+            CAbove b d1 d2 -> [rec d1, rec d2]
+            CNest k d -> [rec d]
+