pretty 1.1.1.0 → 1.1.1.1
raw patch · 11 files changed
+2387/−993 lines, 11 filesdep +QuickChecksetup-changed
Dependencies added: QuickCheck
Files
- CHANGELOG.md +167/−0
- README.md +54/−0
- Setup.hs +1/−0
- Text/PrettyPrint.hs +0/−70
- Text/PrettyPrint/HughesPJ.hs +0/−915
- pretty.cabal +34/−8
- src/Text/PrettyPrint.hs +70/−0
- src/Text/PrettyPrint/HughesPJ.hs +904/−0
- tests/Test.hs +990/−0
- tests/TestGenerators.hs +75/−0
- tests/TestStructures.hs +92/−0
+ CHANGELOG.md view
@@ -0,0 +1,167 @@+# Pretty library change log++## 1.1.1.1++* Update pretty cabal file and readme.+* Fix tests to work with latest quickcheck.++## 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+
+ README.md view
@@ -0,0 +1,54 @@+# Pretty : A Haskell Pretty-printer library++Pretty is a pretty-printing library, a set of API's that provides a+way to easily print out text in a consistent format of your choosing.+This is useful for compilers and related tools.++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>++## Licensing++This library is BSD-licensed.++## Building++The library uses the Cabal build system, so building is simply a+matter of running++```+cabal configure --enable-tests+cabal build+```++## Branches++Usually two branches are maintained for Pretty development:++ * master: This branch is generally kept in a stable state and is+ where release are pulled and made from. The reason for this is GHC+ includes the pretty library and tracks the master branch by default+ so we don't want experimental code being pulled into GHC at times.++ * next: This branch is the general development branch.++## Get involved!++We are happy to receive bug reports, fixes, documentation enhancements,+and other improvements.++Please report bugs via the+[github issue tracker](http://github.com/haskell/pretty/issues).++Master [git repository](http://github.com/haskell/pretty):++* `git clone git://github.com/haskell/pretty.git`++## Authors++This library is maintained by David Terei, <code@davidterei.com>. It+was originally designed by John Hughes's and since heavily modified by+Simon Peyton Jones.+
Setup.hs view
@@ -4,3 +4,4 @@ main :: IO () main = defaultMain+
− Text/PrettyPrint.hs
@@ -1,70 +0,0 @@-#if __GLASGOW_HASKELL__ >= 701-{-# LANGUAGE Safe #-}-#endif--------------------------------------------------------------------------------- |--- Module : Text.PrettyPrint--- Copyright : (c) The University of Glasgow 2001--- License : BSD-style (see the file LICENSE)--- --- Maintainer : David Terei <dave.terei@gmail.com>--- Stability : stable--- Portability : portable------ The default interface to the pretty-printing library. Provides a collection--- of pretty printer combinators.------ This module should be used as opposed to the "Text.PrettyPrint.HughesPJ"--- module. Both are equivalent though as this module simply re-exports the--- other.-----------------------------------------------------------------------------------module Text.PrettyPrint ( -- -- * The document type- Doc,-- -- * Constructing documents-- -- ** Converting values into documents- char, text, ptext, sizedText, zeroWidthText,- int, integer, float, double, rational,-- -- ** Simple derived documents- semi, comma, colon, space, equals,- lparen, rparen, lbrack, rbrack, lbrace, rbrace,-- -- ** Wrapping documents in delimiters- parens, brackets, braces, quotes, doubleQuotes,-- -- ** Combining documents- empty,- (<>), (<+>), hcat, hsep,- ($$), ($+$), vcat,- sep, cat,- fsep, fcat,- nest,- hang, punctuate,-- -- * Predicates on documents- isEmpty,-- -- * Rendering documents-- -- ** Default rendering- render,-- -- ** Rendering with a particular style- Style(..),- style,- renderStyle,-- -- ** General rendering- fullRender,- Mode(..), TextDetails(..)-- ) where--import Text.PrettyPrint.HughesPJ-
− Text/PrettyPrint/HughesPJ.hs
@@ -1,915 +0,0 @@-{-# OPTIONS_HADDOCK not-home #-}-{-# LANGUAGE BangPatterns #-}-#if __GLASGOW_HASKELL__ >= 701-{-# LANGUAGE Safe #-}-#endif---------------------------------------------------------------------------------- |--- Module : Text.PrettyPrint.HughesPJ--- Copyright : (c) The University of Glasgow 2001--- License : BSD-style (see the file LICENSE)------ Maintainer : David Terei <dave.terei@gmail.com>--- Stability : stable--- Portability : portable------ John Hughes's and Simon Peyton Jones's Pretty Printer Combinators------ Based on /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>------ Heavily modified by Simon Peyton Jones (December 1996).----------------------------------------------------------------------------------module Text.PrettyPrint.HughesPJ (-- -- * The document type- Doc, TextDetails(..),-- -- * Constructing documents-- -- ** Converting values into documents- char, text, ptext, sizedText, zeroWidthText,- int, integer, float, double, rational,-- -- ** Simple derived documents- semi, comma, colon, space, equals,- lparen, rparen, lbrack, rbrack, lbrace, rbrace,-- -- ** Wrapping documents in delimiters- parens, brackets, braces, quotes, doubleQuotes,-- -- ** Combining documents- empty,- (<>), (<+>), hcat, hsep,- ($$), ($+$), vcat,- sep, cat,- fsep, fcat,- nest,- hang, punctuate,-- -- * Predicates on documents- isEmpty,-- -- * Utility functions for documents- first, reduceDoc,-- -- * Rendering documents-- -- ** Default rendering- render,-- -- ** Rendering with a particular style- Style(..),- style,- renderStyle,- Mode(..),-- -- ** General rendering- fullRender-- ) where--import Data.Monoid ( Monoid(mempty, mappend) )-import Data.String ( IsString(fromString) )---- ------------------------------------------------------------------------------ The Doc calculus---- The Doc combinators satisfy the following laws:--{--Laws for $$-~~~~~~~~~~~-<a1> (x $$ y) $$ z = x $$ (y $$ z)-<a2> empty $$ x = x-<a3> x $$ empty = x-- ...ditto $+$...--Laws for <>-~~~~~~~~~~~-<b1> (x <> y) <> z = x <> (y <> z)-<b2> empty <> x = empty-<b3> x <> empty = x-- ...ditto <+>...--Laws for text-~~~~~~~~~~~~~-<t1> text s <> text t = text (s++t)-<t2> text "" <> x = x, if x non-empty--** because of law n6, t2 only holds if x doesn't-** start with `nest'.---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 x <> 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--** Note the side condition on <n6>! It is this that-** makes it OK for empty to be a left unit for <>.--Miscellaneous-~~~~~~~~~~~~~-<m1> (text s <> x) $$ y = text s <> ((text "" <> x) $$- nest (-length s) y)--<m2> (x $$ y) <> z = x $$ (y <> z)- if y non-empty---Laws for list versions-~~~~~~~~~~~~~~~~~~~~~~-<l1> sep (ps++[empty]++qs) = sep (ps ++ qs)- ...ditto hsep, hcat, vcat, fill...--<l2> nest k (sep ps) = sep (map (nest k) ps)- ...ditto hsep, hcat, vcat, fill...--Laws for oneLiner-~~~~~~~~~~~~~~~~~-<o1> oneLiner (nest k p) = nest k (oneLiner p)-<o2> oneLiner (x <> y) = oneLiner x <> oneLiner y--You might think that the following verion of <m1> would-be neater:--<3 NO> (text s <> x) $$ y = text s <> ((empty <> x)) $$- nest (-length s) y)--But it doesn't work, for if x=empty, we would have-- text s $$ y = text s <> (empty $$ nest (-length s) y)- = text s <> nest (-length s) y--}---- ------------------------------------------------------------------------------ Operator fixity--infixl 6 <>-infixl 6 <+>-infixl 5 $$, $+$---- ------------------------------------------------------------------------------ The Doc data type---- | The abstract type of documents.--- A Doc represents a *set* of layouts. A Doc with--- no occurrences of Union or NoDoc represents just one layout.-data Doc- = Empty -- empty- | NilAbove Doc -- text "" $$ x- | TextBeside !TextDetails {-# UNPACK #-} !Int Doc -- text s <> x- | Nest {-# UNPACK #-} !Int Doc -- nest k x- | Union Doc Doc -- ul `union` ur- | NoDoc -- The empty set of documents- | Beside Doc Bool Doc -- True <=> space between- | Above Doc Bool Doc -- True <=> never overlap--{-- Here are the invariants:-- 1) The argument of NilAbove is never Empty. Therefore- a NilAbove occupies at least two lines.-- 2) The argument of @TextBeside@ is never @Nest@.-- 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@.-- 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.-- 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)--}----- | RDoc is a "reduced GDoc", guaranteed not to have a top-level Above or Beside.-type RDoc a = Doc---- | The TextDetails data type------ A TextDetails represents a fragment of text that will be--- output at some point.-data TextDetails = Chr {-# UNPACK #-} !Char -- ^ A single Char fragment- | Str String -- ^ A whole String fragment- | PStr String -- ^ Used to represent a Fast String fragment- -- but now deprecated and identical to the- -- Str constructor.---- Combining @Doc@ values-instance Monoid Doc where- mempty = empty- mappend = (<>)--instance IsString Doc where- fromString = text--instance Show Doc where- showsPrec _ doc cont = fullRender (mode style) (lineLength style)- (ribbonsPerLine style)- txtPrinter cont doc---- ------------------------------------------------------------------------------ Values and Predicates on GDocs and TextDetails---- | A document of height and width 1, containing a literal character.-char :: Char -> Doc-char c = textBeside_ (Chr c) 1 Empty---- | A document of height 1 containing a literal string.--- 'text' satisfies the following laws:------ * @'text' s '<>' 'text' t = 'text' (s'++'t)@------ * @'text' \"\" '<>' x = x@, if @x@ non-empty------ The side condition on the last law is necessary because @'text' \"\"@--- has height 1, while 'empty' has no height.-text :: String -> Doc-text s = case length s of {sl -> textBeside_ (Str s) sl Empty}---- | Same as @text@. Used to be used for Bytestrings.-ptext :: String -> Doc-ptext s = case length s of {sl -> textBeside_ (PStr s) sl Empty}---- | Some text with any width. (@text s = sizedText (length s) s@)-sizedText :: Int -> String -> Doc-sizedText l s = textBeside_ (Str s) l Empty---- | Some text, but without any width. Use for non-printing text--- such as a HTML or Latex tags-zeroWidthText :: String -> Doc-zeroWidthText = sizedText 0---- | The empty document, with no height and no width.--- 'empty' is the identity for '<>', '<+>', '$$' and '$+$', and anywhere--- in the argument list for 'sep', 'hcat', 'hsep', 'vcat', 'fcat' etc.-empty :: Doc-empty = Empty---- | Returns 'True' if the document is empty-isEmpty :: Doc -> Bool-isEmpty Empty = True-isEmpty _ = False---- an old version inserted tabs being 8 columns apart in the output.-indent :: Int -> String-indent !n = replicate n ' '-{- TODO: GHC Optimised version--- optimise long indentations using LitString chunks of 8 spaces-indent n r | n >=# _ILIT(8) = LStr (sLit " ") (_ILIT(8)) `txt`- indent (n -# _ILIT(8)) r- | otherwise = Str (spaces n) `txt` r--}--{--Q: What is the reason for negative indentation (i.e. argument to indent- is < 0) ?--A:-This indicates an error in the library client's code.-If we compose a <> b, and the first line of b is more indented than some-other lines of b, the law <n6> (<> eats nests) may cause the pretty-printer to produce an invalid layout:--doc |0123345--------------------d1 |a...|-d2 |...b|- |c...|--d1<>d2 |ab..|- c|....|--Consider a <> b, let `s' be the length of the last line of `a', `k' the-indentation of the first line of b, and `k0' the indentation of the-left-most line b_i of b.--The produced layout will have negative indentation if `k - k0 > s', as-the first line of b will be put on the (s+1)th column, effectively-translating b horizontally by (k-s). Now if the i^th line of b has an-indentation k0 < (k-s), it is translated out-of-page, causing-`negative indentation'.--}---semi :: Doc -- ^ A ';' character-comma :: Doc -- ^ A ',' character-colon :: Doc -- ^ A ':' character-space :: Doc -- ^ A space character-equals :: Doc -- ^ A '=' character-lparen :: Doc -- ^ A '(' character-rparen :: Doc -- ^ A ')' character-lbrack :: Doc -- ^ A '[' character-rbrack :: Doc -- ^ A ']' character-lbrace :: Doc -- ^ A '{' character-rbrace :: Doc -- ^ A '}' character-semi = char ';'-comma = char ','-colon = char ':'-space = char ' '-equals = char '='-lparen = char '('-rparen = char ')'-lbrack = char '['-rbrack = char ']'-lbrace = char '{'-rbrace = char '}'--space_text, nl_text :: TextDetails-space_text = Chr ' '-nl_text = Chr '\n'--int :: Int -> Doc -- ^ @int n = text (show n)@-integer :: Integer -> Doc -- ^ @integer n = text (show n)@-float :: Float -> Doc -- ^ @float n = text (show n)@-double :: Double -> Doc -- ^ @double n = text (show n)@-rational :: Rational -> Doc -- ^ @rational n = text (show n)@-int n = text (show n)-integer n = text (show n)-float n = text (show n)-double n = text (show n)-rational n = text (show n)--parens :: Doc -> Doc -- ^ Wrap document in @(...)@-brackets :: Doc -> Doc -- ^ Wrap document in @[...]@-braces :: Doc -> Doc -- ^ Wrap document in @{...}@-quotes :: Doc -> Doc -- ^ Wrap document in @\'...\'@-doubleQuotes :: Doc -> Doc -- ^ Wrap document in @\"...\"@-quotes p = char '\'' <> p <> char '\''-doubleQuotes p = char '"' <> p <> char '"'-parens p = char '(' <> p <> char ')'-brackets p = char '[' <> p <> char ']'-braces p = char '{' <> p <> char '}'----- ------------------------------------------------------------------------------ Structural operations on GDocs---- | Perform some simplification of a built up @GDoc@.-reduceDoc :: Doc -> RDoc a-reduceDoc (Beside p g q) = beside p g (reduceDoc q)-reduceDoc (Above p g q) = above p g (reduceDoc q)-reduceDoc p = p---- | List version of '<>'.-hcat :: [Doc] -> Doc-hcat = reduceAB . foldr (beside_' False) empty---- | List version of '<+>'.-hsep :: [Doc] -> Doc-hsep = reduceAB . foldr (beside_' True) empty---- | List version of '$$'.-vcat :: [Doc] -> Doc-vcat = reduceAB . foldr (above_' False) empty---- | Nest (or indent) a document by a given number of positions--- (which may also be negative). 'nest' satisfies the laws:------ * @'nest' 0 x = x@------ * @'nest' k ('nest' k' x) = 'nest' (k+k') x@------ * @'nest' k (x '<>' y) = 'nest' k z '<>' 'nest' k y@------ * @'nest' k (x '$$' y) = 'nest' k x '$$' 'nest' k y@------ * @'nest' k 'empty' = 'empty'@------ * @x '<>' 'nest' k y = x '<>' y@, if @x@ non-empty------ The side condition on the last law is needed because--- 'empty' is a left identity for '<>'.-nest :: Int -> Doc -> Doc-nest k p = mkNest k (reduceDoc p)---- | @hang d1 n d2 = sep [d1, nest n d2]@-hang :: Doc -> Int -> Doc -> Doc-hang d1 n d2 = sep [d1, nest n d2]---- | @punctuate p [d1, ... dn] = [d1 \<> p, d2 \<> p, ... dn-1 \<> p, dn]@-punctuate :: Doc -> [Doc] -> [Doc]-punctuate _ [] = []-punctuate p (x:xs) = go x xs- where go y [] = [y]- go y (z:zs) = (y <> p) : go z zs---- mkNest checks for Nest's invariant that it doesn't have an Empty inside it-mkNest :: Int -> Doc -> Doc-mkNest k _ | k `seq` False = undefined-mkNest k (Nest k1 p) = mkNest (k + k1) p-mkNest _ NoDoc = NoDoc-mkNest _ Empty = Empty-mkNest 0 p = p-mkNest k p = nest_ k p---- mkUnion checks for an empty document-mkUnion :: Doc -> Doc -> Doc-mkUnion Empty _ = Empty-mkUnion p q = p `union_` q--beside_' :: Bool -> Doc -> Doc -> Doc-beside_' _ p Empty = p-beside_' g p q = Beside p g q--above_' :: Bool -> Doc -> Doc -> Doc-above_' _ p Empty = p-above_' g p q = Above p g q--reduceAB :: Doc -> Doc-reduceAB (Above Empty _ q) = q-reduceAB (Beside Empty _ q) = q-reduceAB doc = doc--nilAbove_ :: RDoc a -> RDoc a-nilAbove_ p = NilAbove p---- Arg of a TextBeside is always an RDoc-textBeside_ :: TextDetails -> Int -> RDoc a -> RDoc a-textBeside_ s sl p = TextBeside s sl p--nest_ :: Int -> RDoc a -> RDoc a-nest_ k p = Nest k p--union_ :: RDoc a -> RDoc a -> RDoc a-union_ p q = Union p q----- ------------------------------------------------------------------------------ Vertical composition @$$@---- | Above, except that if the last line of the first argument stops--- at least one position before the first line of the second begins,--- these two lines are overlapped. For example:------ > text "hi" $$ nest 5 (text "there")------ lays out as------ > hi there------ rather than------ > hi--- > there------ '$$' is associative, with identity 'empty', and also satisfies------ * @(x '$$' y) '<>' z = x '$$' (y '<>' z)@, if @y@ non-empty.----($$) :: Doc -> Doc -> Doc-p $$ q = above_ p False q---- | Above, with no overlapping.--- '$+$' is associative, with identity 'empty'.-($+$) :: Doc -> Doc -> Doc-p $+$ q = above_ p True q--above_ :: Doc -> Bool -> Doc -> Doc-above_ p _ Empty = p-above_ Empty _ q = q-above_ p g q = Above p g q--above :: Doc -> Bool -> RDoc a -> RDoc a-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)--aboveNest :: RDoc a -> Bool -> Int -> RDoc a -> RDoc a--- Specfication: aboveNest p g k q = p $g$ (nest k q)--aboveNest _ _ k _ | k `seq` False = undefined-aboveNest NoDoc _ _ _ = NoDoc-aboveNest (p1 `Union` p2) g k q = aboveNest p1 g k q `union_`- aboveNest p2 g k q--aboveNest Empty _ k q = mkNest k q-aboveNest (Nest k1 p) g k q = nest_ k1 (aboveNest p g (k - k1) q)- -- p can't be Empty, so no need for mkNest--aboveNest (NilAbove p) g k q = nilAbove_ (aboveNest p g k q)-aboveNest (TextBeside s sl p) g k q = textBeside_ s sl rest- where- !k1 = k - sl- rest = case p of- Empty -> nilAboveNest g k1 q- _ -> aboveNest p g k1 q-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)--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- = nilAbove_ (mkNest k q)----- ------------------------------------------------------------------------------ Horizontal composition @<>@---- We intentionally avoid Data.Monoid.(<>) here due to interactions of--- Data.Monoid.(<>) and (<+>). See--- http://www.haskell.org/pipermail/libraries/2011-November/017066.html---- | Beside.--- '<>' is associative, with identity 'empty'.-(<>) :: Doc -> Doc -> Doc-p <> q = beside_ p False q---- | Beside, separated by space, unless one of the arguments is 'empty'.--- '<+>' is associative, with identity 'empty'.-(<+>) :: Doc -> Doc -> Doc-p <+> q = beside_ p True q--beside_ :: Doc -> Bool -> Doc -> Doc-beside_ p _ Empty = p-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--beside NoDoc _ _ = NoDoc-beside (p1 `Union` p2) g q = beside p1 g q `union_` beside p2 g q-beside Empty _ q = q-beside (Nest k p) g q = nest_ k $! beside p g q-beside p@(Beside p1 g1 q1) g2 q2- | g1 == g2 = beside p1 g1 $! beside q1 g2 q2- | otherwise = beside (reduceDoc p) g2 q2-beside p@(Above _ _ _) g q = let !d = reduceDoc p in beside d g q-beside (NilAbove p) g q = nilAbove_ $! beside p g q-beside (TextBeside s sl p) g q = textBeside_ s sl $! rest- where- rest = case p of- Empty -> nilBeside g q- _ -> beside p g q--nilBeside :: Bool -> RDoc a -> RDoc a--- Specification: text "" <> nilBeside g p--- = text "" <g> 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- | otherwise = p----- ------------------------------------------------------------------------------ Separate, @sep@---- Specification: sep ps = oneLiner (hsep ps)--- `union`--- vcat ps---- | Either 'hsep' or 'vcat'.-sep :: [Doc] -> Doc-sep = sepX True -- Separate with spaces---- | Either 'hcat' or 'vcat'.-cat :: [Doc] -> Doc-cat = sepX False -- Don't--sepX :: Bool -> [Doc] -> Doc-sepX _ [] = empty-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)--sep1 :: Bool -> RDoc a -> Int -> [Doc] -> RDoc a-sep1 _ _ k _ | k `seq` False = undefined-sep1 _ NoDoc _ _ = NoDoc-sep1 g (p `Union` q) k ys = sep1 g p k ys `union_`- aboveNest q False k (reduceDoc (vcat ys))--sep1 g Empty k ys = mkNest k (sepX g ys)-sep1 g (Nest n p) k ys = nest_ n (sep1 g p (k - n) ys)--sep1 _ (NilAbove p) k ys = nilAbove_- (aboveNest p False k (reduceDoc (vcat ys)))-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"--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--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- nilAboveNest False k (reduceDoc (vcat ys))- where- rest | g = hsep ys- | otherwise = hcat ys-sepNB g p k ys- = sep1 g p k ys----- ------------------------------------------------------------------------------ @fill@---- | \"Paragraph fill\" version of 'cat'.-fcat :: [Doc] -> Doc-fcat = fill False---- | \"Paragraph fill\" version of 'sep'.-fsep :: [Doc] -> Doc-fsep = fill True---- 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 | hasMoreThanOneLine layout1 = layout1 $$ layout2--- | otherwise = layout1 $+$ layout2--fill :: Bool -> [Doc] -> RDoc a-fill _ [] = empty-fill g (p:ps) = fill1 g (reduceDoc p) 0 ps--fill1 :: Bool -> RDoc a -> 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- -- Never triggered, because of invariant (2)-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 :: 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- `mkUnion` nilAboveNest False k (fill g (y:ys))- where k' = if g then k - 1 else k--elideNest :: Doc -> Doc-elideNest (Nest _ d) = d-elideNest d = d----- ------------------------------------------------------------------------------ Selecting the best layout--best :: Int -- Line length- -> Int -- Ribbon length- -> RDoc a- -> RDoc a -- No unions in here!-best w0 r p0- = get w0 p0- where- get w _ | w == 0 && False = undefined- get _ Empty = Empty- get _ NoDoc = NoDoc- get w (NilAbove p) = nilAbove_ (get w p)- get w (TextBeside s sl p) = textBeside_ s sl (get1 w sl p)- get w (Nest k p) = nest_ k (get (w - k) p)- get w (p `Union` q) = nicest w r (get w p) (get w q)- get _ (Above {}) = error "best get Above"- get _ (Beside {}) = error "best get Beside"-- get1 w _ _ | w == 0 && False = undefined- get1 _ _ Empty = Empty- get1 _ _ NoDoc = NoDoc- get1 w sl (NilAbove p) = nilAbove_ (get (w - sl) p)- get1 w sl (TextBeside t tl p) = textBeside_ t tl (get1 w (sl + tl) p)- get1 w sl (Nest _ p) = get1 w sl p- get1 w sl (p `Union` q) = nicest1 w r sl (get1 w sl p)- (get1 w sl q)- get1 _ _ (Above {}) = error "best get1 Above"- get1 _ _ (Beside {}) = error "best get1 Beside"--nicest :: Int -> Int -> Doc -> Doc -> Doc-nicest !w !r p q = nicest1 w r 0 p q--nicest1 :: Int -> Int -> Int -> Doc -> Doc -> Doc-nicest1 !w !r !sl p q | fits ((w `min` r) - sl) p = p- | otherwise = q--fits :: Int -- Space available- -> Doc- -> Bool -- True if *first line* of Doc fits in space available-fits n _ | n < 0 = False-fits _ NoDoc = False-fits _ Empty = True-fits _ (NilAbove _) = True-fits n (TextBeside _ sl p) = fits (n - sl) p-fits _ (Above {}) = error "fits Above"-fits _ (Beside {}) = error "fits Beside"-fits _ (Union {}) = error "fits Union"-fits _ (Nest {}) = error "fits Nest"---- | @first@ returns its first argument if it is non-empty, otherwise its second.-first :: Doc -> Doc -> Doc-first p q | nonEmptySet p = p -- unused, because (get OneLineMode) is unused- | otherwise = q--nonEmptySet :: Doc -> Bool-nonEmptySet NoDoc = False-nonEmptySet (_ `Union` _) = True-nonEmptySet Empty = True-nonEmptySet (NilAbove _) = True-nonEmptySet (TextBeside _ _ p) = nonEmptySet p-nonEmptySet (Nest _ p) = nonEmptySet p-nonEmptySet (Above {}) = error "nonEmptySet Above"-nonEmptySet (Beside {}) = error "nonEmptySet Beside"---- @oneLiner@ returns the one-line members of the given set of @GDoc@s.-oneLiner :: Doc -> Doc-oneLiner NoDoc = NoDoc-oneLiner Empty = Empty-oneLiner (NilAbove _) = NoDoc-oneLiner (TextBeside s sl p) = textBeside_ s sl (oneLiner p)-oneLiner (Nest k p) = nest_ k (oneLiner p)-oneLiner (p `Union` _) = oneLiner p-oneLiner (Above {}) = error "oneLiner Above"-oneLiner (Beside {}) = error "oneLiner Beside"----- ------------------------------------------------------------------------------ Rendering---- | A rendering style.-data Style- = Style { mode :: Mode -- ^ The rendering mode- , lineLength :: Int -- ^ Length of line, in chars- , ribbonsPerLine :: Float -- ^ Ratio of ribbon length to line length- }---- | The default style (@mode=PageMode, lineLength=100, ribbonsPerLine=1.5@).-style :: Style-style = Style { lineLength = 100, ribbonsPerLine = 1.5, mode = PageMode }---- | Rendering mode.-data Mode = PageMode -- ^ Normal- | ZigZagMode -- ^ With zig-zag cuts- | LeftMode -- ^ No indentation, infinitely long lines- | OneLineMode -- ^ All on one line---- | Render the @Doc@ to a String using the default @Style@.-render :: Doc -> String-render doc = fullRender (mode style) (lineLength style) (ribbonsPerLine style)- txtPrinter "" doc---- | Render the @Doc@ to a String using the given @Style@.-renderStyle :: Style -> Doc -> String-renderStyle s doc = fullRender (mode s) (lineLength s) (ribbonsPerLine s)- txtPrinter "" doc---- | Default TextDetails printer-txtPrinter :: TextDetails -> String -> String-txtPrinter (Chr c) s = c:s-txtPrinter (Str s1) s2 = s1 ++ s2-txtPrinter (PStr s1) s2 = s1 ++ s2---- | The general rendering interface.-fullRender :: Mode -- ^ Rendering mode- -> Int -- ^ Line length- -> Float -- ^ Ribbons per line- -> (TextDetails -> a -> a) -- ^ What to do with text- -> a -- ^ What to do at the end- -> Doc -- ^ The document- -> a -- ^ Result-fullRender OneLineMode _ _ txt end doc- = easy_display space_text (\_ y -> y) txt end (reduceDoc doc)-fullRender LeftMode _ _ txt end doc- = easy_display nl_text first txt end (reduceDoc doc)--fullRender m lineLen ribbons txt rest doc- = display m lineLen ribbonLen txt rest doc'- where- doc' = best bestLineLen ribbonLen (reduceDoc doc)-- bestLineLen, ribbonLen :: Int- ribbonLen = round (fromIntegral lineLen / ribbons)- bestLineLen = case m of- ZigZagMode -> maxBound- _ -> lineLen--easy_display :: TextDetails- -> (Doc -> Doc -> Doc)- -> (TextDetails -> a -> a)- -> a- -> Doc- -> a-easy_display nl_space_text choose txt end doc- = lay doc- where- lay NoDoc = error "easy_display: NoDoc"- lay (Union p q) = lay (choose p q)- lay (Nest _ p) = lay p- lay Empty = end- lay (NilAbove p) = nl_space_text `txt` lay p- lay (TextBeside s _ p) = s `txt` lay p- lay (Above {}) = error "easy_display Above"- lay (Beside {}) = error "easy_display Beside"--display :: Mode -> Int -> Int -> (TextDetails -> a -> a) -> a -> Doc -> a-display m !page_width !ribbon_width txt end doc- = case page_width - ribbon_width of { gap_width ->- case gap_width `quot` 2 of { shift ->- let- lay k _ | k `seq` False = undefined- lay k (Nest k1 p) = lay (k + k1) p- lay _ Empty = end- lay k (NilAbove p) = nl_text `txt` lay k p- lay k (TextBeside s sl p)- = case m of- ZigZagMode | k >= gap_width- -> nl_text `txt` (- Str (replicate shift '/') `txt` (- nl_text `txt`- lay1 (k - shift) s sl p ))-- | k < 0- -> nl_text `txt` (- Str (replicate shift '\\') `txt` (- nl_text `txt`- lay1 (k + shift) s sl p ))-- _ -> lay1 k s sl p- lay _ (Above {}) = error "display lay Above"- lay _ (Beside {}) = error "display lay Beside"- lay _ NoDoc = error "display lay NoDoc"- lay _ (Union {}) = error "display lay Union"-- lay1 !k s !sl p = let !r = k + sl- in Str (indent k) `txt` (s `txt` lay2 r p)-- lay2 k _ | k `seq` False = undefined- lay2 k (NilAbove p) = nl_text `txt` lay k p- lay2 k (TextBeside s sl p) = s `txt` lay2 (k + sl) p- lay2 k (Nest _ p) = lay2 k p- lay2 _ Empty = end- lay2 _ (Above {}) = error "display lay2 Above"- lay2 _ (Beside {}) = error "display lay2 Beside"- lay2 _ NoDoc = error "display lay2 NoDoc"- lay2 _ (Union {}) = error "display lay2 Union"- in- lay 0 doc- }}-
pretty.cabal view
@@ -1,5 +1,5 @@ name: pretty-version: 1.1.1.0+version: 1.1.1.1 synopsis: Pretty-printing library description: This package contains a pretty-printing library, a set of API's@@ -13,21 +13,47 @@ license: BSD3 license-file: LICENSE category: Text-maintainer: David Terei <dave.terei@gmail.com>+maintainer: David Terei <code@davidterei.com> homepage: http://github.com/haskell/pretty-bug-reports: http://hackage.haskell.org/trac/ghc/newticket?component=libraries/pretty+bug-reports: http://github.com/haskell/pretty/issues stability: Stable build-type: Simple-Cabal-Version: >= 1.6+Extra-Source-Files: README.md CHANGELOG.md+Cabal-Version: >= 1.8 +source-repository head+ type: git+ location: http://github.com/haskell/pretty.git+ Library+ hs-source-dirs: src exposed-modules: Text.PrettyPrint Text.PrettyPrint.HughesPJ build-depends: base >= 3 && < 5- extensions: CPP+ extensions: CPP, BangPatterns+ ghc-options: -Wall -fwarn-tabs -source-repository head- type: git- location: http://github.com/haskell/pretty.git+Test-Suite test-pretty+ type: exitcode-stdio-1.0+ hs-source-dirs: tests+ src+ build-depends: base >= 3 && < 5,+ QuickCheck >= 2.5 && <3+ main-is: Test.hs+ other-modules:+ TestGenerators+ TestStructures+ extensions: CPP, BangPatterns+ include-dirs: src/Text/PrettyPrint++-- Executable Bench1+-- main-is: Bench1.hs+-- hs-source-dirs: test+-- src+-- other-modules:+-- Text.PrettyPrint+-- Text.PrettyPrint.HughesPJ+-- extensions: CPP, BangPatterns+-- ghc-options: -O -fwarn-tabs
+ src/Text/PrettyPrint.hs view
@@ -0,0 +1,70 @@+#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE Safe #-}+#endif+-----------------------------------------------------------------------------+-- |+-- Module : Text.PrettyPrint+-- Copyright : (c) The University of Glasgow 2001+-- License : BSD-style (see the file LICENSE)+-- +-- Maintainer : David Terei <dave.terei@gmail.com>+-- Stability : stable+-- Portability : portable+--+-- The default interface to the pretty-printing library. Provides a collection+-- of pretty printer combinators.+--+-- This module should be used as opposed to the "Text.PrettyPrint.HughesPJ"+-- module. Both are equivalent though as this module simply re-exports the+-- other.+--+-----------------------------------------------------------------------------++module Text.PrettyPrint ( ++ -- * The document type+ Doc,++ -- * Constructing documents++ -- ** Converting values into documents+ char, text, ptext, sizedText, zeroWidthText,+ int, integer, float, double, rational,++ -- ** Simple derived documents+ semi, comma, colon, space, equals,+ lparen, rparen, lbrack, rbrack, lbrace, rbrace,++ -- ** Wrapping documents in delimiters+ parens, brackets, braces, quotes, doubleQuotes,++ -- ** Combining documents+ empty,+ (<>), (<+>), hcat, hsep,+ ($$), ($+$), vcat,+ sep, cat,+ fsep, fcat,+ nest,+ hang, punctuate,++ -- * Predicates on documents+ isEmpty,++ -- * Rendering documents++ -- ** Default rendering+ render,++ -- ** Rendering with a particular style+ Style(..),+ style,+ renderStyle,++ -- ** General rendering+ fullRender,+ Mode(..), TextDetails(..)++ ) where++import Text.PrettyPrint.HughesPJ+
+ src/Text/PrettyPrint/HughesPJ.hs view
@@ -0,0 +1,904 @@+{-# OPTIONS_HADDOCK not-home #-}+{-# LANGUAGE BangPatterns #-}+#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE Safe #-}+#endif++-----------------------------------------------------------------------------+-- |+-- Module : Text.PrettyPrint.HughesPJ+-- Copyright : (c) The University of Glasgow 2001+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : David Terei <dave.terei@gmail.com>+-- Stability : stable+-- Portability : portable+--+-- John Hughes's and Simon Peyton Jones's Pretty Printer Combinators+--+-- Based on /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>+--+-----------------------------------------------------------------------------++#ifndef TESTING+module Text.PrettyPrint.HughesPJ (++ -- * The document type+ Doc, TextDetails(..),++ -- * Constructing documents++ -- ** Converting values into documents+ char, text, ptext, sizedText, zeroWidthText,+ int, integer, float, double, rational,++ -- ** Simple derived documents+ semi, comma, colon, space, equals,+ lparen, rparen, lbrack, rbrack, lbrace, rbrace,++ -- ** Wrapping documents in delimiters+ parens, brackets, braces, quotes, doubleQuotes,++ -- ** Combining documents+ empty,+ (<>), (<+>), hcat, hsep,+ ($$), ($+$), vcat,+ sep, cat,+ fsep, fcat,+ nest,+ hang, punctuate,++ -- * Predicates on documents+ isEmpty,++ -- * Utility functions for documents+ first, reduceDoc,+ -- TODO: Should these be exported? Previously they weren't++ -- * Rendering documents++ -- ** Default rendering+ render,++ -- ** Rendering with a particular style+ Style(..),+ style,+ renderStyle,+ Mode(..),++ -- ** General rendering+ fullRender++ ) where+#endif++import Data.Monoid ( Monoid(mempty, mappend) )+import Data.String ( IsString(fromString) )++-- ---------------------------------------------------------------------------+-- The Doc calculus++{-+Laws for $$+~~~~~~~~~~~+<a1> (x $$ y) $$ z = x $$ (y $$ z)+<a2> empty $$ x = x+<a3> x $$ empty = x++ ...ditto $+$...++Laws for <>+~~~~~~~~~~~+<b1> (x <> y) <> z = x <> (y <> z)+<b2> empty <> x = empty+<b3> x <> empty = x++ ...ditto <+>...++Laws for text+~~~~~~~~~~~~~+<t1> text s <> text t = text (s++t)+<t2> text "" <> x = x, if x non-empty++** because of law n6, t2 only holds if x doesn't+** start with `nest'.+++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 x <> 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++** Note the side condition on <n6>! It is this that+** makes it OK for empty to be a left unit for <>.++Miscellaneous+~~~~~~~~~~~~~+<m1> (text s <> x) $$ y = text s <> ((text "" <> x) $$+ nest (-length s) y)++<m2> (x $$ y) <> z = x $$ (y <> z)+ if y non-empty+++Laws for list versions+~~~~~~~~~~~~~~~~~~~~~~+<l1> sep (ps++[empty]++qs) = sep (ps ++ qs)+ ...ditto hsep, hcat, vcat, fill...++<l2> nest k (sep ps) = sep (map (nest k) ps)+ ...ditto hsep, hcat, vcat, fill...++Laws for oneLiner+~~~~~~~~~~~~~~~~~+<o1> oneLiner (nest k p) = nest k (oneLiner p)+<o2> oneLiner (x <> y) = oneLiner x <> oneLiner y++You might think that the following verion of <m1> would+be neater:++<3 NO> (text s <> x) $$ y = text s <> ((empty <> x)) $$+ nest (-length s) y)++But it doesn't work, for if x=empty, we would have++ text s $$ y = text s <> (empty $$ nest (-length s) y)+ = text s <> nest (-length s) y+-}++-- ---------------------------------------------------------------------------+-- Operator fixity++infixl 6 <>+infixl 6 <+>+infixl 5 $$, $+$++-- ---------------------------------------------------------------------------+-- The Doc data type++-- | The abstract type of documents.+-- A Doc represents a *set* of layouts. A Doc with+-- no occurrences of Union or NoDoc represents just one layout.+data Doc+ = Empty -- empty+ | NilAbove Doc -- text "" $$ x+ | TextBeside !TextDetails {-# UNPACK #-} !Int Doc -- text s <> x+ | Nest {-# UNPACK #-} !Int Doc -- nest k x+ | Union Doc Doc -- ul `union` ur+ | NoDoc -- The empty set of documents+ | Beside Doc Bool Doc -- True <=> space between+ | Above Doc Bool Doc -- True <=> never overlap++{-+Here are the invariants:++1) The argument of NilAbove is never Empty. Therefore+ a NilAbove occupies at least two lines.++2) The argument of @TextBeside@ is never @Nest@.++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@.++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.++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)+-}+++-- | RDoc is a "reduced GDoc", guaranteed not to have a top-level Above or Beside.+type RDoc = Doc++-- | The TextDetails data type+--+-- A TextDetails represents a fragment of text that will be+-- output at some point.+data TextDetails = Chr {-# UNPACK #-} !Char -- ^ A single Char fragment+ | Str String -- ^ A whole String fragment+ | PStr String -- ^ Used to represent a Fast String fragment+ -- but now deprecated and identical to the+ -- Str constructor.++-- Combining @Doc@ values+instance Monoid Doc where+ mempty = empty+ mappend = (<>)++instance IsString Doc where+ fromString = text++instance Show Doc where+ showsPrec _ doc cont = fullRender (mode style) (lineLength style)+ (ribbonsPerLine style)+ txtPrinter cont doc++-- ---------------------------------------------------------------------------+-- Values and Predicates on GDocs and TextDetails++-- | A document of height and width 1, containing a literal character.+char :: Char -> Doc+char c = textBeside_ (Chr c) 1 Empty++-- | A document of height 1 containing a literal string.+-- 'text' satisfies the following laws:+--+-- * @'text' s '<>' 'text' t = 'text' (s'++'t)@+--+-- * @'text' \"\" '<>' x = x@, if @x@ non-empty+--+-- The side condition on the last law is necessary because @'text' \"\"@+-- has height 1, while 'empty' has no height.+text :: String -> Doc+text s = case length s of {sl -> textBeside_ (Str s) sl Empty}++-- | Same as @text@. Used to be used for Bytestrings.+ptext :: String -> Doc+ptext s = case length s of {sl -> textBeside_ (PStr s) sl Empty}++-- | Some text with any width. (@text s = sizedText (length s) s@)+sizedText :: Int -> String -> Doc+sizedText l s = textBeside_ (Str s) l Empty++-- | Some text, but without any width. Use for non-printing text+-- such as a HTML or Latex tags+zeroWidthText :: String -> Doc+zeroWidthText = sizedText 0++-- | The empty document, with no height and no width.+-- 'empty' is the identity for '<>', '<+>', '$$' and '$+$', and anywhere+-- in the argument list for 'sep', 'hcat', 'hsep', 'vcat', 'fcat' etc.+empty :: Doc+empty = Empty++-- | Returns 'True' if the document is empty+isEmpty :: Doc -> Bool+isEmpty Empty = True+isEmpty _ = False++-- | Produce spacing for indenting the amount specified.+--+-- an old version inserted tabs being 8 columns apart in the output.+indent :: Int -> String+indent !n = replicate n ' '++{-+Q: What is the reason for negative indentation (i.e. argument to indent+ is < 0) ?++A:+This indicates an error in the library client's code.+If we compose a <> b, and the first line of b is more indented than some+other lines of b, the law <n6> (<> eats nests) may cause the pretty+printer to produce an invalid layout:++doc |0123345+------------------+d1 |a...|+d2 |...b|+ |c...|++d1<>d2 |ab..|+ c|....|++Consider a <> b, let `s' be the length of the last line of `a', `k' the+indentation of the first line of b, and `k0' the indentation of the+left-most line b_i of b.++The produced layout will have negative indentation if `k - k0 > s', as+the first line of b will be put on the (s+1)th column, effectively+translating b horizontally by (k-s). Now if the i^th line of b has an+indentation k0 < (k-s), it is translated out-of-page, causing+`negative indentation'.+-}+++semi :: Doc -- ^ A ';' character+comma :: Doc -- ^ A ',' character+colon :: Doc -- ^ A ':' character+space :: Doc -- ^ A space character+equals :: Doc -- ^ A '=' character+lparen :: Doc -- ^ A '(' character+rparen :: Doc -- ^ A ')' character+lbrack :: Doc -- ^ A '[' character+rbrack :: Doc -- ^ A ']' character+lbrace :: Doc -- ^ A '{' character+rbrace :: Doc -- ^ A '}' character+semi = char ';'+comma = char ','+colon = char ':'+space = char ' '+equals = char '='+lparen = char '('+rparen = char ')'+lbrack = char '['+rbrack = char ']'+lbrace = char '{'+rbrace = char '}'++space_text, nl_text :: TextDetails+space_text = Chr ' '+nl_text = Chr '\n'++int :: Int -> Doc -- ^ @int n = text (show n)@+integer :: Integer -> Doc -- ^ @integer n = text (show n)@+float :: Float -> Doc -- ^ @float n = text (show n)@+double :: Double -> Doc -- ^ @double n = text (show n)@+rational :: Rational -> Doc -- ^ @rational n = text (show n)@+int n = text (show n)+integer n = text (show n)+float n = text (show n)+double n = text (show n)+rational n = text (show n)++parens :: Doc -> Doc -- ^ Wrap document in @(...)@+brackets :: Doc -> Doc -- ^ Wrap document in @[...]@+braces :: Doc -> Doc -- ^ Wrap document in @{...}@+quotes :: Doc -> Doc -- ^ Wrap document in @\'...\'@+doubleQuotes :: Doc -> Doc -- ^ Wrap document in @\"...\"@+quotes p = char '\'' <> p <> char '\''+doubleQuotes p = char '"' <> p <> char '"'+parens p = char '(' <> p <> char ')'+brackets p = char '[' <> p <> char ']'+braces p = char '{' <> p <> char '}'+++-- ---------------------------------------------------------------------------+-- Structural operations on GDocs++-- | Perform some simplification of a built up @GDoc@.+reduceDoc :: Doc -> RDoc+reduceDoc (Beside p g q) = beside p g (reduceDoc q)+reduceDoc (Above p g q) = above p g (reduceDoc q)+reduceDoc p = p++-- | List version of '<>'.+hcat :: [Doc] -> Doc+hcat = reduceAB . foldr (beside_' False) empty++-- | List version of '<+>'.+hsep :: [Doc] -> Doc+hsep = reduceAB . foldr (beside_' True) empty++-- | List version of '$$'.+vcat :: [Doc] -> Doc+vcat = reduceAB . foldr (above_' False) empty++-- | Nest (or indent) a document by a given number of positions+-- (which may also be negative). 'nest' satisfies the laws:+--+-- * @'nest' 0 x = x@+--+-- * @'nest' k ('nest' k' x) = 'nest' (k+k') x@+--+-- * @'nest' k (x '<>' y) = 'nest' k z '<>' 'nest' k y@+--+-- * @'nest' k (x '$$' y) = 'nest' k x '$$' 'nest' k y@+--+-- * @'nest' k 'empty' = 'empty'@+--+-- * @x '<>' 'nest' k y = x '<>' y@, if @x@ non-empty+--+-- The side condition on the last law is needed because+-- 'empty' is a left identity for '<>'.+nest :: Int -> Doc -> Doc+nest k p = mkNest k (reduceDoc p)++-- | @hang d1 n d2 = sep [d1, nest n d2]@+hang :: Doc -> Int -> Doc -> Doc+hang d1 n d2 = sep [d1, nest n d2]++-- | @punctuate p [d1, ... dn] = [d1 \<> p, d2 \<> p, ... dn-1 \<> p, dn]@+punctuate :: Doc -> [Doc] -> [Doc]+punctuate _ [] = []+punctuate p (x:xs) = go x xs+ where go y [] = [y]+ go y (z:zs) = (y <> p) : go z zs++-- mkNest checks for Nest's invariant that it doesn't have an Empty inside it+mkNest :: Int -> Doc -> Doc+mkNest k _ | k `seq` False = undefined+mkNest k (Nest k1 p) = mkNest (k + k1) p+mkNest _ NoDoc = NoDoc+mkNest _ Empty = Empty+mkNest 0 p = p+mkNest k p = nest_ k p++-- mkUnion checks for an empty document+mkUnion :: Doc -> Doc -> Doc+mkUnion Empty _ = Empty+mkUnion p q = p `union_` q++beside_' :: Bool -> Doc -> Doc -> Doc+beside_' _ p Empty = p+beside_' g p q = Beside p g q++above_' :: Bool -> Doc -> Doc -> Doc+above_' _ p Empty = p+above_' g p q = Above p g q++reduceAB :: Doc -> Doc+reduceAB (Above Empty _ q) = q+reduceAB (Beside Empty _ q) = q+reduceAB doc = doc++nilAbove_ :: RDoc -> RDoc+nilAbove_ p = NilAbove p++-- Arg of a TextBeside is always an RDoc+textBeside_ :: TextDetails -> Int -> RDoc -> RDoc+textBeside_ s sl p = TextBeside s sl p++nest_ :: Int -> RDoc -> RDoc+nest_ k p = Nest k p++union_ :: RDoc -> RDoc -> RDoc+union_ p q = Union p q+++-- ---------------------------------------------------------------------------+-- Vertical composition @$$@++-- | Above, except that if the last line of the first argument stops+-- at least one position before the first line of the second begins,+-- these two lines are overlapped. For example:+--+-- > text "hi" $$ nest 5 (text "there")+--+-- lays out as+--+-- > hi there+--+-- rather than+--+-- > hi+-- > there+--+-- '$$' is associative, with identity 'empty', and also satisfies+--+-- * @(x '$$' y) '<>' z = x '$$' (y '<>' z)@, if @y@ non-empty.+--+($$) :: Doc -> Doc -> Doc+p $$ q = above_ p False q++-- | Above, with no overlapping.+-- '$+$' is associative, with identity 'empty'.+($+$) :: Doc -> Doc -> Doc+p $+$ q = above_ p True q++above_ :: Doc -> Bool -> Doc -> Doc+above_ p _ Empty = p+above_ Empty _ q = q+above_ p g q = Above p g q++above :: Doc -> Bool -> RDoc -> RDoc+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)++-- Specfication: aboveNest p g k q = p $g$ (nest k q)+aboveNest :: RDoc -> Bool -> Int -> RDoc -> RDoc+aboveNest _ _ k _ | k `seq` False = undefined+aboveNest NoDoc _ _ _ = NoDoc+aboveNest (p1 `Union` p2) g k q = aboveNest p1 g k q `union_`+ aboveNest p2 g k q++aboveNest Empty _ k q = mkNest k q+aboveNest (Nest k1 p) g k q = nest_ k1 (aboveNest p g (k - k1) q)+ -- p can't be Empty, so no need for mkNest++aboveNest (NilAbove p) g k q = nilAbove_ (aboveNest p g k q)+aboveNest (TextBeside s sl p) g k q = textBeside_ s sl rest+ where+ !k1 = k - sl+ rest = case p of+ Empty -> nilAboveNest g k1 q+ _ -> aboveNest p g k1 q+aboveNest (Above {}) _ _ _ = error "aboveNest Above"+aboveNest (Beside {}) _ _ _ = error "aboveNest Beside"++-- Specification: text s <> nilaboveNest g k q+-- = text s <> (text "" $g$ nest k q)+nilAboveNest :: Bool -> Int -> RDoc -> RDoc+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+ = nilAbove_ (mkNest k q)+++-- ---------------------------------------------------------------------------+-- Horizontal composition @<>@++-- We intentionally avoid Data.Monoid.(<>) here due to interactions of+-- Data.Monoid.(<>) and (<+>). See+-- http://www.haskell.org/pipermail/libraries/2011-November/017066.html++-- | Beside.+-- '<>' is associative, with identity 'empty'.+(<>) :: Doc -> Doc -> Doc+p <> q = beside_ p False q++-- | Beside, separated by space, unless one of the arguments is 'empty'.+-- '<+>' is associative, with identity 'empty'.+(<+>) :: Doc -> Doc -> Doc+p <+> q = beside_ p True q++beside_ :: Doc -> Bool -> Doc -> Doc+beside_ p _ Empty = p+beside_ Empty _ q = q+beside_ p g q = Beside p g q++-- Specification: beside g p q = p <g> q+beside :: Doc -> Bool -> RDoc -> RDoc+beside NoDoc _ _ = NoDoc+beside (p1 `Union` p2) g q = beside p1 g q `union_` beside p2 g q+beside Empty _ q = q+beside (Nest k p) g q = nest_ k $! beside p g q+beside p@(Beside p1 g1 q1) g2 q2+ | g1 == g2 = beside p1 g1 $! beside q1 g2 q2+ | otherwise = beside (reduceDoc p) g2 q2+beside p@(Above _ _ _) g q = let !d = reduceDoc p in beside d g q+beside (NilAbove p) g q = nilAbove_ $! beside p g q+beside (TextBeside s sl p) g q = textBeside_ s sl $! rest+ where+ rest = case p of+ Empty -> nilBeside g q+ _ -> beside p g q++-- Specification: text "" <> nilBeside g p+-- = text "" <g> p+nilBeside :: Bool -> RDoc -> RDoc+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+ | otherwise = p+++-- ---------------------------------------------------------------------------+-- Separate, @sep@++-- Specification: sep ps = oneLiner (hsep ps)+-- `union`+-- vcat ps++-- | Either 'hsep' or 'vcat'.+sep :: [Doc] -> Doc+sep = sepX True -- Separate with spaces++-- | Either 'hcat' or 'vcat'.+cat :: [Doc] -> Doc+cat = sepX False -- Don't++sepX :: Bool -> [Doc] -> Doc+sepX _ [] = empty+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)+sep1 :: Bool -> RDoc -> Int -> [Doc] -> RDoc+sep1 _ _ k _ | k `seq` False = undefined+sep1 _ NoDoc _ _ = NoDoc+sep1 g (p `Union` q) k ys = sep1 g p k ys `union_`+ aboveNest q False k (reduceDoc (vcat ys))++sep1 g Empty k ys = mkNest k (sepX g ys)+sep1 g (Nest n p) k ys = nest_ n (sep1 g p (k - n) ys)++sep1 _ (NilAbove p) k ys = nilAbove_+ (aboveNest p False k (reduceDoc (vcat ys)))+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"++-- 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`+ -- XXX: TODO: PRETTY: Used to use True here (but GHC used False...)+ nilAboveNest False k (reduceDoc (vcat ys))+ where+ rest | g = hsep ys+ | otherwise = hcat ys+sepNB g p k ys+ = sep1 g p k ys+++-- ---------------------------------------------------------------------------+-- @fill@++-- | \"Paragraph fill\" version of 'cat'.+fcat :: [Doc] -> Doc+fcat = fill False++-- | \"Paragraph fill\" version of 'sep'.+fsep :: [Doc] -> Doc+fsep = fill True++-- 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 | hasMoreThanOneLine layout1 = layout1 $$ layout2+-- | otherwise = layout1 $+$ layout2++fill :: Bool -> [Doc] -> RDoc+fill _ [] = empty+fill g (p:ps) = fill1 g (reduceDoc p) 0 ps++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+ -- Never triggered, because of invariant (2)+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 :: Bool -> Int -> Doc -> [Doc] -> Doc+fillNBE g k y ys+ = nilBeside g (fill1 g ((elideNest . oneLiner . reduceDoc) y) k' ys)+ -- XXX: TODO: PRETTY: Used to use True here (but GHC used False...)+ `mkUnion` nilAboveNest False k (fill g (y:ys))+ where k' = if g then k - 1 else k++elideNest :: Doc -> Doc+elideNest (Nest _ d) = d+elideNest d = d+++-- ---------------------------------------------------------------------------+-- Selecting the best layout++best :: Int -- Line length+ -> Int -- Ribbon length+ -> RDoc+ -> RDoc -- No unions in here!+best w0 r p0+ = get w0 p0+ where+ get w _ | w == 0 && False = undefined+ get _ Empty = Empty+ get _ NoDoc = NoDoc+ get w (NilAbove p) = nilAbove_ (get w p)+ get w (TextBeside s sl p) = textBeside_ s sl (get1 w sl p)+ get w (Nest k p) = nest_ k (get (w - k) p)+ get w (p `Union` q) = nicest w r (get w p) (get w q)+ get _ (Above {}) = error "best get Above"+ get _ (Beside {}) = error "best get Beside"++ get1 w _ _ | w == 0 && False = undefined+ get1 _ _ Empty = Empty+ get1 _ _ NoDoc = NoDoc+ get1 w sl (NilAbove p) = nilAbove_ (get (w - sl) p)+ get1 w sl (TextBeside t tl p) = textBeside_ t tl (get1 w (sl + tl) p)+ get1 w sl (Nest _ p) = get1 w sl p+ get1 w sl (p `Union` q) = nicest1 w r sl (get1 w sl p)+ (get1 w sl q)+ get1 _ _ (Above {}) = error "best get1 Above"+ get1 _ _ (Beside {}) = error "best get1 Beside"++nicest :: Int -> Int -> Doc -> Doc -> Doc+nicest !w !r p q = nicest1 w r 0 p q++nicest1 :: Int -> Int -> Int -> Doc -> Doc -> Doc+nicest1 !w !r !sl p q | fits ((w `min` r) - sl) p = p+ | otherwise = q++fits :: Int -- Space available+ -> Doc+ -> Bool -- True if *first line* of Doc fits in space available+fits n _ | n < 0 = False+fits _ NoDoc = False+fits _ Empty = True+fits _ (NilAbove _) = True+fits n (TextBeside _ sl p) = fits (n - sl) p+fits _ (Above {}) = error "fits Above"+fits _ (Beside {}) = error "fits Beside"+fits _ (Union {}) = error "fits Union"+fits _ (Nest {}) = error "fits Nest"++-- | @first@ returns its first argument if it is non-empty, otherwise its second.+first :: Doc -> Doc -> Doc+first p q | nonEmptySet p = p -- unused, because (get OneLineMode) is unused+ | otherwise = q++nonEmptySet :: Doc -> Bool+nonEmptySet NoDoc = False+nonEmptySet (_ `Union` _) = True+nonEmptySet Empty = True+nonEmptySet (NilAbove _) = True+nonEmptySet (TextBeside _ _ p) = nonEmptySet p+nonEmptySet (Nest _ p) = nonEmptySet p+nonEmptySet (Above {}) = error "nonEmptySet Above"+nonEmptySet (Beside {}) = error "nonEmptySet Beside"++-- @oneLiner@ returns the one-line members of the given set of @GDoc@s.+oneLiner :: Doc -> Doc+oneLiner NoDoc = NoDoc+oneLiner Empty = Empty+oneLiner (NilAbove _) = NoDoc+oneLiner (TextBeside s sl p) = textBeside_ s sl (oneLiner p)+oneLiner (Nest k p) = nest_ k (oneLiner p)+oneLiner (p `Union` _) = oneLiner p+oneLiner (Above {}) = error "oneLiner Above"+oneLiner (Beside {}) = error "oneLiner Beside"+++-- ---------------------------------------------------------------------------+-- Rendering++-- | A rendering style.+data Style+ = Style { mode :: Mode -- ^ The rendering mode+ , lineLength :: Int -- ^ Length of line, in chars+ , ribbonsPerLine :: Float -- ^ Ratio of ribbon length to line length+ }++-- | The default style (@mode=PageMode, lineLength=100, ribbonsPerLine=1.5@).+style :: Style+style = Style { lineLength = 100, ribbonsPerLine = 1.5, mode = PageMode }++-- | Rendering mode.+data Mode = PageMode -- ^ Normal+ | ZigZagMode -- ^ With zig-zag cuts+ | LeftMode -- ^ No indentation, infinitely long lines+ | OneLineMode -- ^ All on one line++-- | Render the @Doc@ to a String using the default @Style@.+render :: Doc -> String+render doc = fullRender (mode style) (lineLength style) (ribbonsPerLine style)+ txtPrinter "" doc++-- | Render the @Doc@ to a String using the given @Style@.+renderStyle :: Style -> Doc -> String+renderStyle s doc = fullRender (mode s) (lineLength s) (ribbonsPerLine s)+ txtPrinter "" doc++-- | Default TextDetails printer+txtPrinter :: TextDetails -> String -> String+txtPrinter (Chr c) s = c:s+txtPrinter (Str s1) s2 = s1 ++ s2+txtPrinter (PStr s1) s2 = s1 ++ s2++-- | The general rendering interface.+fullRender :: Mode -- ^ Rendering mode+ -> Int -- ^ Line length+ -> Float -- ^ Ribbons per line+ -> (TextDetails -> a -> a) -- ^ What to do with text+ -> a -- ^ What to do at the end+ -> Doc -- ^ The document+ -> a -- ^ Result+fullRender OneLineMode _ _ txt end doc+ = easy_display space_text (\_ y -> y) txt end (reduceDoc doc)+fullRender LeftMode _ _ txt end doc+ = easy_display nl_text first txt end (reduceDoc doc)++fullRender m lineLen ribbons txt rest doc+ = display m lineLen ribbonLen txt rest doc'+ where+ doc' = best bestLineLen ribbonLen (reduceDoc doc)++ bestLineLen, ribbonLen :: Int+ ribbonLen = round (fromIntegral lineLen / ribbons)+ bestLineLen = case m of+ ZigZagMode -> maxBound+ _ -> lineLen++easy_display :: TextDetails+ -> (Doc -> Doc -> Doc)+ -> (TextDetails -> a -> a)+ -> a+ -> Doc+ -> a+easy_display nl_space_text choose txt end doc+ = lay doc+ where+ lay NoDoc = error "easy_display: NoDoc"+ lay (Union p q) = lay (choose p q)+ lay (Nest _ p) = lay p+ lay Empty = end+ lay (NilAbove p) = nl_space_text `txt` lay p+ lay (TextBeside s _ p) = s `txt` lay p+ lay (Above {}) = error "easy_display Above"+ lay (Beside {}) = error "easy_display Beside"++display :: Mode -> Int -> Int -> (TextDetails -> a -> a) -> a -> Doc -> a+display m !page_width !ribbon_width txt end doc+ = case page_width - ribbon_width of { gap_width ->+ case gap_width `quot` 2 of { shift ->+ let+ lay k _ | k `seq` False = undefined+ lay k (Nest k1 p) = lay (k + k1) p+ lay _ Empty = end+ lay k (NilAbove p) = nl_text `txt` lay k p+ lay k (TextBeside s sl p)+ = case m of+ ZigZagMode | k >= gap_width+ -> nl_text `txt` (+ Str (replicate shift '/') `txt` (+ nl_text `txt`+ lay1 (k - shift) s sl p ))++ | k < 0+ -> nl_text `txt` (+ Str (replicate shift '\\') `txt` (+ nl_text `txt`+ lay1 (k + shift) s sl p ))++ _ -> lay1 k s sl p+ lay _ (Above {}) = error "display lay Above"+ lay _ (Beside {}) = error "display lay Beside"+ lay _ NoDoc = error "display lay NoDoc"+ lay _ (Union {}) = error "display lay Union"++ lay1 !k s !sl p = let !r = k + sl+ in Str (indent k) `txt` (s `txt` lay2 r p)++ lay2 k _ | k `seq` False = undefined+ lay2 k (NilAbove p) = nl_text `txt` lay k p+ lay2 k (TextBeside s sl p) = s `txt` lay2 (k + sl) p+ lay2 k (Nest _ p) = lay2 k p+ lay2 _ Empty = end+ lay2 _ (Above {}) = error "display lay2 Above"+ lay2 _ (Beside {}) = error "display lay2 Beside"+ lay2 _ NoDoc = error "display lay2 NoDoc"+ lay2 _ (Union {}) = error "display lay2 Union"+ in+ lay 0 doc+ }}+
+ tests/Test.hs view
@@ -0,0 +1,990 @@+{-# 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 PrettyTestVersion+import TestGenerators+import TestStructures++import Control.Monad+import Data.Char (isSpace)+import Data.List (intersperse)+import Debug.Trace++import Test.QuickCheck++main :: IO ()+main = do+ check_laws + check_invariants+ check_improvements+ check_non_prims -- hpc full coverage+ check_rendering+ check_list_def++-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- Utility functions+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++-- tweaked to perform many small tests+myConfig :: Int -> Int -> Args+myConfig d n = stdArgs { maxSize = d, maxDiscardRatio = n*5 }++maxTests :: Int+maxTests = 1000++myTest :: (Testable a) => String -> a -> IO ()+myTest = myTest' 15 maxTests++myTest' :: (Testable a) => Int -> Int -> String -> a -> IO ()+myTest' d n msg t = do+ putStrLn (" * " ++ msg)+ r <- quickCheckWithResult (myConfig d n) t+ case r of+ (Failure {}) -> error "Failed testing!"+ _ -> return ()++myAssert :: String -> Bool -> IO ()+myAssert msg b = putStrLn $ (if b then "Ok, passed " else "Failed test:\n ") ++ msg++-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- 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 :: [Doc] -> [Doc] -> Maybe [(Doc, Doc)]+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)" (expectFailure . 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) + -- XXX: Not sure if this is meant to fail (I added the expectFailure [DT])+ myTest "sep def" (expectFailure . 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 :: Testable a => String -> ([Doc] -> a) -> IO ()+check_fill_prop msg p = myTest msg (prop_restrict_sz maxLayouts p . buildDocList)++check_fill_def_fail :: IO ()+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 :: IO ()+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)+ -- XXX: These all fail now with the change of pretty to GHC behaviour.+ check_fill_prop "fcat def (ol) vs fcat" (expectFailure . prop_restrict_ol prop_fcat)+ check_fill_prop "fcat def vs fcat" (expectFailure . prop_fcat)+ check_fill_prop "fsep def vs fsep" (expectFailure . prop_fsep)+++check_fill_def_laws :: IO ()+check_fill_def_laws = do+ check_fill_prop "lastLayout (fcat ps) == vcat ps" prop_fcat_vcat++check_fill_def :: IO ()+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 :: IO ()+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) -> Property+prop_inv6a sep = forAll emptyDocListGen $+ \ds -> isEmptyRepr (sep $ buildDocList 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) [ cat, sep, fcat, fsep, vcat, hcat, hsep ]+ -- XXX: Not sure if this is meant to fail (I added the expectFailure [DT])+ myTest "Invariant 7 (fails in HughesPJ:20080621)" (expectFailure . 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)+
+ tests/TestGenerators.hs view
@@ -0,0 +1,75 @@+-- | Test generators.+--+module TestGenerators (+ emptyDocGen,+ emptyDocListGen+ ) where++import PrettyTestVersion+import TestStructures++import Control.Monad++import Test.QuickCheck++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)+ ]+ 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)++instance CoArbitrary CDoc where+ 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 ]++instance CoArbitrary CList where+ coarbitrary cl = variant (case cl of CCat -> 0; CSep -> 1; CFCat -> 2; CFSep -> 3)++-- 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++instance CoArbitrary CDocList where+ coarbitrary (CDocList ds) = coarbitrary ds++instance Arbitrary Text where+ arbitrary = liftM Text $ sized $ \n -> mapM (const arbChar) [1..n]+ where arbChar = oneof (map return ['a'..'c'])++instance CoArbitrary Text where+ coarbitrary (Text str) = coarbitrary (length str)++emptyDocGen :: Gen CDoc+emptyDocGen = return CEmpty++emptyDocListGen :: Gen CDocList+emptyDocListGen = do+ ls <- listOf emptyDocGen+ return $ CDocList ls+
+ tests/TestStructures.hs view
@@ -0,0 +1,92 @@+-- | 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.+--+module TestStructures (+ CDoc(..), CList(..), CDocList(..), Text(..),++ buildDoc, liftDoc2, liftDoc3, buildDocList,+ text', tdToStr, genericCProp+ ) where++import PrettyTestVersion++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+ deriving (Eq, Ord)++data CList = CCat | CSep | CFCat | CFSep deriving (Eq,Ord)++newtype CDocList = CDocList { unDocList :: [CDoc] } ++-- wrapper for String argument of `text'+newtype Text = Text { unText :: String } deriving (Eq, Ord, Show)++instance Show CDoc where+ showsPrec k CEmpty = showString "empty"+ showsPrec k (CText s) = showParen (k >= 10) (showString " text " . 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 Show CList where + show cs = case cs of CCat -> "cat" ; CSep -> "sep" ; CFCat -> "fcat" ; CFSep -> "fsep" ++instance Show CDocList where show = show . unDocList+ +buildDoc :: CDoc -> Doc+buildDoc CEmpty = empty+buildDoc (CText s) = text 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++listComb :: CList -> ([Doc] -> Doc)+listComb cs = case cs of CCat -> cat ; CSep -> sep ; CFCat -> fcat ; CFSep -> fsep++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)+ +buildDocList :: CDocList -> [Doc]+buildDocList = map buildDoc . unDocList++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 _ -> []+ 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]+