pretty (empty) → 1.0.0.0
raw patch · 5 files changed
+1072/−0 lines, 5 filesdep +basesetup-changed
Dependencies added: base
Files
- LICENSE +39/−0
- Setup.hs +6/−0
- Text/PrettyPrint.hs +22/−0
- Text/PrettyPrint/HughesPJ.hs +991/−0
- pretty.cabal +14/−0
+ LICENSE view
@@ -0,0 +1,39 @@+This library (libraries/pretty) is derived from code from+the GHC project which is largely (c) The University of+Glasgow, and distributable under a BSD-style license (see below).++-----------------------------------------------------------------------------++The Glasgow Haskell Compiler License++Copyright 2004, The University Court of the University of Glasgow. +All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++- Redistributions of source code must retain the above copyright notice,+this list of conditions and the following disclaimer.+ +- Redistributions in binary form must reproduce the above copyright notice,+this list of conditions and the following disclaimer in the documentation+and/or other materials provided with the distribution.+ +- Neither name of the University nor the names of its contributors may be+used to endorse or promote products derived from this software without+specific prior written permission. ++THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF+GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,+INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND+FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE+UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH+DAMAGE.++-----------------------------------------------------------------------------
+ Setup.hs view
@@ -0,0 +1,6 @@+module Main (main) where++import Distribution.Simple++main :: IO ()+main = defaultMain
+ Text/PrettyPrint.hs view
@@ -0,0 +1,22 @@+-----------------------------------------------------------------------------+-- |+-- 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 Prelude+import Text.PrettyPrint.HughesPJ
+ Text/PrettyPrint/HughesPJ.hs view
@@ -0,0 +1,991 @@+-----------------------------------------------------------------------------+-- |+-- 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,+ 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++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 prec 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++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++** 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 '}'+++hcat = foldr (<>) empty+hsep = foldr (<+>) empty+vcat = foldr ($$) empty++hang d1 n d2 = sep [d1, nest n d2]++punctuate p [] = []+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 = Chr ' '+nl_text = Chr '\n'++{-+ Here are the invariants:+ + * The argument of NilAbove is never Empty. Therefore+ a NilAbove occupies at least two lines.+ + * The arugment of @TextBeside@ is never @Nest@.+ + + * The layouts of the two arguments of @Union@ both flatten to the same + string.+ + * The arguments of @Union@ are either @TextBeside@, or @NilAbove@.+ + * The right argument of a union cannot be equivalent to the empty set+ (@NoDoc@). If the left argument of a union is equivalent to the+ empty set (@NoDoc@), then the @NoDoc@ appears in the first line.+ + * An empty document is always represented by @Empty@. It can't be+ hidden inside a @Nest@, or a @Union@ of two @Empty@s.+ + * 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.+-}++ -- Arg of a NilAbove is always an RDoc+nilAbove_ p = NilAbove p++ -- Arg of a TextBeside is always an RDoc+textBeside_ s sl p = TextBeside s sl p++ -- Arg of Nest is always an RDoc+nest_ k p = Nest k p++ -- Args of union are always RDocs+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}++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 k _ | k `seq` False = undefined+mkNest k (Nest k1 p) = mkNest (k + k1) p+mkNest k NoDoc = NoDoc+mkNest k Empty = Empty+mkNest 0 p = p -- Worth a try!+mkNest k p = nest_ k p++-- mkUnion checks for an empty document+mkUnion Empty q = 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 g k q = NoDoc+aboveNest (p1 `Union` p2) g k q = aboveNest p1 g k q `union_` + aboveNest p2 g k q+ +aboveNest Empty g 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+ other -> aboveNest p g k1 q+++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 g k 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 g q = NoDoc+beside (p1 `Union` p2) g q = (beside p1 g q) `union_` (beside p2 g q)+beside Empty g 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+ other -> beside p g q+++nilBeside :: Bool -> RDoc -> RDoc+-- Specification: text "" <> nilBeside g p +-- = text "" <g> p++nilBeside g 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 x [] = 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 g _ k ys | k `seq` False = undefined+sep1 g NoDoc k ys = 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 g (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)++-- Specification: sepNB p k ys = sep1 (text "" <> p) k ys+-- Called when we have already found some text in the first item+-- We have to eat up nests++sepNB g (Nest _ p) k ys = sepNB g p k ys++sepNB g Empty k ys = oneLiner (nilBeside g (reduceDoc rest))+ `mkUnion` + 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@++fsep = fill True+fcat = fill False++-- Specification: +-- fill [] = empty+-- fill [p] = p+-- fill (p1:p2:ps) = oneLiner p1 <#> nest (length p1) +-- (fill (oneLiner p2 : ps))+-- `union`+-- p1 $$ fill ps++fill g [] = empty+fill g (p:ps) = fill1 g (reduceDoc p) 0 ps+++fill1 :: Bool -> RDoc -> Int -> [Doc] -> Doc+fill1 g _ k ys | k `seq` False = undefined+fill1 g NoDoc k ys = 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)++fillNB g _ k ys | k `seq` False = undefined+fillNB g (Nest _ p) k ys = fillNB g p k ys+fillNB g Empty k [] = Empty+fillNB g Empty k (y:ys) = nilBeside g (fill1 g (oneLiner (reduceDoc y)) k1 ys)+ `mkUnion` + nilAboveNest False k (fill g (y:ys))+ where+ k1 | g = k - 1+ | otherwise = k++fillNB g p k ys = fill1 g p k ys+++-- ---------------------------------------------------------------------------+-- Selecting the best layout++best :: Mode+ -> Int -- Line length+ -> Int -- Ribbon length+ -> RDoc+ -> RDoc -- No unions in here!++best OneLineMode w r p+ = get p+ 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 k p) = get p -- Elide nest+ get (p `Union` q) = first (get p) (get q)++best mode w r p+ = get w p+ where+ get :: Int -- (Remaining) width of line+ -> Doc -> Doc+ get w _ | w==0 && False = undefined+ get w Empty = Empty+ get w 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)++ 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 w sl Empty = Empty+ get1 w sl 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 k p) = get1 w sl p+ get1 w sl (p `Union` q) = nicest1 w r sl (get1 w sl p) + (get1 w sl q)++nicest w r p q = nicest1 w r 0 p q+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 p | n < 0 = False+fits n NoDoc = False+fits n Empty = True+fits n (NilAbove _) = True+fits n (TextBeside _ sl p) = fits (n - sl) p++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 p q | nonEmptySet p = p + | otherwise = q++nonEmptySet NoDoc = False+nonEmptySet (p `Union` q) = True+nonEmptySet Empty = True+nonEmptySet (NilAbove p) = True -- NoDoc always in first line+nonEmptySet (TextBeside _ _ p) = nonEmptySet p+nonEmptySet (Nest _ p) = nonEmptySet p++-- @oneLiner@ returns the one-line members of the given set of @Doc@s.++oneLiner :: Doc -> Doc+oneLiner NoDoc = NoDoc+oneLiner Empty = Empty+oneLiner (NilAbove p) = NoDoc+oneLiner (TextBeside s sl p) = textBeside_ s sl (oneLiner p)+oneLiner (Nest k p) = nest_ k (oneLiner p)+oneLiner (p `Union` q) = oneLiner p+++-- ---------------------------------------------------------------------------+-- Displaying the best layout++renderStyle style doc + = fullRender (mode style)+ (lineLength style)+ (ribbonsPerLine style)+ string_txt+ ""+ doc++render doc = showDoc doc ""+showDoc doc rest = fullRender PageMode 100 1.5 string_txt rest doc++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 mode line_length ribbons_per_line txt end doc+ = display mode line_length ribbon_length txt end best_doc+ where + best_doc = best 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 mode of { ZigZagMode -> maxBound; other -> line_length }++display 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 k Empty = end+ + lay k (NilAbove p) = nl_text `txt` lay k p+ + lay k (TextBeside s sl p)+ = case 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 )))++ other -> 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 k Empty = end+ in+ lay 0 doc+ }}++cant_fail = error "easy_display: NoDoc"+easy_display nl_text txt end doc + = lay doc cant_fail+ where+ lay NoDoc no_doc = no_doc+ lay (Union p q) no_doc = {- lay p -} (lay q cant_fail) -- Second arg can't be NoDoc+ lay (Nest k p) no_doc = lay p no_doc+ lay Empty no_doc = end+ lay (NilAbove p) no_doc = nl_text `txt` lay p cant_fail -- NoDoc always on first line+ lay (TextBeside s sl p) no_doc = s `txt` lay p no_doc++-- 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 n = spaces n++multi_ch 0 ch = ""+multi_ch n ch = ch : multi_ch (n - 1) ch++-- (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+-- Here's a test case:+-- ncat x y = nest 4 $ cat [ x, y ]+-- d1 = foldl1 ncat $ take 50 $ repeat $ char 'a'+-- d2 = parens $ sep [ d1, text "+" , d1 ]+-- main = print d2+-- I don't feel motivated enough to find the Real Bug, so meanwhile we just test for n<=0+spaces n | n <= 0 = ""+ | otherwise = ' ' : spaces (n - 1)++{- Comments from Johannes Waldmann about what the problem might be:++ In the example above, d2 and d1 are deeply nested, but `text "+"' is not, + so the layout function tries to "out-dent" it.+ + when I look at the Doc values that are generated, there are lots of+ Nest constructors with negative arguments. see this sample output of+ d1 (obtained with hugs, :s -u)+ + tBeside (TextDetails_Chr 'a') 1 Doc_Empty) (Doc_NilAbove (Doc_Nest+ (-241) (Doc_TextBeside (TextDetails_Chr 'a') 1 Doc_Empty)))))+ (Doc_NilAbove (Doc_Nest (-236) (Doc_TextBeside (TextDetails_Chr 'a') 1+ (Doc_NilAbove (Doc_Nest (-5) (Doc_TextBeside (TextDetails_Chr 'a') 1+ Doc_Empty)))))))) (Doc_NilAbove (Doc_Nest (-231) (Doc_TextBeside+ (TextDetails_Chr 'a') 1 (Doc_NilAbove (Doc_Nest (-5) (Doc_TextBeside+ (TextDetails_Chr 'a') 1 (Doc_NilAbove (Doc_Nest (-5) (Doc_TextBeside+ (TextDetails_Chr 'a') 1 Doc_Empty))))))))))) (Doc_NilAbove (Doc_Nest+-}
+ pretty.cabal view
@@ -0,0 +1,14 @@+name: pretty+version: 1.0.0.0+license: BSD3+license-file: LICENSE+maintainer: libraries@haskell.org+synopsis: Pretty-printing library+description:+ This package contains a pretty-printing library.+build-type: Simple+exposed-modules:+ Text.PrettyPrint+ Text.PrettyPrint.HughesPJ+build-depends: base+