diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. + +----------------------------------------------------------------------------- diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,6 @@ +module Main (main) where + +import Distribution.Simple + +main :: IO () +main = defaultMain diff --git a/Text/PrettyPrint.hs b/Text/PrettyPrint.hs new file mode 100644 --- /dev/null +++ b/Text/PrettyPrint.hs @@ -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 diff --git a/Text/PrettyPrint/HughesPJ.hs b/Text/PrettyPrint/HughesPJ.hs new file mode 100644 --- /dev/null +++ b/Text/PrettyPrint/HughesPJ.hs @@ -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 +-- +-- +-- 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 $$ +~~~~~~~~~~~ + (x $$ y) $$ z = x $$ (y $$ z) + empty $$ x = x + x $$ empty = x + + ...ditto $+$... + +Laws for <> +~~~~~~~~~~~ + (x <> y) <> z = x <> (y <> z) + empty <> x = empty + x <> empty = x + + ...ditto <+>... + +Laws for text +~~~~~~~~~~~~~ + text s <> text t = text (s++t) + text "" <> x = x, if x non-empty + +Laws for nest +~~~~~~~~~~~~~ + nest 0 x = x + nest k (nest k' x) = nest (k+k') x + nest k (x <> y) = nest k z <> nest k y + nest k (x $$ y) = nest k x $$ nest k y + nest k empty = empty + x <> nest k y = x <> y, if x non-empty + +** Note the side condition on ! It is this that +** makes it OK for empty to be a left unit for <>. + +Miscellaneous +~~~~~~~~~~~~~ + (text s <> x) $$ y = text s <> ((text "" <> x)) $$ + nest (-length s) y) + + (x $$ y) <> z = x $$ (y <> z) + if y non-empty + + +Laws for list versions +~~~~~~~~~~~~~~~~~~~~~~ + sep (ps++[empty]++qs) = sep (ps ++ qs) + ...ditto hsep, hcat, vcat, fill... + + nest k (sep ps) = sep (map (nest k) ps) + ...ditto hsep, hcat, vcat, fill... + +Laws for oneLiner +~~~~~~~~~~~~~~~~~ + oneLiner (nest k p) = nest k (oneLiner p) + oneLiner (x <> y) = oneLiner x <> oneLiner y + +You might think that the following verion of would +be neater: + +<3 NO> (text s <> x) $$ y = text s <> ((empty <> x)) $$ + nest (-length s) y) + +But it doesn't work, for if x=empty, we would have + + text s $$ y = text s <> (empty $$ nest (-length s) y) + = text s <> nest (-length s) y +-} + +-- --------------------------------------------------------------------------- +-- 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 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 "" 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 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 +-} diff --git a/pretty.cabal b/pretty.cabal new file mode 100644 --- /dev/null +++ b/pretty.cabal @@ -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 +