pretty 1.0.1.2 → 1.1.3.6
raw patch · 22 files changed
Files
- CHANGELOG.md +203/−0
- README.md +65/−0
- Setup.hs +1/−0
- Text/PrettyPrint.hs +0/−21
- Text/PrettyPrint/HughesPJ.hs +0/−1095
- bench/Bench.hs +75/−0
- pretty.cabal +71/−16
- src/Text/PrettyPrint.hs +71/−0
- src/Text/PrettyPrint/Annotated.hs +78/−0
- src/Text/PrettyPrint/Annotated/HughesPJ.hs +1194/−0
- src/Text/PrettyPrint/Annotated/HughesPJClass.hs +147/−0
- src/Text/PrettyPrint/HughesPJ.hs +457/−0
- src/Text/PrettyPrint/HughesPJClass.hs +146/−0
- tests/PrettyTestVersion.hs +14/−0
- tests/Test.hs +998/−0
- tests/TestGenerators.hs +75/−0
- tests/TestStructures.hs +96/−0
- tests/TestUtils.hs +19/−0
- tests/UnitLargeDoc.hs +16/−0
- tests/UnitPP1.hs +76/−0
- tests/UnitT32.hs +9/−0
- tests/UnitT3911.hs +25/−0
+ CHANGELOG.md view
@@ -0,0 +1,203 @@+# Pretty library change log++## 1.1.3.6 -- 30th January, 2018++* Fix compatability with GHC-8.4/base-4.11 (by Herbert Valerio Riedel).+* Add in benchmarking framework (by Alfredo Di Napoli).++## 1.1.3.5 -- 1st February, 2017++* Fix documentation formatting bug (by Ivan Lazar Miljenovic)+* Fix missing git tag on Github for v1.1.3.4 release.++## 1.1.3.4 -- 3rd June, 2016++* Fix over-zeleaous use of strictness causing stack allocation, fixes part of+ issue #32 (by Neil Mitchell).++## 1.1.3.3 -- 29th February, 2016++* Improve documentation.++## 1.1.3.2 -- 19th March, 2015++* Fix bug with haddock documentation.+* Clean up module intro documentation.++## 1.1.3.1 -- 11th March, 2015++* Add support for annotations in pretty (by Trevor Elliott).++## 1.1.2.1 -- 25th December, 2014++* Fix overly-strict issue preventing use of pretty for very large+ docs (by Eyal Lotem).++## 1.1.2.0 -- 25th December, 2014++* Merge in prettyclass package -- new Text.PrettyPrint.HughesPHClass.+* Add in 'maybe\*' variants of various bracket functins.+* Add Generic instances for appropriate data types.+* Fix compilation under GHC 7.10++## 1.1.1.3 -- 21st December, 2014++* Remove upper bound on `deepseq` package to fix build issues with+ latest GHC.++## 1.1.1.2 -- 18th August, 2014++* Add NFData and Eq instances (by Ivan Lazar Miljenovic).++## 1.1.1.1 -- 27th October, 2013++* Update pretty cabal file and readme.+* Fix tests to work with latest quickcheck.++## Version 3.0, 28 May 1987++* Cured massive performance bug. If you write:++ foldl <> empty (map (text.show) [1..10000])++ You get quadratic behaviour with V2.0. Why? For just the same+ reason as you get quadratic behaviour with left-associated (++)+ chains.++ This is really bad news. One thing a pretty-printer abstraction+ should certainly guarantee is insensitivity to associativity. It+ matters: suddenly GHC's compilation times went up by a factor of+ 100 when I switched to the new pretty printer.+ + I fixed it with a bit of a hack (because I wanted to get GHC back+ on the road). I added two new constructors to the Doc type, Above+ and Beside:+ + <> = Beside+ $$ = Above+ + Then, where I need to get to a "TextBeside" or "NilAbove" form I+ "force" the Doc to squeeze out these suspended calls to Beside and+ Above; but in so doing I re-associate. It's quite simple, but I'm+ not satisfied that I've done the best possible job. I'll send you+ the code if you are interested.++* Added new exports:+ punctuate, hang+ int, integer, float, double, rational,+ lparen, rparen, lbrack, rbrack, lbrace, rbrace,++* fullRender's type signature has changed. Rather than producing a+ string it now takes an extra couple of arguments that tells it how+ to glue fragments of output together:++ fullRender :: Mode+ -> Int -- Line length+ -> Float -- Ribbons per line+ -> (TextDetails -> a -> a) -- What to do with text+ -> a -- What to do at the end+ -> Doc+ -> a -- Result++ The "fragments" are encapsulated in the TextDetails data type:++ data TextDetails = Chr Char+ | Str String+ | PStr FAST_STRING++ The Chr and Str constructors are obvious enough. The PStr+ constructor has a packed string (FAST_STRING) inside it. It's+ generated by using the new "ptext" export.++ An advantage of this new setup is that you can get the renderer to+ do output directly (by passing in a function of type (TextDetails+ -> IO () -> IO ()), rather than producing a string that you then+ print.++## Version 3.0, 28 May 1987++* Made empty into a left unit for <> as well as a right unit;+ it is also now true that+ nest k empty = empty+ which wasn't true before.++* Fixed an obscure bug in sep that occasionally gave very weird behaviour++* Added $+$++* Corrected and tidied up the laws and invariants++## Version 1.0++Relative to John's original paper, there are the following new features:++1. There's an empty document, "empty". It's a left and right unit for+ both <> and $$, and anywhere in the argument list for+ sep, hcat, hsep, vcat, fcat etc.++ It is Really Useful in practice.++2. There is a paragraph-fill combinator, fsep, that's much like sep,+ only it keeps fitting things on one line until it can't fit any more.++3. Some random useful extra combinators are provided.+ <+> puts its arguments beside each other with a space between them,+ unless either argument is empty in which case it returns the other+++ hcat is a list version of <>+ hsep is a list version of <+>+ vcat is a list version of $$++ sep (separate) is either like hsep or like vcat, depending on what fits++ cat behaves like sep, but it uses <> for horizontal composition+ fcat behaves like fsep, but it uses <> for horizontal composition++ These new ones do the obvious things:+ char, semi, comma, colon, space,+ parens, brackets, braces,+ quotes, doubleQuotes++4. The "above" combinator, $$, now overlaps its two arguments if the+ last line of the top argument stops before the first line of the+ second begins.++ For example: text "hi" $$ nest 5 (text "there")+ lays out as+ hi there+ rather than+ hi+ there++ There are two places this is really useful++ a) When making labelled blocks, like this:+ Left -> code for left+ Right -> code for right+ LongLongLongLabel ->+ code for longlonglonglabel+ The block is on the same line as the label if the label is+ short, but on the next line otherwise.++ b) When laying out lists like this:+ [ first+ , second+ , third+ ]+ which some people like. But if the list fits on one line you+ want [first, second, third]. You can't do this with John's+ original combinators, but it's quite easy with the new $$.++ The combinator $+$ gives the original "never-overlap" behaviour.++5. Several different renderers are provided:+ * a standard one+ * one that uses cut-marks to avoid deeply-nested documents+ simply piling up in the right-hand margin+ * one that ignores indentation (fewer chars output; good for machines)+ * one that ignores indentation and newlines (ditto, only more so)++6. Numerous implementation tidy-ups+ Use of unboxed data types to speed up the implementation+
+ README.md view
@@ -0,0 +1,65 @@+# Pretty : A Haskell Pretty-printer library++[](https://hackage.haskell.org/package/pretty)+[](http://packdeps.haskellers.com/reverse/pretty)+[][tl;dr Legal: BSD3]+[](https://travis-ci.org/haskell/pretty)++[tl;dr Legal: BSD3]:+ https://tldrlegal.com/license/bsd-3-clause-license-(revised)+ "BSD3 License"++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' by John Hughes in Advanced Functional+Programming, 1995. It can be found+[here](http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.38.8777).++## Licensing++This library is BSD-licensed.++## Building++The library uses the Cabal build system, so building is simply a+matter of running:++```+cabal sandbox init+cabal install "QuickCheck >= 2.5 && < 3"+cabal install --only-dependencies+cabal configure --enable-tests+cabal build+cabal test+```++We have to install `QuickCheck` manually as otherwise Cabal currently+throws an error due to the cyclic dependency between `pretty` and+`QuickCheck`.++*If `cabal test` freezes*, then run+`cabal test --show-details=streaming` instead. This is due to a+[bug](https://github.com/haskell/cabal/issues/1810) in certain+versions of Cabal.++## Get involved!++We are happy to receive bug reports, fixes, documentation enhancements,+and other improvements.++Please report bugs via the+[github issue tracker](http://github.com/haskell/pretty/issues).++Master [git repository](http://github.com/haskell/pretty):++* `git clone git://github.com/haskell/pretty.git`++## Authors++This library is maintained by David Terei, <code@davidterei.com>. It+was originally designed by John Hughes's and since heavily modified by+Simon Peyton Jones.+
Setup.hs view
@@ -4,3 +4,4 @@ main :: IO () main = defaultMain+
− Text/PrettyPrint.hs
@@ -1,21 +0,0 @@--------------------------------------------------------------------------------- |--- Module : Text.PrettyPrint--- Copyright : (c) The University of Glasgow 2001--- License : BSD-style (see the file libraries/base/LICENSE)--- --- Maintainer : libraries@haskell.org--- Stability : experimental--- Portability : portable------ Re-export of "Text.PrettyPrint.HughesPJ" to provide a default--- pretty-printing library. Marked experimental at the moment; the --- default library might change at a later date.-----------------------------------------------------------------------------------module Text.PrettyPrint ( - module Text.PrettyPrint.HughesPJ- ) where--import Text.PrettyPrint.HughesPJ
− Text/PrettyPrint/HughesPJ.hs
@@ -1,1095 +0,0 @@--------------------------------------------------------------------------------- |--- Module : Text.PrettyPrint.HughesPJ--- Copyright : (c) The University of Glasgow 2001--- License : BSD-style (see the file libraries/base/LICENSE)--- --- Maintainer : libraries@haskell.org--- Stability : provisional--- Portability : portable------ John Hughes's and Simon Peyton Jones's Pretty Printer Combinators--- --- Based on /The Design of a Pretty-printing Library/--- in Advanced Functional Programming,--- Johan Jeuring and Erik Meijer (eds), LNCS 925--- <http://www.cs.chalmers.se/~rjmh/Papers/pretty.ps>------ Heavily modified by Simon Peyton Jones, Dec 96-----------------------------------------------------------------------------------{--Version 3.0 28 May 1997- * 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 insensivity 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 2.0 24 April 1997- * 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 occassionally gave very weird behaviour-- * Added $+$-- * Corrected and tidied up the laws and invariants--======================================================================-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 conposition- fcat behaves like fsep, but it uses <> for horizontal conposition-- 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--}--module Text.PrettyPrint.HughesPJ (-- -- * The document type- Doc, -- Abstract-- -- * Constructing documents- -- ** Converting values into documents- char, text, ptext, 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 Prelude--infixl 6 <> -infixl 6 <+>-infixl 5 $$, $+$---- ------------------------------------------------------------------------------ The interface---- The primitive Doc values--isEmpty :: Doc -> Bool; -- ^ Returns 'True' if the document is empty---- | 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--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---- | A document of height and width 1, containing a literal character.-char :: Char -> Doc---- | 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---- | An obsolete function, now identical to 'text'.-ptext :: String -> Doc---- | Some text, but without any width. Use for non-printing text--- such as a HTML or Latex tags-zeroWidthText :: String -> Doc--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)@--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 @\"...\"@---- Combining @Doc@ values---- | Beside.--- '<>' is associative, with identity 'empty'.-(<>) :: Doc -> Doc -> Doc---- | Beside, separated by space, unless one of the arguments is 'empty'.--- '<+>' is associative, with identity 'empty'.-(<+>) :: Doc -> Doc -> Doc---- | 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---- | Above, with no overlapping.--- '$+$' is associative, with identity 'empty'.-($+$) :: Doc -> Doc -> Doc--hcat :: [Doc] -> Doc; -- ^List version of '<>'.-hsep :: [Doc] -> Doc; -- ^List version of '<+>'.-vcat :: [Doc] -> Doc; -- ^List version of '$$'.--cat :: [Doc] -> Doc; -- ^ Either 'hcat' or 'vcat'.-sep :: [Doc] -> Doc; -- ^ Either 'hsep' or 'vcat'.-fcat :: [Doc] -> Doc; -- ^ \"Paragraph fill\" version of 'cat'.-fsep :: [Doc] -> Doc; -- ^ \"Paragraph fill\" version of 'sep'.---- | 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---- GHC-specific ones.---- | @hang d1 n d2 = sep [d1, nest n d2]@-hang :: Doc -> Int -> Doc -> Doc---- | @punctuate p [d1, ... dn] = [d1 \<> p, d2 \<> p, ... dn-1 \<> p, dn]@-punctuate :: Doc -> [Doc] -> [Doc]----- Displaying @Doc@ values. --instance Show Doc where- showsPrec _ doc cont = showDoc doc cont---- | Renders the document as a string using the default 'style'.-render :: Doc -> String---- | 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---- | Render the document as a string using a specified style.-renderStyle :: Style -> Doc -> String---- | 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---- ------------------------------------------------------------------------------ The Doc calculus---- The Doc combinators satisfy the following laws:--{--Laws for $$-~~~~~~~~~~~-<a1> (x $$ y) $$ z = x $$ (y $$ z)-<a2> empty $$ x = x-<a3> x $$ empty = x-- ...ditto $+$...--Laws for <>-~~~~~~~~~~~-<b1> (x <> y) <> z = x <> (y <> z)-<b2> empty <> x = empty-<b3> x <> empty = x-- ...ditto <+>...--Laws for text-~~~~~~~~~~~~~-<t1> text s <> text t = text (s++t)-<t2> text "" <> x = x, if x non-empty- -** because of law n6, t2 only holds if x doesn't-** start with `nest'.- --Laws for nest-~~~~~~~~~~~~~-<n1> nest 0 x = x-<n2> nest k (nest k' x) = nest (k+k') x-<n3> nest k (x <> y) = nest k x <> nest k y-<n4> nest k (x $$ y) = nest k x $$ nest k y-<n5> nest k empty = empty-<n6> x <> nest k y = x <> y, if x non-empty--** Note the side condition on <n6>! It is this that-** makes it OK for empty to be a left unit for <>.--Miscellaneous-~~~~~~~~~~~~~-<m1> (text s <> x) $$ y = text s <> ((text "" <> x) $$- nest (-length s) y) --<m2> (x $$ y) <> z = x $$ (y <> z)- if y non-empty---Laws for list versions-~~~~~~~~~~~~~~~~~~~~~~-<l1> sep (ps++[empty]++qs) = sep (ps ++ qs)- ...ditto hsep, hcat, vcat, fill...--<l2> nest k (sep ps) = sep (map (nest k) ps)- ...ditto hsep, hcat, vcat, fill...--Laws for oneLiner-~~~~~~~~~~~~~~~~~-<o1> oneLiner (nest k p) = nest k (oneLiner p)-<o2> oneLiner (x <> y) = oneLiner x <> oneLiner y --You might think that the following verion of <m1> would-be neater:--<3 NO> (text s <> x) $$ y = text s <> ((empty <> x)) $$ - nest (-length s) y)--But it doesn't work, for if x=empty, we would have-- text s $$ y = text s <> (empty $$ nest (-length s) y)- = text s <> nest (-length s) y--}---- ------------------------------------------------------------------------------ Simple derived definitions--semi = char ';'-colon = char ':'-comma = char ','-space = char ' '-equals = char '='-lparen = char '('-rparen = char ')'-lbrack = char '['-rbrack = char ']'-lbrace = char '{'-rbrace = char '}'--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)--- SIGBJORN wrote instead:--- rational n = text (show (fromRationalX n))--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 '}'---- lazy list versions-hcat = reduceAB . foldr (beside_' False) empty-hsep = reduceAB . foldr (beside_' True) empty-vcat = reduceAB . foldr (above_' False) empty--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--hang d1 n d2 = sep [d1, nest n d2]--punctuate _ [] = []-punctuate p (d:ds) = go d ds- where- go d' [] = [d']- go d' (e:es) = (d' <> p) : go e es---- ------------------------------------------------------------------------------ The Doc data type---- A Doc represents a *set* of layouts. A Doc with--- no occurrences of Union or NoDoc represents just one layout.---- | The abstract type of documents.--- The 'Show' instance is equivalent to using 'render'.-data Doc- = Empty -- empty- | NilAbove Doc -- text "" $$ x- | TextBeside TextDetails !Int Doc -- text s <> x - | Nest !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--type RDoc = Doc -- RDoc is a "reduced Doc", guaranteed not to have a top-level Above or Beside---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---data TextDetails = Chr Char- | Str String- | PStr String-space_text, nl_text :: TextDetails-space_text = Chr ' '-nl_text = Chr '\n'--{-- 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.--}---- Invariant: Args to the 4 functions below are always RDocs-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----- 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)----- ------------------------------------------------------------------------------ @empty@, @text@, @nest@, @union@--empty = Empty--isEmpty Empty = True-isEmpty _ = False--char c = textBeside_ (Chr c) 1 Empty-text s = case length s of {sl -> textBeside_ (Str s) sl Empty}-ptext s = case length s of {sl -> textBeside_ (PStr s) sl Empty}-zeroWidthText s = textBeside_ (Str s) 0 Empty--nest k p = mkNest k (reduceDoc p) -- Externally callable version---- 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 -- Worth a try!-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---- ------------------------------------------------------------------------------ Vertical composition @$$@--above_ :: Doc -> Bool -> Doc -> Doc-above_ p _ Empty = p-above_ Empty _ q = q-above_ p g q = Above p g q--p $$ q = above_ p False q-p $+$ q = above_ p True 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)--aboveNest :: RDoc -> Bool -> Int -> RDoc -> RDoc--- 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 = k1 `seq` 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 -> RDoc--- 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 (spaces k)) k q- | otherwise -- Put them really above- = nilAbove_ (mkNest k q)---- ------------------------------------------------------------------------------ Horizontal composition @<>@--beside_ :: Doc -> Bool -> Doc -> Doc-beside_ p _ Empty = p-beside_ Empty _ q = q-beside_ p g q = Beside p g q--p <> q = beside_ p False q-p <+> q = beside_ p True q--beside :: Doc -> Bool -> RDoc -> RDoc--- Specification: beside g p q = p <g> q- -beside NoDoc _ _ = NoDoc-beside (p1 `Union` p2) g q = (beside p1 g q) `union_` (beside p2 g q)-beside Empty _ q = q-beside (Nest k p) g q = nest_ k (beside p g q) -- p non-empty-beside p@(Beside p1 g1 q1) g2 q2 - {- (A `op1` B) `op2` C == A `op1` (B `op2` C) iff op1 == op2 - [ && (op1 == <> || op1 == <+>) ] -}- | g1 == g2 = beside p1 g1 (beside q1 g2 q2)- | otherwise = beside (reduceDoc p) g2 q2-beside p@(Above _ _ _) g q = beside (reduceDoc p) 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 -> RDoc--- Specification: text "" <> nilBeside g p --- = text "" <g> p--nilBeside _ Empty = Empty -- Hence the text "" in the spec-nilBeside g (Nest _ p) = nilBeside g p-nilBeside g p | g = textBeside_ space_text 1 p- | otherwise = p---- ------------------------------------------------------------------------------ Separate, @sep@, Hughes version---- Specification: sep ps = oneLiner (hsep ps)--- `union`--- vcat ps--sep = sepX True -- Separate with spaces-cat = sepX False -- Don't--sepX :: Bool -> [Doc] -> Doc-sepX _ [] = empty-sepX x (p:ps) = sep1 x (reduceDoc p) 0 ps----- Specification: sep1 g k ys = sep (x : map (nest k) ys)--- = oneLiner (x <g> nest k (hsep ys))--- `union` x $$ nest k (vcat ys)--sep1 :: Bool -> RDoc -> Int -> [Doc] -> RDoc-sep1 _ _ k _ | k `seq` False = undefined-sep1 _ NoDoc _ _ = NoDoc-sep1 g (p `Union` q) k ys = sep1 g p k ys- `union_`- (aboveNest q False k (reduceDoc (vcat ys)))--sep1 g Empty k ys = mkNest k (sepX g ys)-sep1 g (Nest n p) k ys = nest_ n (sep1 g p (k - n) ys)--sep1 _ (NilAbove p) k ys = nilAbove_ (aboveNest p False k (reduceDoc (vcat ys)))-sep1 g (TextBeside s sl p) k ys = textBeside_ s sl (sepNB g p (k - sl) ys)-sep1 _ (Above {}) _ _ = error "sep1 Above"-sep1 _ (Beside {}) _ _ = error "sep1 Beside"---- Specification: sepNB p k ys = sep1 (text "" <> p) k ys--- Called when we have already found some text in the first item--- We have to eat up nests--sepNB :: Bool -> Doc -> Int -> [Doc] -> Doc--sepNB g (Nest _ p) k ys = sepNB g p k ys -- Never triggered, because of invariant (2)--sepNB g Empty k ys = oneLiner (nilBeside g (reduceDoc rest))- `mkUnion` - nilAboveNest True k (reduceDoc (vcat ys))- where- rest | g = hsep ys- | otherwise = hcat ys--sepNB g p k ys = sep1 g p k ys---- ------------------------------------------------------------------------------ @fill@--fsep = fill True-fcat = fill False---- Specification:------ fill g docs = fillIndent 0 docs------ fillIndent k [] = []--- fillIndent k [p] = p--- fillIndent k (p1:p2:ps) =--- oneLiner p1 <g> fillIndent (k + length p1 + g ? 1 : 0) (remove_nests (oneLiner p2) : ps)--- `Union`--- (p1 $*$ nest (-k) (fillIndent 0 ps))------ $*$ is defined for layouts (not Docs) as--- layout1 $*$ layout2 | hasMoreThanOneLine layout1 = layout1 $$ layout2--- | otherwise = layout1 $+$ layout2--fill :: Bool -> [Doc] -> RDoc-fill _ [] = empty-fill g (p:ps) = fill1 g (reduceDoc p) 0 ps---fill1 :: Bool -> RDoc -> Int -> [Doc] -> Doc-fill1 _ _ k _ | k `seq` False = undefined-fill1 _ NoDoc _ _ = NoDoc-fill1 g (p `Union` q) k ys = fill1 g p k ys- `union_`- (aboveNest q False k (fill g ys))--fill1 g Empty k ys = mkNest k (fill g ys)-fill1 g (Nest n p) k ys = nest_ n (fill1 g p (k - n) ys)--fill1 g (NilAbove p) k ys = nilAbove_ (aboveNest p False k (fill g ys))-fill1 g (TextBeside s sl p) k ys = textBeside_ s sl (fillNB g p (k - sl) ys)-fill1 _ (Above {}) _ _ = error "fill1 Above"-fill1 _ (Beside {}) _ _ = error "fill1 Beside"--fillNB :: Bool -> Doc -> Int -> [Doc] -> Doc-fillNB _ _ k _ | k `seq` False = undefined-fillNB g (Nest _ p) k ys = fillNB g p k ys -- Never triggered, because of invariant (2)-fillNB _ Empty _ [] = Empty-fillNB g Empty k (Empty:ys) = fillNB g Empty k ys-fillNB g Empty k (y:ys) = fillNBE g k y ys-fillNB g p k ys = fill1 g p k ys--fillNBE :: Bool -> Int -> Doc -> [Doc] -> Doc-fillNBE g k y ys = nilBeside g (fill1 g ((elideNest . oneLiner . reduceDoc) y) k1 ys)- `mkUnion` - nilAboveNest True k (fill g (y:ys))- where- k1 | g = k - 1- | otherwise = k--elideNest :: Doc -> Doc-elideNest (Nest _ d) = d-elideNest d = d---- ------------------------------------------------------------------------------ Selecting the best layout--best :: Mode- -> Int -- Line length- -> Int -- Ribbon length- -> RDoc- -> RDoc -- No unions in here!--best OneLineMode _ _ p0- = get p0 -- unused, due to the use of easy_display in full_render- where- get Empty = Empty- get NoDoc = NoDoc- get (NilAbove p) = nilAbove_ (get p)- get (TextBeside s sl p) = textBeside_ s sl (get p)- get (Nest _ p) = get p -- Elide nest- get (p `Union` q) = first (get p) (get q)- get (Above {}) = error "best OneLineMode get Above"- get (Beside {}) = error "best OneLineMode get Beside"--best _ w0 r p0- = get w0 p0- where- get :: Int -- (Remaining) width of line- -> Doc -> Doc- 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 :: Int -- (Remaining) width of line- -> Int -- Amount of first line already eaten up- -> Doc -- This is an argument to TextBeside => eat Nests- -> Doc -- No unions in here!-- 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 `minn` 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"--minn :: Int -> Int -> Int-minn x y | x < y = x- | otherwise = y---- @first@ and @nonEmptySet@ are similar to @nicest@ and @fits@, only simpler.--- @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 -- NoDoc always in first line-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 @Doc@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"----- ------------------------------------------------------------------------------ Displaying the best layout--renderStyle the_style doc- = fullRender (mode the_style)- (lineLength the_style)- (ribbonsPerLine the_style)- string_txt- ""- doc--render doc = showDoc doc ""--showDoc :: Doc -> String -> String-showDoc doc rest = fullRender PageMode 100 1.5 string_txt rest doc--string_txt :: TextDetails -> String -> String-string_txt (Chr c) s = c:s-string_txt (Str s1) s2 = s1 ++ s2-string_txt (PStr s1) s2 = s1 ++ s2---fullRender OneLineMode _ _ txt end doc = easy_display space_text txt end (reduceDoc doc)-fullRender LeftMode _ _ txt end doc = easy_display nl_text txt end (reduceDoc doc)--fullRender the_mode line_length ribbons_per_line txt end doc- = display the_mode line_length ribbon_length txt end best_doc- where - best_doc = best the_mode hacked_line_length ribbon_length (reduceDoc doc)-- hacked_line_length, ribbon_length :: Int- ribbon_length = round (fromIntegral line_length / ribbons_per_line)- hacked_line_length = case the_mode of- ZigZagMode -> maxBound- _ -> line_length--display :: Mode -> Int -> Int -> (TextDetails -> a -> a) -> a -> Doc -> a-display the_mode 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 _ (Above {}) = error "display lay Above"- lay _ (Beside {}) = error "display lay Beside"- lay _ NoDoc = error "display lay NoDoc"- lay _ (Union {}) = error "display lay Union"- - lay k (NilAbove p) = nl_text `txt` lay k p- - lay k (TextBeside s sl p)- = case the_mode of- ZigZagMode | k >= gap_width- -> nl_text `txt` (- Str (multi_ch shift '/') `txt` (- nl_text `txt` (- lay1 (k - shift) s sl p)))-- | k < 0- -> nl_text `txt` (- Str (multi_ch shift '\\') `txt` (- nl_text `txt` (- lay1 (k + shift) s sl p )))-- _ -> lay1 k s sl p- - lay1 k _ sl _ | k+sl `seq` False = undefined- lay1 k s sl p = Str (indent k) `txt` (s `txt` lay2 (k + sl) 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- }}--cant_fail :: a-cant_fail = error "easy_display: NoDoc"--easy_display :: TextDetails -> (TextDetails -> a -> a) -> a -> Doc -> a-easy_display nl_space_text txt end doc - = lay doc cant_fail- where- lay NoDoc no_doc = no_doc- lay (Union _p q) _ = {- lay p -} (lay q cant_fail) -- Second arg can't be NoDoc- lay (Nest _ p) no_doc = lay p no_doc- lay Empty _ = end- lay (NilAbove p) _ = nl_space_text `txt` lay p cant_fail -- NoDoc always on first line- lay (TextBeside s _ p) no_doc = s `txt` lay p no_doc- lay (Above {}) _ = error "easy_display Above"- lay (Beside {}) _ = error "easy_display Beside"---- OLD version: we shouldn't rely on tabs being 8 columns apart in the output.--- indent n | n >= 8 = '\t' : indent (n - 8)--- | otherwise = spaces n-indent :: Int -> String-indent n = spaces n--multi_ch :: Int -> Char -> String-multi_ch 0 _ = ""-multi_ch n ch = ch : multi_ch (n - 1) ch---- (spaces n) generates a list of n spaces------ returns the empty string on negative argument.----spaces :: Int -> String-spaces n- {-- | n < 0 = trace "Warning: negative indentation" ""- -}- | n <= 0 = ""- | otherwise = ' ' : spaces (n - 1)--{--Q: What is the reason for negative indentation (i.e. argument to indent- is < 0) ?--A:-This indicates an error in the library client's code.-If we compose a <> b, and the first line of b is more indented than some-other lines of b, the law <n6> (<> eats nests) may cause the pretty-printer to produce an invalid layout:--doc |0123345--------------------d1 |a...|-d2 |...b|- |c...|--d1<>d2 |ab..|- c|....|--Consider a <> b, let `s' be the length of the last line of `a', `k' the-indentation of the first line of b, and `k0' the indentation of the-left-most line b_i of b.--The produced layout will have negative indentation if `k - k0 > s', as-the first line of b will be put on the (s+1)th column, effectively-translating b horizontally by (k-s). Now if the i^th line of b has an-indentation k0 < (k-s), it is translated out-of-page, causing-`negative indentation'.--}-
+ bench/Bench.hs view
@@ -0,0 +1,75 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE PackageImports #-}+module Main where++import Criterion.Main+import Data.List+import Text.PrettyPrint.HughesPJ++--------------------------------------------------------------------------------+f_left :: Int -> Doc+f_left n = foldl' (<>) empty (map (text . show) [10001..10000+n])++--------------------------------------------------------------------------------+f_right :: Int -> Doc+f_right n = foldr (<>) empty (map (text . show) [10001..10000+n])++--------------------------------------------------------------------------------+stuff :: String -> String -> Double -> Rational -> Int -> Int -> Int -> Doc+stuff s1 s2 d1 r1 i1 i2 i3 =+ let a = nest i1 $ text s1+ b = double d1+ c = rational r1+ d = replicate i1 (text s2 <> b <> c <+> a)+ e = cat d $+$ cat d $$ (c <> b <+> a)+ f = parens e <> brackets c <> hcat d+ g = lparen <> f <> rparen+ h = text $ s2 ++ s1+ i = map rational ([1..(toRational i2)]::[Rational])+ j = punctuate comma i+ k = nest i3 h <> (nest (i1 + i3) $ sep i) $+$ g <> cat j+ l = cat $ punctuate (comma <> b <> comma) $ replicate i3 k+ in l++--------------------------------------------------------------------------------+doc1 :: Doc+doc1 = stuff "Adsas ads" "dassdab weeaa xxxxx" 123.231321 ((-1)/5) 30 300 20++--------------------------------------------------------------------------------+doc2 :: Doc+doc2 = stuff "aDSAS ADS asdasdsa sdsda xx" "SDAB WEEAA" 1333.212 ((-4)/5) 31 301 30++--------------------------------------------------------------------------------+doc3 :: Doc+doc3 = stuff "ADsAs --____ aDS" "DasSdAB weEAA" 2533.21299 ((-4)/999) 39 399 60++--------------------------------------------------------------------------------+processTxt :: TextDetails -> String -> String+processTxt (Chr c) s = c:s+processTxt (Str s1) s2 = s1 ++ s2+processTxt (PStr s1) s2 = s1 ++ s2++--------------------------------------------------------------------------------+main :: IO ()+main = defaultMain $ [+ bgroup "<> associativity" [ bench "left" $ nf (length . render . f_left) 10000+ , bench "right" $ nf (length . render . f_right) 10000+ , bench "left20k" $ nf (length . render . f_left) 20000+ , bench "right20k" $ nf (length . render . f_right) 20000+ , bench "left30k" $ nf (length . render . f_left) 30000+ , bench "right30k" $ nf (length . render . f_right) 30000+ ]++ , bgroup "render" [ bench "doc1" $ nf render doc1+ , bench "doc2" $ nf render doc2+ , bench "doc3" $ nf render doc3+ ]++ , bgroup "fullRender" [ bench "PageMode 1000" $ nf (fullRender PageMode 1000 4 processTxt "") doc2+ , bench "PageMode 100" $ nf (fullRender PageMode 100 1.5 processTxt "") doc2+ , bench "ZigZagMode" $ nf (fullRender ZigZagMode 1000 4 processTxt "") doc2+ , bench "LeftMode" $ nf (fullRender LeftMode 1000 4 processTxt "") doc2+ , bench "OneLineMode" $ nf (fullRender OneLineMode 1000 4 processTxt "") doc3+ ]+ ]
pretty.cabal view
@@ -1,24 +1,79 @@-name: pretty-version: 1.0.1.2-license: BSD3-license-file: LICENSE-maintainer: libraries@haskell.org-bug-reports: http://hackage.haskell.org/trac/ghc/newticket?component=libraries/pretty-synopsis: Pretty-printing library-category: Text+name: pretty+version: 1.1.3.6+synopsis: Pretty-printing library description:- This package contains John Hughes's pretty-printing library,- heavily modified by Simon Peyton Jones.-build-type: Simple-Cabal-Version: >= 1.6+ This package contains 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.+ .+ This library was originally designed by John Hughes's and has since+ been heavily modified by Simon Peyton Jones. +license: BSD3+license-file: LICENSE+category: Text+maintainer: David Terei <code@davidterei.com>+homepage: http://github.com/haskell/pretty+bug-reports: http://github.com/haskell/pretty/issues+stability: Stable+build-type: Simple+Extra-Source-Files: README.md CHANGELOG.md+Cabal-Version: >= 1.8++source-repository this+ type: git+ location: http://github.com/haskell/pretty.git+ tag: 1.1.3.5++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+ Text.PrettyPrint.HughesPJClass+ Text.PrettyPrint.Annotated+ Text.PrettyPrint.Annotated.HughesPJ+ Text.PrettyPrint.Annotated.HughesPJClass+ build-depends: base >= 4.5 && < 5,+ deepseq >= 1.1,+ ghc-prim+ extensions: CPP, BangPatterns, DeriveGeneric+ ghc-options: -Wall -fwarn-tabs -source-repository head- type: darcs- location: http://darcs.haskell.org/packages/pretty/+Test-Suite test-pretty+ type: exitcode-stdio-1.0+ hs-source-dirs: tests+ src+ build-depends: base >= 4.5 && < 5,+ deepseq >= 1.1,+ ghc-prim,+ QuickCheck >= 2.5 && <3+ main-is: Test.hs+ other-modules:+ Text.PrettyPrint.Annotated.HughesPJ+ Text.PrettyPrint.HughesPJ+ PrettyTestVersion+ TestGenerators+ TestStructures+ TestUtils+ UnitLargeDoc+ UnitPP1+ UnitT3911+ UnitT32+ extensions: CPP, BangPatterns, DeriveGeneric+ include-dirs: src/Text/PrettyPrint/Annotated+ ghc-options: -rtsopts -with-rtsopts=-K2M +benchmark pretty-bench+ type: exitcode-stdio-1.0+ main-is: Bench.hs+ hs-source-dirs: bench+ ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -O2 -threaded -rtsopts -with-rtsopts=-N1 -with-rtsopts=-s -with-rtsopts=-qg+ build-depends: base >= 4.5 && < 5+ , criterion+ , pretty
+ src/Text/PrettyPrint.hs view
@@ -0,0 +1,71 @@+#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 <code@davidterei.com>+-- Stability : stable+-- Portability : portable+--+-- Provides a collection of pretty printer combinators, a set of API's+-- that provides a way to easily print out text in a consistent format+-- of your choosing.+--+-- 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,+ (X.<>), (<+>), 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 as X+
+ src/Text/PrettyPrint/Annotated.hs view
@@ -0,0 +1,78 @@+#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE Safe #-}+#endif+-----------------------------------------------------------------------------+-- |+-- Module : Text.PrettyPrint.Annotated+-- Copyright : (c) Trevor Elliott <revor@galois.com> 2015+-- License : BSD-style (see the file LICENSE)+-- +-- Maintainer : David Terei <code@davidterei.com>+-- Stability : stable+-- Portability : portable+--+-- This module provides a version of pretty that allows for annotations to be+-- attached to documents. Annotations are arbitrary pieces of metadata that can+-- be attached to sub-documents.+--+-- This module should be used as opposed to the+-- 'Text.PrettyPrint.Annotated.HughesPJ' module. Both are equivalent though as+-- this module simply re-exports the other.+--+-----------------------------------------------------------------------------++module Text.PrettyPrint.Annotated ( ++ -- * 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,+ (X.<>), (<+>), hcat, hsep,+ ($$), ($+$), vcat,+ sep, cat,+ fsep, fcat,+ nest,+ hang, punctuate,++ -- ** Annotating documents+ annotate,++ -- * Predicates on documents+ isEmpty,++ -- * Rendering documents++ -- ** Default rendering+ render,++ -- ** Annotation rendering+ renderSpans, Span(..),++ -- ** Rendering with a particular style+ Style(..),+ style,+ renderStyle,++ -- ** General rendering+ fullRender,+ fullRenderAnn,+ Mode(..), TextDetails(..)++ ) where++import Text.PrettyPrint.Annotated.HughesPJ as X+
+ src/Text/PrettyPrint/Annotated/HughesPJ.hs view
@@ -0,0 +1,1194 @@+{-# OPTIONS_HADDOCK not-home #-}+{-# LANGUAGE BangPatterns #-}+#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE Safe #-}+{-# LANGUAGE DeriveGeneric #-}+#endif++-----------------------------------------------------------------------------+-- |+-- Module : Text.PrettyPrint.Annotated.HughesPJ+-- Copyright : (c) Trevor Elliott <revor@galois.com> 2015+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : David Terei <code@davidterei.com>+-- Stability : stable+-- Portability : portable+--+-- This module provides a version of pretty that allows for annotations to be+-- attached to documents. Annotations are arbitrary pieces of metadata that can+-- be attached to sub-documents.+--+-----------------------------------------------------------------------------++#ifndef TESTING+module Text.PrettyPrint.Annotated.HughesPJ (++ -- * The document type+ Doc, TextDetails(..), AnnotDetails(..),++ -- * 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,+ maybeParens, maybeBrackets, maybeBraces, maybeQuotes, maybeDoubleQuotes,++ -- ** Combining documents+ empty,+ (<>), (<+>), hcat, hsep,+ ($$), ($+$), vcat,+ sep, cat,+ fsep, fcat,+ nest,+ hang, punctuate,++ -- ** Annotating documents+ annotate,++ -- * Predicates on documents+ isEmpty,++ -- * Utility functions for documents+ first, reduceDoc,++ -- * Rendering documents++ -- ** Default rendering+ render,++ -- ** Annotation rendering+ renderSpans, Span(..),+ renderDecorated,+ renderDecoratedM,++ -- ** Rendering with a particular style+ Style(..),+ style,+ renderStyle,+ Mode(..),++ -- ** General rendering+ fullRender,+ fullRenderAnn++ ) where+#endif++import Control.DeepSeq ( NFData(rnf) )+import Data.Function ( on )+#if __GLASGOW_HASKELL__ >= 803+import Prelude hiding ( (<>) )+#endif+#if __GLASGOW_HASKELL__ >= 800+import qualified Data.Semigroup as Semi ( Semigroup((<>)) )+#elif __GLASGOW_HASKELL__ < 709+import Data.Monoid ( Monoid(mempty, mappend) )+#endif+import Data.String ( IsString(fromString) )++import GHC.Generics++-- ---------------------------------------------------------------------------+-- The Doc calculus++{-+Laws for $$+~~~~~~~~~~~+<a1> (x $$ y) $$ z = x $$ (y $$ z)+<a2> empty $$ x = x+<a3> x $$ empty = x++ ...ditto $+$...++Laws for <>+~~~~~~~~~~~+<b1> (x <> y) <> z = x <> (y <> z)+<b2> empty <> x = empty+<b3> x <> empty = x++ ...ditto <+>...++Laws for text+~~~~~~~~~~~~~+<t1> text s <> text t = text (s++t)+<t2> text "" <> x = x, if x non-empty++** because of law n6, t2 only holds if x doesn't+** start with `nest'.+++Laws for nest+~~~~~~~~~~~~~+<n1> nest 0 x = x+<n2> nest k (nest k' x) = nest (k+k') x+<n3> nest k (x <> y) = nest k x <> nest k y+<n4> nest k (x $$ y) = nest k x $$ nest k y+<n5> nest k empty = empty+<n6> x <> nest k y = x <> y, if x non-empty++** Note the side condition on <n6>! It is this that+** makes it OK for empty to be a left unit for <>.++Miscellaneous+~~~~~~~~~~~~~+<m1> (text s <> x) $$ y = text s <> ((text "" <> x) $$+ nest (-length s) y)++<m2> (x $$ y) <> z = x $$ (y <> z)+ if y non-empty+++Laws for list versions+~~~~~~~~~~~~~~~~~~~~~~+<l1> sep (ps++[empty]++qs) = sep (ps ++ qs)+ ...ditto hsep, hcat, vcat, fill...++<l2> nest k (sep ps) = sep (map (nest k) ps)+ ...ditto hsep, hcat, vcat, fill...++Laws for oneLiner+~~~~~~~~~~~~~~~~~+<o1> oneLiner (nest k p) = nest k (oneLiner p)+<o2> oneLiner (x <> y) = oneLiner x <> oneLiner y++You might think that the following verion of <m1> would+be neater:++<3 NO> (text s <> x) $$ y = text s <> ((empty <> x)) $$+ nest (-length s) y)++But it doesn't work, for if x=empty, we would have++ text s $$ y = text s <> (empty $$ nest (-length s) y)+ = text s <> nest (-length s) y+-}++-- ---------------------------------------------------------------------------+-- Operator fixity++infixl 6 <>+infixl 6 <+>+infixl 5 $$, $+$++-- ---------------------------------------------------------------------------+-- The Doc data type++-- | The abstract type of documents. A Doc represents a /set/ of layouts. A Doc+-- with no occurrences of Union or NoDoc represents just one layout.+data Doc a+ = Empty -- ^ An empty span, see 'empty'.+ | NilAbove (Doc a) -- ^ @text "" $$ x@.+ | TextBeside !(AnnotDetails a) (Doc a) -- ^ @text s <> x@.+ | Nest {-# UNPACK #-} !Int (Doc a) -- ^ @nest k x@.+ | Union (Doc a) (Doc a) -- ^ @ul `union` ur@.+ | NoDoc -- ^ The empty set of documents.+ | Beside (Doc a) Bool (Doc a) -- ^ True <=> space between.+ | Above (Doc a) Bool (Doc a) -- ^ True <=> never overlap.+#if __GLASGOW_HASKELL__ >= 701+ deriving (Generic)+#endif++{-+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++-- | An annotation (side-metadata) attached at a particular point in a @Doc@.+-- Allows carrying non-pretty-printed data around in a @Doc@ that is attached+-- at particular points in the structure. Once the @Doc@ is render to an output+-- type (such as 'String'), we can also retrieve where in the rendered document+-- our annotations start and end (see 'Span' and 'renderSpans').+data AnnotDetails a = AnnotStart+ | NoAnnot !TextDetails {-# UNPACK #-} !Int+ | AnnotEnd a+ deriving (Show,Eq)++instance Functor AnnotDetails where+ fmap _ AnnotStart = AnnotStart+ fmap _ (NoAnnot d i) = NoAnnot d i+ fmap f (AnnotEnd a) = AnnotEnd (f a)++-- NOTE: Annotations are assumed to have zero length; only text has a length.+annotSize :: AnnotDetails a -> Int+annotSize (NoAnnot _ l) = l+annotSize _ = 0++-- | A TextDetails represents a fragment of text that will be output at some+-- point in a @Doc@.+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.+#if __GLASGOW_HASKELL__ >= 701+ deriving (Show, Eq, Generic)+#endif++-- Combining @Doc@ values+#if __GLASGOW_HASKELL__ >= 800+instance Semi.Semigroup (Doc a) where+#ifndef TESTING+ (<>) = (Text.PrettyPrint.Annotated.HughesPJ.<>)+#else+ (<>) = (PrettyTestVersion.<>)+#endif++instance Monoid (Doc a) where+ mempty = empty+ mappend = (Semi.<>)+#else+instance Monoid (Doc a) where+ mempty = empty+ mappend = (<>)+#endif++instance IsString (Doc a) where+ fromString = text++instance Show (Doc a) where+ showsPrec _ doc cont = fullRender (mode style) (lineLength style)+ (ribbonsPerLine style)+ txtPrinter cont doc++instance Eq (Doc a) where+ (==) = (==) `on` render++instance Functor Doc where+ fmap _ Empty = Empty+ fmap f (NilAbove d) = NilAbove (fmap f d)+ fmap f (TextBeside td d) = TextBeside (fmap f td) (fmap f d)+ fmap f (Nest k d) = Nest k (fmap f d)+ fmap f (Union ur ul) = Union (fmap f ur) (fmap f ul)+ fmap _ NoDoc = NoDoc+ fmap f (Beside ld s rd) = Beside (fmap f ld) s (fmap f rd)+ fmap f (Above ud s ld) = Above (fmap f ud) s (fmap f ld)++instance NFData a => NFData (Doc a) where+ rnf Empty = ()+ rnf (NilAbove d) = rnf d+ rnf (TextBeside td d) = rnf td `seq` rnf d+ rnf (Nest k d) = rnf k `seq` rnf d+ rnf (Union ur ul) = rnf ur `seq` rnf ul+ rnf NoDoc = ()+ rnf (Beside ld s rd) = rnf ld `seq` rnf s `seq` rnf rd+ rnf (Above ud s ld) = rnf ud `seq` rnf s `seq` rnf ld++instance NFData a => NFData (AnnotDetails a) where+ rnf AnnotStart = ()+ rnf (NoAnnot d sl) = rnf d `seq` rnf sl+ rnf (AnnotEnd a) = rnf a++instance NFData TextDetails where+ rnf (Chr c) = rnf c+ rnf (Str str) = rnf str+ rnf (PStr str) = rnf str++-- ---------------------------------------------------------------------------+-- Values and Predicates on GDocs and TextDetails++-- | Attach an annotation to a document.+annotate :: a -> Doc a -> Doc a+annotate a d = TextBeside AnnotStart+ $ beside (reduceDoc d) False+ $ TextBeside (AnnotEnd a) Empty+++-- | A document of height and width 1, containing a literal character.+char :: Char -> Doc a+char c = textBeside_ (NoAnnot (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 a+text s = case length s of {sl -> textBeside_ (NoAnnot (Str s) sl) Empty}++-- | Same as @text@. Used to be used for Bytestrings.+ptext :: String -> Doc a+ptext s = case length s of {sl -> textBeside_ (NoAnnot (PStr s) sl) Empty}++-- | Some text with any width. (@text s = sizedText (length s) s@)+sizedText :: Int -> String -> Doc a+sizedText l s = textBeside_ (NoAnnot (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 a+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 a+empty = Empty++-- | Returns 'True' if the document is empty+isEmpty :: Doc a -> Bool+isEmpty Empty = True+isEmpty _ = False++-- | Produce spacing for indenting the amount specified.+--+-- an old version inserted tabs being 8 columns apart in the output.+indent :: Int -> String+indent !n = replicate n ' '++{-+Q: What is the reason for negative indentation (i.e. argument to indent+ is < 0) ?++A:+This indicates an error in the library client's code.+If we compose a <> b, and the first line of b is more indented than some+other lines of b, the law <n6> (<> eats nests) may cause the pretty+printer to produce an invalid layout:++doc |0123345+------------------+d1 |a...|+d2 |...b|+ |c...|++d1<>d2 |ab..|+ c|....|++Consider a <> b, let `s' be the length of the last line of `a', `k' the+indentation of the first line of b, and `k0' the indentation of the+left-most line b_i of b.++The produced layout will have negative indentation if `k - k0 > s', as+the first line of b will be put on the (s+1)th column, effectively+translating b horizontally by (k-s). Now if the i^th line of b has an+indentation k0 < (k-s), it is translated out-of-page, causing+`negative indentation'.+-}+++semi :: Doc a -- ^ A ';' character+comma :: Doc a -- ^ A ',' character+colon :: Doc a -- ^ A ':' character+space :: Doc a -- ^ A space character+equals :: Doc a -- ^ A '=' character+lparen :: Doc a -- ^ A '(' character+rparen :: Doc a -- ^ A ')' character+lbrack :: Doc a -- ^ A '[' character+rbrack :: Doc a -- ^ A ']' character+lbrace :: Doc a -- ^ A '{' character+rbrace :: Doc a -- ^ A '}' character+semi = char ';'+comma = char ','+colon = char ':'+space = char ' '+equals = char '='+lparen = char '('+rparen = char ')'+lbrack = char '['+rbrack = char ']'+lbrace = char '{'+rbrace = char '}'++spaceText, nlText :: AnnotDetails a+spaceText = NoAnnot (Chr ' ') 1+nlText = NoAnnot (Chr '\n') 1++int :: Int -> Doc a -- ^ @int n = text (show n)@+integer :: Integer -> Doc a -- ^ @integer n = text (show n)@+float :: Float -> Doc a -- ^ @float n = text (show n)@+double :: Double -> Doc a -- ^ @double n = text (show n)@+rational :: Rational -> Doc a -- ^ @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 a -> Doc a -- ^ Wrap document in @(...)@+brackets :: Doc a -> Doc a -- ^ Wrap document in @[...]@+braces :: Doc a -> Doc a -- ^ Wrap document in @{...}@+quotes :: Doc a -> Doc a -- ^ Wrap document in @\'...\'@+doubleQuotes :: Doc a -> Doc a -- ^ 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 '}'++-- | Apply 'parens' to 'Doc' if boolean is true.+maybeParens :: Bool -> Doc a -> Doc a+maybeParens False = id+maybeParens True = parens++-- | Apply 'brackets' to 'Doc' if boolean is true.+maybeBrackets :: Bool -> Doc a -> Doc a+maybeBrackets False = id+maybeBrackets True = brackets++-- | Apply 'braces' to 'Doc' if boolean is true.+maybeBraces :: Bool -> Doc a -> Doc a+maybeBraces False = id+maybeBraces True = braces++-- | Apply 'quotes' to 'Doc' if boolean is true.+maybeQuotes :: Bool -> Doc a -> Doc a+maybeQuotes False = id+maybeQuotes True = quotes++-- | Apply 'doubleQuotes' to 'Doc' if boolean is true.+maybeDoubleQuotes :: Bool -> Doc a -> Doc a+maybeDoubleQuotes False = id+maybeDoubleQuotes True = doubleQuotes++-- ---------------------------------------------------------------------------+-- Structural operations on GDocs++-- | Perform some simplification of a built up @GDoc@.+reduceDoc :: Doc a -> 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 a] -> Doc a+hcat = snd . reduceHoriz . foldr (\p q -> Beside p False q) empty++-- | List version of '<+>'.+hsep :: [Doc a] -> Doc a+hsep = snd . reduceHoriz . foldr (\p q -> Beside p True q) empty++-- | List version of '$$'.+vcat :: [Doc a] -> Doc a+vcat = snd . reduceVert . foldr (\p q -> Above p False q) 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 a -> Doc a+nest k p = mkNest k (reduceDoc p)++-- | @hang d1 n d2 = sep [d1, nest n d2]@+hang :: Doc a -> Int -> Doc a -> Doc a+hang d1 n d2 = sep [d1, nest n d2]++-- | @punctuate p [d1, ... dn] = [d1 \<> p, d2 \<> p, ... dn-1 \<> p, dn]@+punctuate :: Doc a -> [Doc a] -> [Doc a]+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 a -> Doc a+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 a -> Doc a -> Doc a+mkUnion Empty _ = Empty+mkUnion p q = p `union_` q++data IsEmpty = IsEmpty | NotEmpty++reduceHoriz :: Doc a -> (IsEmpty, Doc a)+reduceHoriz (Beside p g q) = eliminateEmpty Beside (snd (reduceHoriz p)) g (reduceHoriz q)+reduceHoriz doc = (NotEmpty, doc)++reduceVert :: Doc a -> (IsEmpty, Doc a)+reduceVert (Above p g q) = eliminateEmpty Above (snd (reduceVert p)) g (reduceVert q)+reduceVert doc = (NotEmpty, doc)++{-# INLINE eliminateEmpty #-}+eliminateEmpty ::+ (Doc a -> Bool -> Doc a -> Doc a) ->+ Doc a -> Bool -> (IsEmpty, Doc a) -> (IsEmpty, Doc a)+eliminateEmpty _ Empty _ q = q+eliminateEmpty cons p g q =+ (NotEmpty,+ -- We're not empty whether or not q is empty, so for laziness-sake,+ -- after checking that p isn't empty, we put the NotEmpty result+ -- outside independent of q. This allows reduceAB to immediately+ -- return the appropriate constructor (Above or Beside) without+ -- forcing the entire nested Doc. This allows the foldr in vcat,+ -- hsep, and hcat to be lazy on its second argument, avoiding a+ -- stack overflow.+ case q of+ (NotEmpty, q') -> cons p g q'+ (IsEmpty, _) -> p)++nilAbove_ :: RDoc a -> RDoc a+nilAbove_ = NilAbove++-- | Arg of a TextBeside is always an RDoc.+textBeside_ :: AnnotDetails a -> RDoc a -> RDoc a+textBeside_ = TextBeside++nest_ :: Int -> RDoc a -> RDoc a+nest_ = Nest++union_ :: RDoc a -> RDoc a -> RDoc a+union_ = Union+++-- ---------------------------------------------------------------------------+-- 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 a -> Doc a -> Doc a+p $$ q = above_ p False q++-- | Above, with no overlapping.+-- '$+$' is associative, with identity 'empty'.+($+$) :: Doc a -> Doc a -> Doc a+p $+$ q = above_ p True q++above_ :: Doc a -> Bool -> Doc a -> Doc a+above_ p _ Empty = p+above_ Empty _ q = q+above_ p g q = Above p g q++above :: Doc a -> 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)++-- Specfication: aboveNest p g k q = p $g$ (nest k q)+aboveNest :: RDoc a -> Bool -> Int -> RDoc a -> RDoc a+aboveNest _ _ k _ | k `seq` False = undefined+aboveNest NoDoc _ _ _ = NoDoc+aboveNest (p1 `Union` p2) g k q = aboveNest p1 g k q `union_`+ aboveNest 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 p) g k q = TextBeside s rest+ where+ !k1 = k - annotSize s+ 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 a -> RDoc a+nilAboveNest _ k _ | k `seq` False = undefined+nilAboveNest _ _ Empty = Empty+ -- Here's why the "text s <>" is in the spec!+nilAboveNest g k (Nest k1 q) = nilAboveNest g (k + k1) q+nilAboveNest g k q | not g && k > 0 -- No newline if no overlap+ = textBeside_ (NoAnnot (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 a -> Doc a -> Doc a+p <> q = beside_ p False q++-- | Beside, separated by space, unless one of the arguments is 'empty'.+-- '<+>' is associative, with identity 'empty'.+(<+>) :: Doc a -> Doc a -> Doc a+p <+> q = beside_ p True q++beside_ :: Doc a -> Bool -> Doc a -> Doc a+beside_ p _ Empty = p+beside_ Empty _ q = q+beside_ p g q = Beside p g q++-- Specification: beside g p q = p <g> q+beside :: Doc a -> Bool -> RDoc a -> RDoc a+beside NoDoc _ _ = NoDoc+beside (p1 `Union` p2) g q = beside p1 g q `union_` beside p2 g q+beside Empty _ q = q+beside (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 t p) g q = TextBeside t rest+ where+ rest = case p of+ Empty -> nilBeside g q+ _ -> beside p g q++-- Specification: text "" <> nilBeside g p+-- = text "" <g> p+nilBeside :: Bool -> RDoc a -> RDoc a+nilBeside _ Empty = Empty -- Hence the text "" in the spec+nilBeside g (Nest _ p) = nilBeside g p+nilBeside g p | g = textBeside_ spaceText p+ | otherwise = p+++-- ---------------------------------------------------------------------------+-- Separate, @sep@++-- Specification: sep ps = oneLiner (hsep ps)+-- `union`+-- vcat ps++-- | Either 'hsep' or 'vcat'.+sep :: [Doc a] -> Doc a+sep = sepX True -- Separate with spaces++-- | Either 'hcat' or 'vcat'.+cat :: [Doc a] -> Doc a+cat = sepX False -- Don't++sepX :: Bool -> [Doc a] -> Doc a+sepX _ [] = empty+sepX x (p:ps) = sep1 x (reduceDoc p) 0 ps+++-- Specification: sep1 g k ys = sep (x : map (nest k) ys)+-- = oneLiner (x <g> nest k (hsep ys))+-- `union` x $$ nest k (vcat ys)+sep1 :: Bool -> RDoc a -> Int -> [Doc a] -> 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 p) k ys = textBeside_ s (sepNB g p (k - annotSize s) 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 a -> Int -> [Doc a] -> Doc a+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 a] -> Doc a+fcat = fill False++-- | \"Paragraph fill\" version of 'sep'.+fsep :: [Doc a] -> Doc a+fsep = fill True++-- Specification:+--+-- fill g docs = fillIndent 0 docs+--+-- fillIndent k [] = []+-- fillIndent k [p] = p+-- fillIndent k (p1:p2:ps) =+-- oneLiner p1 <g> fillIndent (k + length p1 + g ? 1 : 0)+-- (remove_nests (oneLiner p2) : ps)+-- `Union`+-- (p1 $*$ nest (-k) (fillIndent 0 ps))+--+-- $*$ is defined for layouts (not Docs) as+-- layout1 $*$ layout2 | hasMoreThanOneLine layout1 = layout1 $$ layout2+-- | otherwise = layout1 $+$ layout2++fill :: Bool -> [Doc a] -> RDoc a+fill _ [] = empty+fill g (p:ps) = fill1 g (reduceDoc p) 0 ps++fill1 :: Bool -> RDoc a -> Int -> [Doc a] -> Doc a+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 p) k ys = textBeside_ s (fillNB g p (k - annotSize s) ys)+fill1 _ (Above {}) _ _ = error "fill1 Above"+fill1 _ (Beside {}) _ _ = error "fill1 Beside"++fillNB :: Bool -> Doc a -> Int -> [Doc a] -> Doc a+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 a -> [Doc a] -> Doc a+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 a -> Doc a+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 = get w0+ 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 p) = textBeside_ s (get1 w (annotSize s) 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 s p) = textBeside_ s (get1 w (sl + annotSize s) 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 a -> Doc a -> Doc a+nicest !w !r = nicest1 w r 0++nicest1 :: Int -> Int -> Int -> Doc a -> Doc a -> Doc a+nicest1 !w !r !sl p q | fits ((w `min` r) - sl) p = p+ | otherwise = q++fits :: Int -- Space available+ -> Doc a+ -> 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 s p) = fits (n - annotSize s) 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 a -> Doc a -> Doc a+first p q | nonEmptySet p = p -- unused, because (get OneLineMode) is unused+ | otherwise = q++nonEmptySet :: Doc a -> 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 a -> Doc a+oneLiner NoDoc = NoDoc+oneLiner Empty = Empty+oneLiner (NilAbove _) = NoDoc+oneLiner (TextBeside s p) = textBeside_ s (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. Allows us to specify constraints to choose among the+-- many different rendering options.+data Style+ = Style { mode :: Mode+ -- ^ The rendering mode.+ , lineLength :: Int+ -- ^ Maximum length of a line, in characters.+ , ribbonsPerLine :: Float+ -- ^ Ratio of line length to ribbon length. A ribbon refers to the+ -- characters on a line /excluding/ indentation. So a 'lineLength'+ -- of 100, with a 'ribbonsPerLine' of @2.0@ would only allow up to+ -- 50 characters of ribbon to be displayed on a line, while+ -- allowing it to be indented up to 50 characters.+ }+#if __GLASGOW_HASKELL__ >= 701+ deriving (Show, Eq, Generic)+#endif++-- | 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 rendering ('lineLength' and 'ribbonsPerLine'+ -- respected').+ | ZigZagMode + -- ^ With zig-zag cuts.+ | LeftMode + -- ^ No indentation, infinitely long lines ('lineLength' ignored),+ -- but explicit new lines, i.e., @text "one" $$ text "two"@, are+ -- respected.+ | OneLineMode + -- ^ All on one line, 'lineLength' ignored and explicit new lines+ -- (@$$@) are turned into spaces.+#if __GLASGOW_HASKELL__ >= 701+ deriving (Show, Eq, Generic)+#endif++-- | Render the @Doc@ to a String using the default @Style@ (see 'style').+render :: Doc a -> String+render = fullRender (mode style) (lineLength style) (ribbonsPerLine style)+ txtPrinter ""++-- | Render the @Doc@ to a String using the given @Style@.+renderStyle :: Style -> Doc a -> String+renderStyle s = fullRender (mode s) (lineLength s) (ribbonsPerLine s)+ txtPrinter ""++-- | 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. Please refer to the @Style@ and @Mode@+-- types for a description of rendering mode, line length and ribbons.+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 b -- ^ The document.+ -> a -- ^ Result.+fullRender m l r txt = fullRenderAnn m l r annTxt+ where+ annTxt (NoAnnot s _) = txt s+ annTxt _ = id++-- | The general rendering interface, supporting annotations. Please refer to+-- the @Style@ and @Mode@ types for a description of rendering mode, line+-- length and ribbons.+fullRenderAnn :: Mode -- ^ Rendering mode.+ -> Int -- ^ Line length.+ -> Float -- ^ Ribbons per line.+ -> (AnnotDetails b -> a -> a) -- ^ What to do with text.+ -> a -- ^ What to do at the end.+ -> Doc b -- ^ The document.+ -> a -- ^ Result.+fullRenderAnn OneLineMode _ _ txt end doc+ = easyDisplay spaceText (\_ y -> y) txt end (reduceDoc doc)+fullRenderAnn LeftMode _ _ txt end doc+ = easyDisplay nlText first txt end (reduceDoc doc)++fullRenderAnn 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++easyDisplay :: AnnotDetails b+ -> (Doc b -> Doc b -> Doc b)+ -> (AnnotDetails b -> a -> a)+ -> a+ -> Doc b+ -> a+easyDisplay nlSpaceText choose txt end+ = lay+ where+ lay NoDoc = error "easyDisplay: NoDoc"+ lay (Union p q) = lay (choose p q)+ lay (Nest _ p) = lay p+ lay Empty = end+ lay (NilAbove p) = nlSpaceText `txt` lay p+ lay (TextBeside s p) = s `txt` lay p+ lay (Above {}) = error "easyDisplay Above"+ lay (Beside {}) = error "easyDisplay Beside"++display :: Mode -> Int -> Int -> (AnnotDetails b -> a -> a) -> a -> Doc b -> 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) = nlText `txt` lay k p+ lay k (TextBeside s p)+ = case m of+ ZigZagMode | k >= gap_width+ -> nlText `txt` (+ NoAnnot (Str (replicate shift '/')) shift `txt` (+ nlText `txt`+ lay1 (k - shift) s p ))++ | k < 0+ -> nlText `txt` (+ NoAnnot (Str (replicate shift '\\')) shift `txt` (+ nlText `txt`+ lay1 (k + shift) s p ))++ _ -> lay1 k s 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 p = let !r = k + annotSize s+ in NoAnnot (Str (indent k)) k `txt` (s `txt` lay2 r p)++ lay2 k _ | k `seq` False = undefined+ lay2 k (NilAbove p) = nlText `txt` lay k p+ lay2 k (TextBeside s p) = s `txt` lay2 (k + annotSize s) 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+ }}++++-- Rendering Annotations -------------------------------------------------------++-- | A @Span@ represents the result of an annotation after a @Doc@ has been+-- rendered, capturing where the annotation now starts and ends in the rendered+-- output.+data Span a = Span { spanStart :: !Int+ , spanLength :: !Int+ , spanAnnotation :: a+ } deriving (Show,Eq)++instance Functor Span where+ fmap f (Span x y a) = Span x y (f a)+++-- State required for generating document spans.+data Spans a = Spans { sOffset :: !Int+ -- ^ Current offset from the end of the document.+ , sStack :: [Int -> Span a]+ -- ^ Currently open spans.+ , sSpans :: [Span a]+ -- ^ Collected annotation regions.+ , sOutput :: String+ -- ^ Collected output.+ }++-- | Render an annotated @Doc@ to a String and list of annotations (see 'Span')+-- using the default @Style@ (see 'style').+renderSpans :: Doc ann -> (String,[Span ann])+renderSpans = finalize+ . fullRenderAnn (mode style) (lineLength style) (ribbonsPerLine style)+ spanPrinter+ Spans { sOffset = 0, sStack = [], sSpans = [], sOutput = "" }+ where++ finalize (Spans size _ spans out) = (out, map adjust spans)+ where+ adjust s = s { spanStart = size - spanStart s }++ mkSpan a end start = Span { spanStart = start+ , spanLength = start - end+ -- this seems wrong, but remember that it's+ -- working backwards at this point+ , spanAnnotation = a }++ -- the document gets generated in reverse, which is why the starting+ -- annotation ends the annotation.+ spanPrinter AnnotStart s =+ case sStack s of+ sp : rest -> s { sSpans = sp (sOffset s) : sSpans s, sStack = rest }+ _ -> error "renderSpans: stack underflow"++ spanPrinter (AnnotEnd a) s =+ s { sStack = mkSpan a (sOffset s) : sStack s }++ spanPrinter (NoAnnot td l) s =+ case td of+ Chr c -> s { sOutput = c : sOutput s, sOffset = sOffset s + l }+ Str t -> s { sOutput = t ++ sOutput s, sOffset = sOffset s + l }+ PStr t -> s { sOutput = t ++ sOutput s, sOffset = sOffset s + l }+++-- | Render out a String, interpreting the annotations as part of the resulting+-- document.+--+-- /IMPORTANT/: the size of the annotation string does NOT figure into the+-- layout of the document, so the document will lay out as though the+-- annotations are not present.+renderDecorated :: (ann -> String) -- ^ Starting an annotation.+ -> (ann -> String) -- ^ Ending an annotation.+ -> Doc ann -> String+renderDecorated startAnn endAnn =+ finalize . fullRenderAnn (mode style) (lineLength style) (ribbonsPerLine style)+ annPrinter+ ("", [])+ where+ annPrinter AnnotStart (rest,stack) =+ case stack of+ a : as -> (startAnn a ++ rest, as)+ _ -> error "renderDecorated: stack underflow"++ annPrinter (AnnotEnd a) (rest,stack) =+ (endAnn a ++ rest, a : stack)++ annPrinter (NoAnnot s _) (rest,stack) =+ (txtPrinter s rest, stack)++ finalize (str,_) = str+++-- | Render a document with annotations, by interpreting the start and end of+-- the annotations, as well as the text details in the context of a monad.+renderDecoratedM :: Monad m+ => (ann -> m r) -- ^ Starting an annotation.+ -> (ann -> m r) -- ^ Ending an annotation.+ -> (String -> m r) -- ^ Text formatting.+ -> m r -- ^ Document end.+ -> Doc ann -> m r+renderDecoratedM startAnn endAnn txt docEnd =+ finalize . fullRenderAnn (mode style) (lineLength style) (ribbonsPerLine style)+ annPrinter+ (docEnd, [])+ where+ annPrinter AnnotStart (rest,stack) =+ case stack of+ a : as -> (startAnn a >> rest, as)+ _ -> error "renderDecorated: stack underflow"++ annPrinter (AnnotEnd a) (rest,stack) =+ (endAnn a >> rest, a : stack)++ annPrinter (NoAnnot td _) (rest,stack) =+ case td of+ Chr c -> (txt [c] >> rest, stack)+ Str s -> (txt s >> rest, stack)+ PStr s -> (txt s >> rest, stack)++ finalize (m,_) = m
+ src/Text/PrettyPrint/Annotated/HughesPJClass.hs view
@@ -0,0 +1,147 @@+#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE Safe #-}+#endif++-----------------------------------------------------------------------------+-- |+-- Module : Text.PrettyPrint.Annotated.HughesPJClass+-- Copyright : (c) Trevor Elliott <revor@galois.com> 2015+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : David Terei <code@davidterei.com>+-- Stability : stable+-- Portability : portable+--+-- Pretty printing class, simlar to 'Show' but nicer looking.+--+-- Note that the precedence level is a 'Rational' so there is an unlimited+-- number of levels. This module re-exports+-- 'Text.PrettyPrint.Annotated.HughesPJ'.+--+-----------------------------------------------------------------------------++module Text.PrettyPrint.Annotated.HughesPJClass (+ -- * Pretty typeclass+ Pretty(..),++ PrettyLevel(..), prettyNormal,+ prettyShow, prettyParen,++ -- re-export HughesPJ+ module Text.PrettyPrint.Annotated.HughesPJ+ ) where++import Text.PrettyPrint.Annotated.HughesPJ++-- | Level of detail in the pretty printed output. Level 0 is the least+-- detail.+newtype PrettyLevel = PrettyLevel Int+ deriving (Eq, Ord, Show)++-- | The "normal" (Level 0) of detail.+prettyNormal :: PrettyLevel+prettyNormal = PrettyLevel 0++-- | Pretty printing class. The precedence level is used in a similar way as in+-- the 'Show' class. Minimal complete definition is either 'pPrintPrec' or+-- 'pPrint'.+class Pretty a where+ pPrintPrec :: PrettyLevel -> Rational -> a -> Doc ann+ pPrintPrec _ _ = pPrint++ pPrint :: a -> Doc ann+ pPrint = pPrintPrec prettyNormal 0++ pPrintList :: PrettyLevel -> [a] -> Doc ann+ pPrintList l = brackets . fsep . punctuate comma . map (pPrintPrec l 0)++#if __GLASGOW_HASKELL__ >= 708+ {-# MINIMAL pPrintPrec | pPrint #-}+#endif++-- | Pretty print a value with the 'prettyNormal' level.+prettyShow :: (Pretty a) => a -> String+prettyShow = render . pPrint++pPrint0 :: (Pretty a) => PrettyLevel -> a -> Doc ann+pPrint0 l = pPrintPrec l 0++appPrec :: Rational+appPrec = 10++-- | Parenthesize an value if the boolean is true.+{-# DEPRECATED prettyParen "Please use 'maybeParens' instead" #-}+prettyParen :: Bool -> Doc ann -> Doc ann+prettyParen = maybeParens++-- Various Pretty instances+instance Pretty Int where pPrint = int++instance Pretty Integer where pPrint = integer++instance Pretty Float where pPrint = float++instance Pretty Double where pPrint = double++instance Pretty () where pPrint _ = text "()"++instance Pretty Bool where pPrint = text . show++instance Pretty Ordering where pPrint = text . show++instance Pretty Char where+ pPrint = char+ pPrintList _ = text . show++instance (Pretty a) => Pretty (Maybe a) where+ pPrintPrec _ _ Nothing = text "Nothing"+ pPrintPrec l p (Just x) =+ prettyParen (p > appPrec) $ text "Just" <+> pPrintPrec l (appPrec+1) x++instance (Pretty a, Pretty b) => Pretty (Either a b) where+ pPrintPrec l p (Left x) =+ prettyParen (p > appPrec) $ text "Left" <+> pPrintPrec l (appPrec+1) x+ pPrintPrec l p (Right x) =+ prettyParen (p > appPrec) $ text "Right" <+> pPrintPrec l (appPrec+1) x++instance (Pretty a) => Pretty [a] where+ pPrintPrec l _ = pPrintList l++instance (Pretty a, Pretty b) => Pretty (a, b) where+ pPrintPrec l _ (a, b) =+ parens $ fsep $ punctuate comma [pPrint0 l a, pPrint0 l b]++instance (Pretty a, Pretty b, Pretty c) => Pretty (a, b, c) where+ pPrintPrec l _ (a, b, c) =+ parens $ fsep $ punctuate comma [pPrint0 l a, pPrint0 l b, pPrint0 l c]++instance (Pretty a, Pretty b, Pretty c, Pretty d) => Pretty (a, b, c, d) where+ pPrintPrec l _ (a, b, c, d) =+ parens $ fsep $ punctuate comma+ [pPrint0 l a, pPrint0 l b, pPrint0 l c, pPrint0 l d]++instance (Pretty a, Pretty b, Pretty c, Pretty d, Pretty e) => Pretty (a, b, c, d, e) where+ pPrintPrec l _ (a, b, c, d, e) =+ parens $ fsep $ punctuate comma+ [pPrint0 l a, pPrint0 l b, pPrint0 l c, pPrint0 l d, pPrint0 l e]++instance (Pretty a, Pretty b, Pretty c, Pretty d, Pretty e, Pretty f) => Pretty (a, b, c, d, e, f) where+ pPrintPrec l _ (a, b, c, d, e, f) =+ parens $ fsep $ punctuate comma+ [pPrint0 l a, pPrint0 l b, pPrint0 l c,+ pPrint0 l d, pPrint0 l e, pPrint0 l f]++instance (Pretty a, Pretty b, Pretty c, Pretty d, Pretty e, Pretty f, Pretty g) =>+ Pretty (a, b, c, d, e, f, g) where+ pPrintPrec l _ (a, b, c, d, e, f, g) =+ parens $ fsep $ punctuate comma+ [pPrint0 l a, pPrint0 l b, pPrint0 l c,+ pPrint0 l d, pPrint0 l e, pPrint0 l f, pPrint0 l g]++instance (Pretty a, Pretty b, Pretty c, Pretty d, Pretty e, Pretty f, Pretty g, Pretty h) =>+ Pretty (a, b, c, d, e, f, g, h) where+ pPrintPrec l _ (a, b, c, d, e, f, g, h) =+ parens $ fsep $ punctuate comma+ [pPrint0 l a, pPrint0 l b, pPrint0 l c,+ pPrint0 l d, pPrint0 l e, pPrint0 l f, pPrint0 l g, pPrint0 l h]+
+ src/Text/PrettyPrint/HughesPJ.hs view
@@ -0,0 +1,457 @@+{-# OPTIONS_HADDOCK not-home #-}+#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE Safe #-}+{-# LANGUAGE DeriveGeneric #-}+#endif++-----------------------------------------------------------------------------+-- |+-- Module : Text.PrettyPrint.HughesPJ+-- Copyright : (c) The University of Glasgow 2001+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : David Terei <code@davidterei.com>+-- Stability : stable+-- Portability : portable+--+-- Provides a collection of pretty printer combinators, a set of API's that+-- provides a way to easily print out text in a consistent format of your+-- choosing.+--+-- Originally designed by John Hughes's and Simon Peyton Jones's.+--+-- For more information you can refer to the+-- <http://belle.sourceforge.net/doc/hughes95design.pdf original paper> that+-- serves as the basis for this libraries design: /The Design of a+-- Pretty-printing Library/ by John Hughes, in Advanced Functional Programming,+-- 1995.+--+-----------------------------------------------------------------------------++#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,+ maybeParens, maybeBrackets, maybeBraces, maybeQuotes, maybeDoubleQuotes,++ -- ** 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+#endif++import Text.PrettyPrint.Annotated.HughesPJ+ ( TextDetails(..), Mode(..), Style(..), style )+import qualified Text.PrettyPrint.Annotated.HughesPJ as Ann++import Control.DeepSeq ( NFData(rnf) )+import Data.Function ( on )+#if __GLASGOW_HASKELL__ >= 803+import Prelude hiding ( (<>) )+#endif+#if __GLASGOW_HASKELL__ >= 800+import qualified Data.Semigroup as Semi ( Semigroup((<>)) )+#elif __GLASGOW_HASKELL__ < 709+import Data.Monoid ( Monoid(mempty, mappend) )+#endif+import Data.String ( IsString(fromString) )++import GHC.Generics+++-- ---------------------------------------------------------------------------+-- 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.+newtype Doc = Doc (Ann.Doc ())+#if __GLASGOW_HASKELL__ >= 701+ deriving (Generic)+#endif++liftList :: ([Ann.Doc ()] -> Ann.Doc ()) -> ([Doc] -> Doc)+liftList f ds = Doc (f [ d | Doc d <- ds ])+{-# INLINE liftList #-}++liftBinary :: (Ann.Doc () -> Ann.Doc () -> Ann.Doc ())+ -> ( Doc -> Doc -> Doc )+liftBinary f (Doc a) (Doc b) = Doc (f a b)+{-# INLINE liftBinary #-}++-- | RDoc is a "reduced GDoc", guaranteed not to have a top-level Above or+-- Beside.+type RDoc = Doc++-- Combining @Doc@ values+#if __GLASGOW_HASKELL__ >= 800+instance Semi.Semigroup Doc where+ (<>) = (Text.PrettyPrint.HughesPJ.<>)++instance Monoid Doc where+ mempty = empty+ mappend = (Semi.<>)+#else+instance Monoid Doc where+ mempty = empty+ mappend = (<>)+#endif++instance IsString Doc where+ fromString = text++instance Show Doc where+ showsPrec _ doc cont = fullRender (mode style) (lineLength style)+ (ribbonsPerLine style)+ txtPrinter cont doc++instance Eq Doc where+ (==) = (==) `on` render++instance NFData Doc where+ rnf (Doc a) = rnf a++-- ---------------------------------------------------------------------------+-- Values and Predicates on GDocs and TextDetails++-- | A document of height and width 1, containing a literal character.+char :: Char -> Doc+char c = Doc (Ann.char c)+{-# INLINE char #-}++-- | 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 = Doc (Ann.text s)+{-# INLINE text #-}++-- | Same as @text@. Used to be used for Bytestrings.+ptext :: String -> Doc+ptext s = Doc (Ann.ptext s)+{-# INLINE ptext #-}++-- | Some text with any width. (@text s = sizedText (length s) s@)+sizedText :: Int -> String -> Doc+sizedText l s = Doc (Ann.sizedText l s)++-- | 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 = Doc Ann.empty++-- | Returns 'True' if the document is empty+isEmpty :: Doc -> Bool+isEmpty (Doc d) = Ann.isEmpty d++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 '}'++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 '}'++-- | Apply 'parens' to 'Doc' if boolean is true.+maybeParens :: Bool -> Doc -> Doc+maybeParens False = id+maybeParens True = parens++-- | Apply 'brackets' to 'Doc' if boolean is true.+maybeBrackets :: Bool -> Doc -> Doc+maybeBrackets False = id+maybeBrackets True = brackets++-- | Apply 'braces' to 'Doc' if boolean is true.+maybeBraces :: Bool -> Doc -> Doc+maybeBraces False = id+maybeBraces True = braces++-- | Apply 'quotes' to 'Doc' if boolean is true.+maybeQuotes :: Bool -> Doc -> Doc+maybeQuotes False = id+maybeQuotes True = quotes++-- | Apply 'doubleQuotes' to 'Doc' if boolean is true.+maybeDoubleQuotes :: Bool -> Doc -> Doc+maybeDoubleQuotes False = id+maybeDoubleQuotes True = doubleQuotes++-- ---------------------------------------------------------------------------+-- Structural operations on GDocs++-- | Perform some simplification of a built up @GDoc@.+reduceDoc :: Doc -> RDoc+reduceDoc (Doc d) = Doc (Ann.reduceDoc d)+{-# INLINE reduceDoc #-}++-- | List version of '<>'.+hcat :: [Doc] -> Doc+hcat = liftList Ann.hcat+{-# INLINE hcat #-}++-- | List version of '<+>'.+hsep :: [Doc] -> Doc+hsep = liftList Ann.hsep+{-# INLINE hsep #-}++-- | List version of '$$'.+vcat :: [Doc] -> Doc+vcat = liftList Ann.vcat+{-# INLINE vcat #-}++-- | 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 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+--+-- The side condition on the last law is needed because+-- 'empty' is a left identity for '<>'.+nest :: Int -> Doc -> Doc+nest k (Doc p) = Doc (Ann.nest k p)+{-# INLINE nest #-}++-- | @hang d1 n d2 = sep [d1, nest n d2]@+hang :: Doc -> Int -> Doc -> Doc+hang (Doc d1) n (Doc d2) = Doc (Ann.hang d1 n d2)+{-# INLINE hang #-}++-- | @punctuate p [d1, ... dn] = [d1 \<> p, d2 \<> p, ... dn-1 \<> p, dn]@+punctuate :: Doc -> [Doc] -> [Doc]+punctuate (Doc p) ds = [ Doc d | d <- Ann.punctuate p [ d | Doc d <- ds ] ]+{-# INLINE punctuate #-}+++-- ---------------------------------------------------------------------------+-- 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+($$) = liftBinary (Ann.$$)+{-# INLINE ($$) #-}++-- | Above, with no overlapping.+-- '$+$' is associative, with identity 'empty'.+($+$) :: Doc -> Doc -> Doc+($+$) = liftBinary (Ann.$+$)+{-# INLINE ($+$) #-}+++-- ---------------------------------------------------------------------------+-- 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+(<>) = liftBinary (Ann.<>)+{-# INLINE (<>) #-}++-- | Beside, separated by space, unless one of the arguments is 'empty'.+-- '<+>' is associative, with identity 'empty'.+(<+>) :: Doc -> Doc -> Doc+(<+>) = liftBinary (Ann.<+>)+{-# INLINE (<+>) #-}+++-- ---------------------------------------------------------------------------+-- Separate, @sep@++-- Specification: sep ps = oneLiner (hsep ps)+-- `union`+-- vcat ps++-- | Either 'hsep' or 'vcat'.+sep :: [Doc] -> Doc+sep = liftList Ann.sep+{-# INLINE sep #-}++-- | Either 'hcat' or 'vcat'.+cat :: [Doc] -> Doc+cat = liftList Ann.cat+{-# INLINE cat #-}+++-- ---------------------------------------------------------------------------+-- @fill@++-- | \"Paragraph fill\" version of 'cat'.+fcat :: [Doc] -> Doc+fcat = liftList Ann.fcat+{-# INLINE fcat #-}++-- | \"Paragraph fill\" version of 'sep'.+fsep :: [Doc] -> Doc+fsep = liftList Ann.fsep+{-# INLINE fsep #-}+++-- ---------------------------------------------------------------------------+-- Selecting the best layout++-- | @first@ returns its first argument if it is non-empty, otherwise its second.+first :: Doc -> Doc -> Doc+first = liftBinary Ann.first+{-# INLINE first #-}+++-- ---------------------------------------------------------------------------+-- Rendering++-- | Render the @Doc@ to a String using the default @Style@ (see 'style').+render :: Doc -> String+render = fullRender (mode style) (lineLength style) (ribbonsPerLine style)+ txtPrinter ""+{-# INLINE render #-}++-- | Render the @Doc@ to a String using the given @Style@.+renderStyle :: Style -> Doc -> String+renderStyle s = fullRender (mode s) (lineLength s) (ribbonsPerLine s)+ txtPrinter ""+{-# INLINE renderStyle #-}++-- | 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. Please refer to the @Style@ and @Mode@+-- types for a description of rendering mode, line length and ribbons.+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 m lineLen ribbons txt rest (Doc doc)+ = Ann.fullRender m lineLen ribbons txt rest doc+{-# INLINE fullRender #-}+
+ src/Text/PrettyPrint/HughesPJClass.hs view
@@ -0,0 +1,146 @@+#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE Safe #-}+#endif++-----------------------------------------------------------------------------+-- |+-- Module : Text.PrettyPrint.HughesPJClass+-- Copyright : (c) Lennart Augustsson 2014+-- License : BSD-style (see the file LICENSE)+--+-- Maintainer : David Terei <code@davidterei.com>+-- Stability : stable+-- Portability : portable+--+-- Pretty printing class, simlar to 'Show' but nicer looking. +--+-- Note that the precedence level is a 'Rational' so there is an unlimited+-- number of levels. This module re-exports 'Text.PrettyPrint.HughesPJ'.+--+-----------------------------------------------------------------------------++module Text.PrettyPrint.HughesPJClass (+ -- * Pretty typeclass+ Pretty(..),++ PrettyLevel(..), prettyNormal,+ prettyShow, prettyParen,++ -- re-export HughesPJ+ module Text.PrettyPrint.HughesPJ+ ) where++import Text.PrettyPrint.HughesPJ++-- | Level of detail in the pretty printed output. Level 0 is the least+-- detail.+newtype PrettyLevel = PrettyLevel Int+ deriving (Eq, Ord, Show)++-- | The "normal" (Level 0) of detail.+prettyNormal :: PrettyLevel+prettyNormal = PrettyLevel 0++-- | Pretty printing class. The precedence level is used in a similar way as in+-- the 'Show' class. Minimal complete definition is either 'pPrintPrec' or+-- 'pPrint'.+class Pretty a where+ pPrintPrec :: PrettyLevel -> Rational -> a -> Doc+ pPrintPrec _ _ = pPrint++ pPrint :: a -> Doc+ pPrint = pPrintPrec prettyNormal 0++ pPrintList :: PrettyLevel -> [a] -> Doc+ pPrintList l = brackets . fsep . punctuate comma . map (pPrintPrec l 0)++#if __GLASGOW_HASKELL__ >= 708+ {-# MINIMAL pPrintPrec | pPrint #-}+#endif++-- | Pretty print a value with the 'prettyNormal' level.+prettyShow :: (Pretty a) => a -> String+prettyShow = render . pPrint++pPrint0 :: (Pretty a) => PrettyLevel -> a -> Doc+pPrint0 l = pPrintPrec l 0++appPrec :: Rational+appPrec = 10++-- | Parenthesize an value if the boolean is true.+{-# DEPRECATED prettyParen "Please use 'maybeParens' instead" #-}+prettyParen :: Bool -> Doc -> Doc+prettyParen = maybeParens++-- Various Pretty instances+instance Pretty Int where pPrint = int++instance Pretty Integer where pPrint = integer++instance Pretty Float where pPrint = float++instance Pretty Double where pPrint = double++instance Pretty () where pPrint _ = text "()"++instance Pretty Bool where pPrint = text . show++instance Pretty Ordering where pPrint = text . show++instance Pretty Char where+ pPrint = char+ pPrintList _ = text . show++instance (Pretty a) => Pretty (Maybe a) where+ pPrintPrec _ _ Nothing = text "Nothing"+ pPrintPrec l p (Just x) =+ prettyParen (p > appPrec) $ text "Just" <+> pPrintPrec l (appPrec+1) x++instance (Pretty a, Pretty b) => Pretty (Either a b) where+ pPrintPrec l p (Left x) =+ prettyParen (p > appPrec) $ text "Left" <+> pPrintPrec l (appPrec+1) x+ pPrintPrec l p (Right x) =+ prettyParen (p > appPrec) $ text "Right" <+> pPrintPrec l (appPrec+1) x++instance (Pretty a) => Pretty [a] where+ pPrintPrec l _ = pPrintList l++instance (Pretty a, Pretty b) => Pretty (a, b) where+ pPrintPrec l _ (a, b) =+ parens $ fsep $ punctuate comma [pPrint0 l a, pPrint0 l b]++instance (Pretty a, Pretty b, Pretty c) => Pretty (a, b, c) where+ pPrintPrec l _ (a, b, c) =+ parens $ fsep $ punctuate comma [pPrint0 l a, pPrint0 l b, pPrint0 l c]++instance (Pretty a, Pretty b, Pretty c, Pretty d) => Pretty (a, b, c, d) where+ pPrintPrec l _ (a, b, c, d) =+ parens $ fsep $ punctuate comma+ [pPrint0 l a, pPrint0 l b, pPrint0 l c, pPrint0 l d]++instance (Pretty a, Pretty b, Pretty c, Pretty d, Pretty e) => Pretty (a, b, c, d, e) where+ pPrintPrec l _ (a, b, c, d, e) =+ parens $ fsep $ punctuate comma+ [pPrint0 l a, pPrint0 l b, pPrint0 l c, pPrint0 l d, pPrint0 l e]++instance (Pretty a, Pretty b, Pretty c, Pretty d, Pretty e, Pretty f) => Pretty (a, b, c, d, e, f) where+ pPrintPrec l _ (a, b, c, d, e, f) =+ parens $ fsep $ punctuate comma+ [pPrint0 l a, pPrint0 l b, pPrint0 l c,+ pPrint0 l d, pPrint0 l e, pPrint0 l f]++instance (Pretty a, Pretty b, Pretty c, Pretty d, Pretty e, Pretty f, Pretty g) =>+ Pretty (a, b, c, d, e, f, g) where+ pPrintPrec l _ (a, b, c, d, e, f, g) =+ parens $ fsep $ punctuate comma+ [pPrint0 l a, pPrint0 l b, pPrint0 l c,+ pPrint0 l d, pPrint0 l e, pPrint0 l f, pPrint0 l g]++instance (Pretty a, Pretty b, Pretty c, Pretty d, Pretty e, Pretty f, Pretty g, Pretty h) =>+ Pretty (a, b, c, d, e, f, g, h) where+ pPrintPrec l _ (a, b, c, d, e, f, g, h) =+ parens $ fsep $ punctuate comma+ [pPrint0 l a, pPrint0 l b, pPrint0 l c,+ pPrint0 l d, pPrint0 l e, pPrint0 l f, pPrint0 l g, pPrint0 l h]+
+ tests/PrettyTestVersion.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}+#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE DeriveGeneric #-}+#endif++#define TESTING++-- | Here we use some CPP hackery to get a whitebox+-- version of HughesPJ for testing purposes.+module PrettyTestVersion where++#include "HughesPJ.hs"+
+ tests/Test.hs view
@@ -0,0 +1,998 @@+-----------------------------------------------------------------------------+-- 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 UnitLargeDoc+import UnitPP1+import UnitT3911+import UnitT32++import Control.Monad+import Data.Char (isSpace)+import Data.List (intersperse)+import Debug.Trace++import Test.QuickCheck++main :: IO ()+main = do+ -- quickcheck tests+ check_laws+ check_invariants+ check_improvements+ check_non_prims -- hpc full coverage+ check_rendering+ check_list_def+ + -- unit tests+ testPP1+ testT3911+ testT32+ testLargeDoc++-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- 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 ds1, TextBeside td2 ds2) | annotToTd td1 `tdEq` annotToTd 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+++-- (1) QuickCheck Properties: Laws+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++{-+Monoid laws for <>,<+>,$$,$+$+~~~~~~~~~~~~~+<a,b 1> (x * y) * z = x * (y * z)+<a,b 2> empty * x = x+<a,b 3> x * empty = x+-}+prop_1 op x y z = classify (any isEmpty [x,y,z]) "empty x, y or z" $+ ((x `op` y) `op` z) `deq` (x `op` (y `op` z))+prop_2 op x = classify (isEmpty x) "empty" $ (empty `op` x) `deq` x+prop_3 op x = classify (isEmpty x) "empty" $ x `deq` (empty `op` x)++check_monoid = do+ putStrLn " = Monoid Laws ="+ mapM_ (myTest' 5 maxTests "Associativity") [ liftDoc3 (prop_1 op) | op <- allops ]+ mapM_ (myTest "Left neutral") [ prop_2 op . buildDoc | op <- allops ]+ mapM_ (myTest "Right neutral") [ prop_3 op . buildDoc | op <- allops ]+ where+ allops = [ (<>), (<+>) ,($$) , ($+$) ]++{-+Laws for text+~~~~~~~~~~~~~+<t1> text s <> text t = text (s++t)+<t2> text "" <> x = x, if x non-empty [only true if x does not start with nest, because of <n6> ]+-}+prop_t1 s t = text' s <> text' t `deq` text (unText s ++ unText t)+prop_t2 x = not (isEmpty x) ==> text "" <> x `deq` x+prop_t2_a x = not (isEmpty x) && not (isNest x) ==> text "" <> x `deq` x++isNest :: Doc () -> Bool+isNest d = case reduceDoc d of+ (Nest _ _) -> True+ (Union d1 d2) -> isNest d1 || isNest d2+ _ -> False++check_t = do+ putStrLn " = Text laws ="+ myTest "t1" prop_t1+ myTest "t2_a (precondition: x does not start with nest)" (prop_t2_a . buildDoc)+ myTest "t_2 (Known to fail)" (expectFailure . prop_t2 . buildDoc)++{-+Laws for nest+~~~~~~~~~~~~~+<n1> nest 0 x = x+<n2> nest k (nest k' x) = nest (k+k') x+<n3> nest k (x <> y) = nest k z <> nest k y+<n4> nest k (x $$ y) = nest k x $$ nest k y+<n5> nest k empty = empty+<n6> x <> nest k y = x <> y, if x non-empty+-}+prop_n1 x = nest 0 x `deq` x+prop_n2 k k' x = nest k (nest k' x) `deq` nest (k+k') x+prop_n3 k k' x = nest k (nest k' x) `deq` nest (k+k') x +prop_n4 k x y = nest k (x $$ y) `deq` nest k x $$ nest k y+prop_n5 k = nest k empty `deq` empty+prop_n6 x k y = not (isEmpty x) ==> + x <> nest k y `deq` x <> y+check_n = do+ putStrLn "Nest laws"+ myTest "n1" (prop_n1 . buildDoc)+ myTest "n2" (\k k' -> prop_n2 k k' . buildDoc)+ myTest "n3" (\k k' -> prop_n3 k k' . buildDoc)+ myTest "n4" (\k -> liftDoc2 (prop_n4 k))+ myTest "n5" prop_n5+ myTest "n6" (\k -> liftDoc2 (\x -> prop_n6 x k))++{-+<m1> (text s <> x) $$ y = text s <> ((text "" <> x)) $$ + nest (-length s) y)++<m2> (x $$ y) <> z = x $$ (y <> z)+ if y non-empty+-} +prop_m1 s x y = (text' s <> x) $$ y `deq` text' s <> ((text "" <> x) $$ + nest (-length (unText s)) y)+prop_m2 x y z = not (isEmpty y) ==>+ (x $$ y) <> z `deq` x $$ (y <> z)+check_m = do+ putStrLn "Misc laws"+ myTest "m1" (\s -> liftDoc2 (prop_m1 s))+ myTest' 10 maxTests "m2" (liftDoc3 prop_m2)+++{-+Laws for list versions+~~~~~~~~~~~~~~~~~~~~~~+<l1> sep (ps++[empty]++qs) = sep (ps ++ qs)+ ...ditto hsep, hcat, vcat, fill...+[ Fails for fill ! ]+<l2> nest k (sep ps) = sep (map (nest k) ps)+ ...ditto hsep, hcat, vcat, fill...+-} +prop_l1 sp ps qs = + sp (ps++[empty]++qs) `rdeq` sp (ps ++ qs)+prop_l2 sp k ps = nest k (sep ps) `deq` sep (map (nest k) ps)+++prop_l1' sp cps cqs =+ let [ps,qs] = map buildDocList [cps,cqs] in + layoutCountBounded maxLayouts (sp (ps++qs)) ==> prop_l1 sp ps qs+prop_l2' sp k ps = prop_l2 sp k (buildDocList ps)+check_l = do+ allCats $ myTest "l1" . prop_l1'+ allCats $ myTest "l2" . prop_l2'+ where+ allCats = flip mapM_ [ sep, hsep, cat, hcat, vcat, fsep, fcat ]+prop_l1_fail_1 = [ text "a" ]+prop_l1_fail_2 = [ text "a" $$ text "b" ]++{-+Laws for oneLiner+~~~~~~~~~~~~~~~~~+<o1> oneLiner (nest k p) = nest k (oneLiner p)+<o2> oneLiner (x <> y) = oneLiner x <> oneLiner y ++[One liner only takes reduced arguments]+-} +oneLinerR = oneLiner . reduceDoc+prop_o1 k p = oneLinerR (nest k p) `deq` nest k (oneLinerR p)+prop_o2 x y = oneLinerR (x <> y) `deq` oneLinerR x <> oneLinerR y ++check_o = do+ putStrLn "oneliner laws"+ myTest "o1 (RDoc arg)" (\k p -> prop_o1 k (buildDoc p))+ myTest "o2 (RDoc arg)" (liftDoc2 prop_o2)++{-+Definitions of list versions+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+<ldef1> vcat = foldr ($$) empty+<ldef2> hcat = foldr (<>) empty+<ldef3> hsep = foldr (<+>) empty+-}+prop_hcat :: [Doc ()] -> Bool+prop_hcat ds = hcat ds `deq` (foldr (<>) empty) ds++prop_hsep :: [Doc ()] -> Bool+prop_hsep ds = hsep ds `deq` (foldr (<+>) empty) ds++prop_vcat :: [Doc ()] -> Bool+prop_vcat ds = vcat ds `deq` (foldr ($$) empty) ds++{-+Update (pretty-1.1.0):+*failing* definition of sep: oneLiner (hsep ps) `union` vcat ps+<ldef4> ?+-}+prop_sep :: [Doc ()] -> Bool+prop_sep ds = sep ds `rdeq` (sepDef ds)++sepDef :: [Doc ()] -> Doc ()+sepDef docs = let ds = filter (not . isEmpty) docs in+ case ds of+ [] -> empty+ [d] -> d+ ds -> reduceDoc (oneLiner (reduceDoc $ hsep ds) + `Union`+ (reduceDoc $ foldr ($+$) empty ds))++check_list_def = do + myTest "hcat def" (prop_hcat . buildDocList) + myTest "hsep def" (prop_hsep . buildDocList) + myTest "vcat def" (prop_vcat . buildDocList) + -- XXX: Not sure if this is meant to fail (I added the expectFailure [DT])+ myTest "sep def" (expectFailure . prop_sep . buildDocList)++{-+Definition of fill (fcat/fsep)+-- Specification: +-- fill [] = empty+-- fill [p] = p+-- fill (p1:p2:ps) = oneLiner p1 <#> nest (length p1) +-- (fill (oneLiner p2 : ps))+-- `union`+-- p1 $$ fill ps+-- Revised Specification:+-- fill g docs = fillIndent 0 docs+--+-- fillIndent k [] = []+-- fillIndent k [p] = p+-- fillIndent k (p1:p2:ps) =+-- oneLiner p1 <g> fillIndent (k + length p1 + g ? 1 : 0) (remove_nests (oneLiner p2) : ps)+-- `Union`+-- (p1 $*$ nest (-k) (fillIndent 0 ps)) +--+-- $*$ is defined for layouts (not Docs) as +-- layout1 $*$ layout2 | isOneLiner layout1 = layout1 $+$ layout2+-- | otherwise = layout1 $$ layout2+--+-- Old implementation ambiguities/problems:+-- ========================================+-- Preserving nesting:+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- fcat [cat[ text "b", text "a"], nest 2 ( text "" $$ text "a")]+-- ==> fcat [ text "b" $$ text "a", nest 2 (text "" $$ text "a")] // cat: union right+-- ==> (text "b" $$ text "a" $$ nest 2 (text "" $$ text "a")) // fcat: union right with overlap+-- ==> (text "ab" $$ nest 2 (text "" $$ text "a"))+-- ==> "b\na\n..a"+-- Bug #1337:+-- ~~~~~~~~~~+-- > fcat [ nest 1 $ text "a", nest 2 $ text "b", text "c"]+-- ==> [second alternative] roughly (a <#> b $#$ c)+-- " ab"+-- "c "+-- expected: (nest 1; text "a"; text "b"; nest -3; "c")+-- actual : (nest 1; text "a"; text "b"; nest -5; "c")+-- === (nest 1; text a) <> (fill (-2) (p2:ps))+-- ==> (nest 2 (text "b") $+$ text "c") +-- ==> (nest 2 (text "b") `nilabove` nest (-3) (text "c"))+-- ==> (nest 1; text a; text b; nest -5 c)++-}+prop_fcat_vcat :: [Doc ()] -> Bool+prop_fcat_vcat ds = last (flattenDoc $ fcat ds) `deq` last (flattenDoc $ vcat ds)++prop_fcat :: [Doc ()] -> Bool+prop_fcat ds = fcat ds `rdeq` fillDef False (filter (not . isEmpty) ds)++prop_fsep :: [Doc ()] -> Bool+prop_fsep ds = fsep ds `rdeq` fillDef True (filter (not . isEmpty) ds)++prop_fcat_old :: [Doc ()] -> Bool+prop_fcat_old ds = fillOld2 False ds `rdeq` fillDef False (filter (not . isEmpty) ds)++prop_fcat_old_old :: [Doc ()] -> Bool+prop_fcat_old_old ds = fillOld2 False ds `rdeq` fillDefOld False (filter (not . isEmpty) ds)++prop_restrict_sz :: (Testable a) => Int -> ([Doc ()] -> a) -> ([Doc ()] -> Property) +prop_restrict_sz k p ds = layoutCountBounded k (fsep ds) ==> p ds++prop_restrict_ol :: (Testable a) => ([Doc ()] -> a) -> ([Doc ()] -> Property)+prop_restrict_ol p ds = (all isOneLiner . map normalize $ ds) ==> p ds++prop_restrict_no_nest_start :: (Testable a) => ([Doc ()] -> a) -> ([Doc ()] -> Property)+prop_restrict_no_nest_start p ds = (all (not .isNest) ds) ==> p ds++fillDef :: Bool -> [Doc ()] -> Doc ()+fillDef g = normalize . fill' 0 . filter (not.isEmpty) . map reduceDoc+ where+ fill' _ [] = Empty+ fill' _ [x] = x + fill' k (p1:p2:ps) =+ reduceDoc (oneLiner p1 `append` (fill' (k + firstLineLength p1 + (if g then 1 else 0)) $ (oneLiner' p2) : ps))+ `union`+ reduceDoc (p1 $*$ (nest (-k) (fillDef g (p2:ps))))++ union = Union++ append = if g then (<+>) else (<>) ++ oneLiner' (Nest k d) = oneLiner' d+ oneLiner' d = oneLiner d++($*$) :: RDoc () -> RDoc () -> RDoc ()+($*$) p ps = case flattenDoc p of+ [] -> NoDoc+ ls -> foldr1 Union (map combine ls) + where+ combine p | isOneLiner p = p $+$ ps+ | otherwise = p $$ ps++fillDefOld :: Bool -> [Doc ()] -> Doc ()+fillDefOld g = normalize . fill' . filter (not.isEmpty) . map normalize where + fill' [] = Empty+ fill' [p1] = p1+ fill' (p1:p2:ps) = (normalize (oneLiner p1 `append` nest (firstLineLength p1) + (fill' (oneLiner p2 : ps))))+ `union`+ (p1 $$ fill' (p2:ps))+ append = if g then (<+>) else (<>)+ union = Union++check_fill_prop :: Testable a => String -> ([Doc ()] -> a) -> IO ()+check_fill_prop msg p = myTest msg (prop_restrict_sz maxLayouts p . buildDocList)++check_fill_def_fail :: IO ()+check_fill_def_fail = do + check_fill_prop "fcat defOld vs fcatOld (ol)" (prop_restrict_ol prop_fcat_old_old)+ check_fill_prop "fcat defOld vs fcatOld" prop_fcat_old_old++ check_fill_prop "fcat def (ol) vs fcatOld" (prop_restrict_ol prop_fcat_old)+ check_fill_prop "fcat def vs fcatOld" prop_fcat_old ++check_fill_def_ok :: IO ()+check_fill_def_ok = do+ check_fill_prop "fcat def (not nest start) vs fcatOld" (prop_restrict_no_nest_start prop_fcat_old)++ check_fill_prop "fcat def (not nest start) vs fcat" (prop_restrict_no_nest_start prop_fcat)+ -- XXX: These all fail now with the change of pretty to GHC behaviour.+ check_fill_prop "fcat def (ol) vs fcat" (expectFailure . prop_restrict_ol prop_fcat)+ check_fill_prop "fcat def vs fcat" (expectFailure . prop_fcat)+ check_fill_prop "fsep def vs fsep" (expectFailure . prop_fsep)+++check_fill_def_laws :: IO ()+check_fill_def_laws = do+ check_fill_prop "lastLayout (fcat ps) == vcat ps" prop_fcat_vcat++check_fill_def :: IO ()+check_fill_def = check_fill_def_fail >> check_fill_def_ok+{-+text "ac"; nilabove; nest -1; text "a"; empty+text "ac"; nilabove; nest -2; text "a"; empty+-}++{-+Zero width text (Neil)++Here it would be convenient to generate functions (or replace empty / text bz z-w-t)+-}+-- TODO+{- +All laws: monoid, text, nest, misc, list versions, oneLiner, list def+-}+check_laws :: IO ()+check_laws = do+ check_fill_def_ok+ check_monoid+ check_t+ check_n+ check_m+ check_l+ check_o+ check_list_def++-- (2) QuickCheck Properties: Invariants (whitebox)+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++-- strategies: synthesize with stop condition+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+stop :: a -> (a, Bool)+stop a = (a,False)++recurse :: a -> (a, Bool)+recurse a = (a,True)+-- strategy: generic synthesize with stop condition +-- terms are combined top-down, left-right (latin text order)+genericProp :: (a -> a -> a) -> (Doc () -> (a,Bool)) -> Doc () -> a+genericProp c q doc =+ case q doc of+ (v,False) -> v+ (v,True) -> foldl c v (subs doc)+ where+ rec = genericProp c q+ subs d = case d of+ Empty -> []+ NilAbove d -> [rec d]+ TextBeside _ d -> [rec d]+ Nest _ d -> [rec d]+ Union d1 d2 -> [rec d1, rec d2]+ NoDoc -> []+ Beside d1 _ d2 -> subs (reduceDoc d)+ Above d1 _ d2 -> subs (reduceDoc d)+++{-+ * The argument of NilAbove is never Empty. Therefore+ a NilAbove occupies at least two lines.+-}+prop_inv1 :: Doc () -> Bool+prop_inv1 d = genericProp (&&) nilAboveNotEmpty d where+ nilAboveNotEmpty (NilAbove Empty) = stop False+ nilAboveNotEmpty _ = recurse True++{-+ * The argument of @TextBeside@ is never @Nest@. +-}+prop_inv2 :: Doc () -> Bool+prop_inv2 = genericProp (&&) textBesideNotNest where+ textBesideNotNest (TextBeside _ (Nest _ _)) = stop False+ textBesideNotNest _ = recurse True+{-+ * The layouts of the two arguments of @Union@ both flatten to the same + string +-}+prop_inv3 :: Doc () -> Bool+prop_inv3 = genericProp (&&) unionsFlattenSame where+ unionsFlattenSame (Union d1 d2) = stop (pairwiseEqual (extractTexts d1 ++ extractTexts d2))+ unionsFlattenSame _ = recurse True+pairwiseEqual (x:y:zs) = x==y && pairwiseEqual (y:zs)+pairwiseEqual _ = True+++{-+ * The arguments of @Union@ are either @TextBeside@, or @NilAbove@.+-}+prop_inv4 :: Doc () -> Bool+prop_inv4 = genericProp (&&) unionArgs where+ unionArgs (Union d1 d2) | goodUnionArg d1 && goodUnionArg d2 = recurse True+ | otherwise = stop False+ unionArgs _ = recurse True+ goodUnionArg (TextBeside _ _) = True+ goodUnionArg (NilAbove _) = True+ goodUnionArg _ = False+ +{-+ * A @NoDoc@ may only appear on the first line of the left argument of+ an union. Therefore, the right argument of an union can never be equivalent+ to the empty set.+-}+prop_inv5 :: Doc () -> Bool+prop_inv5 = genericProp (&&) unionArgs . reduceDoc where+ unionArgs NoDoc = stop False+ unionArgs (Union d1 d2) = stop $ genericProp (&&) noDocIsFirstLine d1 && nonEmptySet (reduceDoc d2)+ unionArgs _ = (True,True) -- recurse+ noDocIsFirstLine (NilAbove d) = stop $ genericProp (&&) unionArgs d+ noDocIsFirstLine _ = recurse True++{-+ * An empty document is always represented by @Empty@. It can't be+ hidden inside a @Nest@, or a @Union@ of two @Empty@s.+-}+prop_inv6 :: Doc () -> Bool+prop_inv6 d | not (prop_inv1 d) || not (prop_inv2 d) = False+ | not (isEmptyDoc d) = True+ | otherwise = case d of Empty -> True ; _ -> False++isEmptyDoc :: Doc () -> Bool+isEmptyDoc d = case emptyReduction d of Empty -> True; _ -> False++{-+ * Consistency+ If all arguments of one of the list versions are empty documents, the list is an empty document+-}+prop_inv6a :: ([Doc ()] -> Doc ()) -> Property+prop_inv6a sep = forAll emptyDocListGen $+ \ds -> isEmptyRepr (sep $ buildDocList ds)+ where+ isEmptyRepr Empty = True+ isEmptyRepr _ = False++{-+ * The first line of every layout in the left argument of @Union@ is+ longer than the first line of any layout in the right argument.+ (1) ensures that the left argument has a first line. In view of+ (3), this invariant means that the right argument must have at+ least two lines.+-}+counterexample_inv7 = cat [ text " ", nest 2 ( text "a") ]++prop_inv7 :: Doc () -> Bool+prop_inv7 = genericProp (&&) firstLonger where+ firstLonger (Union d1 d2) = (firstLineLength d1 >= firstLineLength d2, True)+ firstLonger _ = (True, True)++{- + * If we take as precondition: the arguments of cat,sep,fill do not start with Nest, invariant 7 holds+-}+prop_inv7_pre :: CDoc -> Bool+prop_inv7_pre cdoc = nestStart True cdoc where+ nestStart nestOk doc = + case doc of+ CList sep ds -> all (nestStart False) ds+ CBeside _ d1 d2 -> nestStart nestOk d1 && nestStart (not . isEmpty $ buildDoc d1) d2+ CAbove _ d1 d2 -> nestStart nestOk d1 && nestStart (not . isEmpty $ buildDoc d1) d2+ CNest _ d | not nestOk -> False+ | otherwise -> nestStart True d+ _empty_or_text -> True++{-+ inv7_pre ==> inv7+-}+prop_inv7_a :: CDoc -> Property+prop_inv7_a cdoc = prop_inv7_pre cdoc ==> prop_inv7 (buildDoc cdoc)+ +check_invariants :: IO ()+check_invariants = do+ myTest "Invariant 1" (prop_inv1 . buildDoc)+ myTest "Invariant 2" (prop_inv2 . buildDoc)+ myTest "Invariant 3" (prop_inv3 . buildDoc)+ myTest "Invariant 4" (prop_inv4 . buildDoc)+ myTest "Invariant 5+" (prop_inv5 . buildDoc)+ myTest "Invariant 6" (prop_inv6 . buildDoc)+ mapM_ (\sp -> myTest "Invariant 6a" $ prop_inv6a sp) [ cat, sep, fcat, fsep, vcat, hcat, hsep ]+ -- XXX: Not sure if this is meant to fail (I added the expectFailure [DT])+ myTest "Invariant 7 (fails in HughesPJ:20080621)" (expectFailure . prop_inv7 . buildDoc)++-- `negative indent' +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ++{- + In the documentation we have:+ + (spaces n) generates a list of n spaces+ It should never be called with 'n' < 0, but that can happen for reasons I don't understand++ This is easy to explain:+ Suppose we have layout1 <> layout2+ length of last line layout1 is k1+ indentation of first line of layout2 is k2+ indentation of some other line of layout2 is k2'+ Now layout1 <> nest k2 (line1 $$ nest k2' lineK)+ ==> layout1 <> (line1 $$ nest k2' lineK)+ When k1 - k2' < 0, we need to layout lineK with negative indentation++ Here is a quick check property to ducment this.+-}+prop_negative_indent :: CDoc -> Property+prop_negative_indent cdoc = noNegNest cdoc ==> noNegSpaces (buildDoc cdoc)+noNegNest = genericCProp (&&) notIsNegNest where+ notIsNegNest (CNest k _) | k < 0 = stop False+ notIsNegNest _ = recurse True+noNegSpaces = go 0 . reduceDoc where + go k Empty = True+ go k (NilAbove d) = go k d+ go k (TextBeside _ d) | k < 0 = False+ go k (TextBeside s d) = go (k+annotSize 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 p) k ys = textBeside_ s (fillNB g p (k - annotSize s) 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 p) k ys = textBeside_ s (fillNB g p (k - annotSize s) 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 d -> (text ("text \""++tdToStr (annotToTd s) ++ "\"" ++ show (annotSize s))) <> 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 d) = map (TextBeside s) (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 (Nest k d)) = norm (TextBeside s d)+ norm (TextBeside s d) = (TextBeside s) (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 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 (TextBeside t2 doc)) = (merge.normalize) (TextBeside (mergeText t1 t2) doc)+ merge (TextBeside s d) = TextBeside s (merge d)+ merge (Nest k d) = Nest k (merge d)+ merge (Union d1 d2) = Union (merge d1) (merge d2)+ mergeText t1 t2 =+ NoAnnot (Str $ tdToStr (annotToTd t1) ++ tdToStr (annotToTd t2))+ (annotSize t1 + annotSize 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 (annotToTd 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 d -> TextBeside s (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 s d) = recurse (annotSize s)+ 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 d) = cal (k + annotSize s) (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 (annotToTd str)++docifyLayout :: [(Int,String)] -> Doc ()+docifyLayout = vcat . map (\(k,t) -> nest k (text t))+ +oneLineRender :: Doc () -> String+oneLineRender = olr . abstractLayout . last . flattenDoc where+ olr = concat . intersperse " " . map snd++-- because of invariant 4, we do not have to expand to layouts here+-- but it is easier, so for now we use abstractLayout+firstLineIsLeftMost :: Doc () -> Bool+firstLineIsLeftMost = all (firstIsLeftMost . abstractLayout) . flattenDoc where+ firstIsLeftMost ((k,_):xs@(_:_)) = all ( (>= k) . fst) xs+ firstIsLeftMost _ = True++noNegativeIndent :: Doc () -> Bool+noNegativeIndent = all (noNegIndent . abstractLayout) . flattenDoc where+ noNegIndent = all ( (>= 0) . fst)+
+ tests/TestGenerators.hs view
@@ -0,0 +1,75 @@+-- | Test generators.+--+module TestGenerators (+ emptyDocGen,+ emptyDocListGen+ ) where++import PrettyTestVersion+import TestStructures++import Control.Monad++import Test.QuickCheck++instance Arbitrary CDoc where+ arbitrary = sized arbDoc+ where+ -- TODO: finetune frequencies+ arbDoc k | k <= 1 = frequency [+ (1,return CEmpty)+ , (2,return (CText . unText) `ap` arbitrary)+ ]+ arbDoc n = frequency [+ (1, return CList `ap` arbitrary `ap` (liftM unDocList $ resize (pred n) arbitrary))+ ,(1, binaryComb n CBeside)+ ,(1, binaryComb n CAbove)+ ,(1, choose (0,10) >>= \k -> return (CNest k) `ap` (resize (pred n) arbitrary)) + ]+ binaryComb n f = + split2 (n-1) >>= \(n1,n2) ->+ return f `ap` arbitrary `ap` (resize n1 arbitrary) `ap` (resize n2 arbitrary)+ split2 n = flip liftM ( choose (0,n) ) $ \sz -> (sz, n - sz)++instance CoArbitrary CDoc where+ coarbitrary CEmpty = variant 0+ coarbitrary (CText t) = variant 1 . coarbitrary (length t)+ coarbitrary (CList f list) = variant 2 . coarbitrary f . coarbitrary list+ coarbitrary (CBeside b d1 d2) = variant 3 . coarbitrary b . coarbitrary d1 . coarbitrary d2+ coarbitrary (CAbove b d1 d2) = variant 4 . coarbitrary b . coarbitrary d1 . coarbitrary d2+ coarbitrary (CNest k d) = variant 5 . coarbitrary k . coarbitrary d+ +instance Arbitrary CList where+ arbitrary = oneof $ map return [ CCat, CSep, CFCat, CFSep ]++instance CoArbitrary CList where+ coarbitrary cl = variant (case cl of CCat -> 0; CSep -> 1; CFCat -> 2; CFSep -> 3)++-- we assume that the list itself has no size, so that +-- sizeof (a $$ b) = sizeof (sep [a,b]) = sizeof(a) + sizeof(b)+1+instance Arbitrary CDocList where+ arbitrary = liftM CDocList $ sized $ \n -> arbDocList n where+ arbDocList 0 = return []+ arbDocList n = do+ listSz <- choose (1,n)+ let elems = take listSz $ repeat (n `div` listSz) -- approximative+ mapM (\sz -> resize sz arbitrary) elems++instance CoArbitrary CDocList where+ coarbitrary (CDocList ds) = coarbitrary ds++instance Arbitrary Text where+ arbitrary = liftM Text $ sized $ \n -> mapM (const arbChar) [1..n]+ where arbChar = oneof (map return ['a'..'c'])++instance CoArbitrary Text where+ coarbitrary (Text str) = coarbitrary (length str)++emptyDocGen :: Gen CDoc+emptyDocGen = return CEmpty++emptyDocListGen :: Gen CDocList+emptyDocListGen = do+ ls <- listOf emptyDocGen+ return $ CDocList ls+
+ tests/TestStructures.hs view
@@ -0,0 +1,96 @@+-- | 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', annotToTd, 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++annotToTd :: AnnotDetails a -> TextDetails+annotToTd (NoAnnot s _) = s+annotToTd _ = 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]+
+ tests/TestUtils.hs view
@@ -0,0 +1,19 @@+-- | Test-suite framework and utility functions.+module TestUtils (+ simpleMatch+ ) where++import Control.Monad+import System.Exit++simpleMatch :: String -> String -> String -> IO ()+simpleMatch test expected actual =+ when (actual /= expected) $ do+ putStrLn $ "Test `" ++ test ++ "' failed!"+ putStrLn "-----------------------------"+ putStrLn $ "Expected: " ++ expected+ putStrLn "-----------------------------"+ putStrLn $ "Actual: " ++ actual+ putStrLn "-----------------------------"+ exitFailure+
+ tests/UnitLargeDoc.hs view
@@ -0,0 +1,16 @@+module UnitLargeDoc where++import Text.PrettyPrint.HughesPJ++import Control.DeepSeq+import Control.Exception++testLargeDoc :: IO ()+testLargeDoc = do+ putStrLn "Testing large doc..."+ evaluate largeDocRender+ return ()++largeDocRender :: String+largeDocRender = force $ render $ vcat $ replicate 10000000 $ text "Hello"+
+ tests/UnitPP1.hs view
@@ -0,0 +1,76 @@+-- This code used to print an infinite string, by calling 'spaces'+-- with a negative argument. There's a patch in the library now,+-- which makes 'spaces' do something sensible when called with a negative+-- argument, but it really should not happen at all.++module UnitPP1 where++import TestUtils++import Text.PrettyPrint.HughesPJ++ncat :: Doc -> Doc -> Doc+ncat x y = nest 4 $ cat [ x, y ]++d1, d2 :: Doc+d1 = foldl1 ncat $ take 50 $ repeat $ char 'a'+d2 = parens $ sep [ d1, text "+" , d1 ]++testPP1 :: IO ()+testPP1 = simpleMatch "PP1" expected out+ where out = show d2++expected :: String+expected =+ "(aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\n\++ a\n\+ a\n\+a\n\+a\n\+a\n\+a\n\+a\n\+a\n\+a\n\+a\n\+a\n\+a\n\+a\n\+a\n\+a\n\+a\n\+a\n\+a\n\+a\n\+a\n\+a\n\+a\n\+a\n\+a\n\+a\n\+a\n\+a\n\+a\n\+a\n\+a\n\+a\n\+a\n\+a\n\+a\n\+a\n\+a\n\+a\n\+a\n\+a\n\+a\n\+a\n\+a\n\+a\n\+a\n\+a\n\+a\n\+a\n\+a\n\+a\n\+a)"+
+ tests/UnitT32.hs view
@@ -0,0 +1,9 @@+-- Test from https://github.com/haskell/pretty/issues/32#issuecomment-223073337+module UnitT32 where++import Text.PrettyPrint.HughesPJ++import TestUtils++testT32 :: IO ()+testT32 = simpleMatch "T3911" (replicate 10 'x') $ take 10 $ render $ hcat $ repeat $ text "x"
+ tests/UnitT3911.hs view
@@ -0,0 +1,25 @@+module UnitT3911 where++import Text.PrettyPrint.HughesPJ++import TestUtils++xs :: [Doc]+xs = [text "hello",+ nest 10 (text "world")]++d1, d2, d3 :: Doc+d1 = vcat xs+d2 = foldr ($$) empty xs+d3 = foldr ($+$) empty xs++testT3911 :: IO ()+testT3911 = simpleMatch "T3911" expected out+ where out = show d1 ++ "\n" ++ show d2 ++ "\n" ++ show d3++expected :: String+expected =+ "hello world\n\+hello world\n\+hello\n\+ world"