diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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 + diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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 + + +## 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, . It +was originally designed by John Hughes's and since heavily modified by +Simon Peyton Jones. + diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -4,3 +4,4 @@ main :: IO () main = defaultMain + diff --git a/Text/PrettyPrint.hs b/Text/PrettyPrint.hs deleted file mode 100644 --- a/Text/PrettyPrint.hs +++ /dev/null @@ -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 --- 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 - diff --git a/Text/PrettyPrint/HughesPJ.hs b/Text/PrettyPrint/HughesPJ.hs deleted file mode 100644 --- a/Text/PrettyPrint/HughesPJ.hs +++ /dev/null @@ -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 --- 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 --- --- --- 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 $$ -~~~~~~~~~~~ - (x $$ y) $$ z = x $$ (y $$ z) - empty $$ x = x - x $$ empty = x - - ...ditto $+$... - -Laws for <> -~~~~~~~~~~~ - (x <> y) <> z = x <> (y <> z) - empty <> x = empty - x <> empty = x - - ...ditto <+>... - -Laws for text -~~~~~~~~~~~~~ - text s <> text t = text (s++t) - text "" <> x = x, if x non-empty - -** because of law n6, t2 only holds if x doesn't -** start with `nest'. - - -Laws for nest -~~~~~~~~~~~~~ - nest 0 x = x - nest k (nest k' x) = nest (k+k') x - nest k (x <> y) = nest k x <> 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 - -** Note the side condition on ! It is this that -** makes it OK for empty to be a left unit for <>. - -Miscellaneous -~~~~~~~~~~~~~ - (text s <> x) $$ y = text s <> ((text "" <> x) $$ - nest (-length s) y) - - (x $$ y) <> z = x $$ (y <> z) - if y non-empty - - -Laws for list versions -~~~~~~~~~~~~~~~~~~~~~~ - sep (ps++[empty]++qs) = sep (ps ++ qs) - ...ditto hsep, hcat, vcat, fill... - - nest k (sep ps) = sep (map (nest k) ps) - ...ditto hsep, hcat, vcat, fill... - -Laws for oneLiner -~~~~~~~~~~~~~~~~~ - oneLiner (nest k p) = nest k (oneLiner p) - oneLiner (x <> y) = oneLiner x <> oneLiner y - -You might think that the following verion of 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 (<> 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 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 "" 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 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 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 - }} - diff --git a/pretty.cabal b/pretty.cabal --- a/pretty.cabal +++ b/pretty.cabal @@ -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 +maintainer: David Terei 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 diff --git a/src/Text/PrettyPrint.hs b/src/Text/PrettyPrint.hs new file mode 100644 --- /dev/null +++ b/src/Text/PrettyPrint.hs @@ -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 +-- 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 + diff --git a/src/Text/PrettyPrint/HughesPJ.hs b/src/Text/PrettyPrint/HughesPJ.hs new file mode 100644 --- /dev/null +++ b/src/Text/PrettyPrint/HughesPJ.hs @@ -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 +-- 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 +-- +-- +----------------------------------------------------------------------------- + +#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 $$ +~~~~~~~~~~~ + (x $$ y) $$ z = x $$ (y $$ z) + empty $$ x = x + x $$ empty = x + + ...ditto $+$... + +Laws for <> +~~~~~~~~~~~ + (x <> y) <> z = x <> (y <> z) + empty <> x = empty + x <> empty = x + + ...ditto <+>... + +Laws for text +~~~~~~~~~~~~~ + text s <> text t = text (s++t) + text "" <> x = x, if x non-empty + +** because of law n6, t2 only holds if x doesn't +** start with `nest'. + + +Laws for nest +~~~~~~~~~~~~~ + nest 0 x = x + nest k (nest k' x) = nest (k+k') x + nest k (x <> y) = nest k x <> 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 + +** Note the side condition on ! It is this that +** makes it OK for empty to be a left unit for <>. + +Miscellaneous +~~~~~~~~~~~~~ + (text s <> x) $$ y = text s <> ((text "" <> x) $$ + nest (-length s) y) + + (x $$ y) <> z = x $$ (y <> z) + if y non-empty + + +Laws for list versions +~~~~~~~~~~~~~~~~~~~~~~ + sep (ps++[empty]++qs) = sep (ps ++ qs) + ...ditto hsep, hcat, vcat, fill... + + nest k (sep ps) = sep (map (nest k) ps) + ...ditto hsep, hcat, vcat, fill... + +Laws for oneLiner +~~~~~~~~~~~~~~~~~ + oneLiner (nest k p) = nest k (oneLiner p) + oneLiner (x <> y) = oneLiner x <> oneLiner y + +You might think that the following verion of 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 (<> 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 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 "" 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 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 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 + }} + diff --git a/tests/Test.hs b/tests/Test.hs new file mode 100644 --- /dev/null +++ b/tests/Test.hs @@ -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 <>,<+>,$$,$+$ +~~~~~~~~~~~~~ + (x * y) * z = x * (y * z) + empty * x = x + 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 +~~~~~~~~~~~~~ + text s <> text t = text (s++t) + text "" <> x = x, if x non-empty [only true if x does not start with nest, because of ] +-} +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 +~~~~~~~~~~~~~ + 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 +-} +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)) + +{- + (text s <> x) $$ y = text s <> ((text "" <> x)) $$ + nest (-length s) y) + + (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 +~~~~~~~~~~~~~~~~~~~~~~ + sep (ps++[empty]++qs) = sep (ps ++ qs) + ...ditto hsep, hcat, vcat, fill... +[ Fails for fill ! ] + 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 +~~~~~~~~~~~~~~~~~ + oneLiner (nest k p) = nest k (oneLiner p) + 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 +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + vcat = foldr ($$) empty + hcat = foldr (<>) empty + 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 + ? +-} +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 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) + diff --git a/tests/TestGenerators.hs b/tests/TestGenerators.hs new file mode 100644 --- /dev/null +++ b/tests/TestGenerators.hs @@ -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 + diff --git a/tests/TestStructures.hs b/tests/TestStructures.hs new file mode 100644 --- /dev/null +++ b/tests/TestStructures.hs @@ -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] +