marked-pretty (empty) → 0.1
raw patch · 5 files changed
+1161/−0 lines, 5 filesdep +basesetup-changed
Dependencies added: base
Files
- LICENSE +40/−0
- Setup.hs +6/−0
- Text/PrettyPrint/MarkedHughesPJ.hs +1017/−0
- marked-pretty.cabal +23/−0
- test/Main.hs +75/−0
+ LICENSE view
@@ -0,0 +1,40 @@+This library (nested-pretty) is derived from pretty, which is+copied from libraries/pretty, and 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/MarkedHughesPJ.hs view
@@ -0,0 +1,1017 @@+-----------------------------------------------------------------------------+-- |+-- Module : Text.PrettyPrint.MarkedHughesPJ+-- Copyright : (c) The University of Glasgow 2001+-- License : BSD-style (see the file libraries/base/LICENSE)+-- +-- Maintainer : andygill@ku.edu+-- 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+--+-- Marking added by Andy Gill, Oct 08.+--+-----------------------------------------------------------------------------++{-+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++-}++{-+ AJG: Adding mark, which adds markup the output of the pretty printed text.+ This make no difference to the output ASCII text, but allow sub-expressions+ to be denoted, and other markup to be added. So, for example, keywords can be bold. +-}++module Text.PrettyPrint.MarkedHughesPJ (++ -- * The document type+ Doc, -- type synonym+ MDoc, -- 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(..),++ -- ** Markup extension+ mark+ ) where+++import Prelude++infixl 6 <> +infixl 6 <+>+infixl 5 $$, $+$++-- ---------------------------------------------------------------------------+-- The interface++-- The primitive Doc values++isEmpty :: MDoc a -> 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 :: MDoc a++semi :: MDoc a; -- ^ A ';' character+comma :: MDoc a; -- ^ A ',' character+colon :: MDoc a; -- ^ A ':' character+space :: MDoc a; -- ^ A space character+equals :: MDoc a; -- ^ A '=' character+lparen :: MDoc a; -- ^ A '(' character+rparen :: MDoc a; -- ^ A ')' character+lbrack :: MDoc a; -- ^ A '[' character+rbrack :: MDoc a; -- ^ A ']' character+lbrace :: MDoc a; -- ^ A '{' character+rbrace :: MDoc a; -- ^ A '}' character++-- | A document of height and width 1, containing a literal character.+char :: Char -> MDoc a++-- | 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 -> MDoc a++-- | An obsolete function, now identical to 'text'.+ptext :: String -> MDoc a++int :: Int -> MDoc a; -- ^ @int n = text (show n)@+integer :: Integer -> MDoc a; -- ^ @integer n = text (show n)@+float :: Float -> MDoc a; -- ^ @float n = text (show n)@+double :: Double -> MDoc a; -- ^ @double n = text (show n)@+rational :: Rational -> MDoc a; -- ^ @rational n = text (show n)@++parens :: MDoc a -> MDoc a; -- ^ Wrap document in @(...)@+brackets :: MDoc a -> MDoc a; -- ^ Wrap document in @[...]@+braces :: MDoc a -> MDoc a; -- ^ Wrap document in @{...}@+quotes :: MDoc a -> MDoc a; -- ^ Wrap document in @\'...\'@+doubleQuotes :: MDoc a -> MDoc a; -- ^ Wrap document in @\"...\"@++-- Combining @MDoc a@ values++-- | Beside.+-- '<>' is associative, with identity 'empty'.+(<>) :: MDoc a -> MDoc a -> MDoc a++-- | Beside, separated by space, unless one of the arguments is 'empty'.+-- '<+>' is associative, with identity 'empty'.+(<+>) :: MDoc a -> MDoc a -> MDoc a++-- | 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.+--+($$) :: MDoc a -> MDoc a -> MDoc a++-- | Above, with no overlapping.+-- '$+$' is associative, with identity 'empty'.+($+$) :: MDoc a -> MDoc a -> MDoc a++hcat :: [MDoc a] -> MDoc a; -- ^List version of '<>'.+hsep :: [MDoc a] -> MDoc a; -- ^List version of '<+>'.+vcat :: [MDoc a] -> MDoc a; -- ^List version of '$$'.++cat :: [MDoc a] -> MDoc a; -- ^ Either 'hcat' or 'vcat'.+sep :: [MDoc a] -> MDoc a; -- ^ Either 'hsep' or 'vcat'.+fcat :: [MDoc a] -> MDoc a; -- ^ \"Paragraph fill\" version of 'cat'.+fsep :: [MDoc a] -> MDoc a; -- ^ \"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 -> MDoc a -> MDoc a++-- GHC-specific ones.++-- | @hang d1 n d2 = sep [d1, nest n d2]@+hang :: MDoc a -> Int -> MDoc a -> MDoc a++-- | @punctuate p [d1, ... dn] = [d1 \<> p, d2 \<> p, ... dn-1 \<> p, dn]@+punctuate :: MDoc a -> [MDoc a] -> [MDoc a]+++-- Displaying @MDoc a@ values. ++instance Show (MDoc a) where+ showsPrec prec doc cont = showDoc doc cont++-- | Renders the document as a string using the default 'style'.+render :: MDoc a -> String++-- | The general rendering interface.+fullRender :: Mode -- ^Rendering mode+ -> Int -- ^Line length+ -> Float -- ^Ribbons per line+ -> (TextDetails b -> a -> a) -- ^What to do with text+ -> a -- ^What to do at the end+ -> MDoc b -- ^The document+ -> a -- ^Result++-- | Render the document as a string using a specified style.+renderStyle :: Style -> MDoc a -> 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++-- An Doc is a Marked Doc (MDoc) with no interesting markings.+type Doc = MDoc ()++-- An MDoc 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 MDoc a+ = Empty -- empty+ | NilAbove (MDoc a) -- text "" $$ x+ | TextBeside (TextDetails a) !Int (MDoc a) -- text s <> x + | Nest !Int (MDoc a) -- nest k x+ | Union (MDoc a) (MDoc a) -- ul `union` ur+ | NoDoc -- The empty set of documents+ | Beside (MDoc a) Bool (MDoc a) -- True <=> space between+ | Above (MDoc a) Bool (MDoc a) -- True <=> never overlap++type RDoc a = MDoc a -- RDoc is a "reduced Doc", guaranteed not to have a top-level Above or Beside+++reduceDoc :: MDoc 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++data TextDetails a+ = Chr Char+ | Str String+ | PStr String+ | Mark a++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_ :: MDoc a -> Bool -> MDoc a -> MDoc a+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 :: MDoc 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)++aboveNest :: RDoc a -> Bool -> Int -> RDoc a -> RDoc a+-- Specfication: aboveNest p g k q = p $g$ (nest k q)++aboveNest _ _ k _ | k `seq` False = undefined+aboveNest NoDoc 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 a -> RDoc a+-- 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_ :: MDoc a -> Bool -> MDoc a -> MDoc a+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 :: MDoc a -> Bool -> RDoc a -> RDoc a+-- 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 a -> RDoc a+-- 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 a -> Int -> [MDoc a] -> RDoc a +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 a -> Int -> [MDoc a] -> MDoc a+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 a+ -> RDoc a -- 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+ -> MDoc a -> MDoc a+ 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+ -> MDoc a -- This is an argument to TextBeside => eat Nests+ -> MDoc a -- 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+ -> MDoc a+ -> 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 :: MDoc a -> MDoc a+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+string_txt (Mark _) s2 = 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+-}+++------------------------------------------------------------------------------++-- | mark inserts a zero width mark into the output document++mark :: a -> MDoc a+mark m = textBeside_ (Mark m) 0 Empty+
+ marked-pretty.cabal view
@@ -0,0 +1,23 @@+name: marked-pretty+version: 0.1+Cabal-Version: >= 1.2+license: BSD3+license-file: LICENSE+category: Text+maintainer: andygill@ku.edu+synopsis: Pretty-printing library, with scoping, based on pretty-1.0.0.0+description:+ This package contains a pretty-printing library, with scoping.+build-type: Simple++Library+ Build-Depends: base+ Exposed-modules:+ Text.PrettyPrint.MarkedHughesPJ++Executable test+ Main-Is: Main.hs+ Hs-Source-Dirs: ., test+ buildable: False++
+ test/Main.hs view
@@ -0,0 +1,75 @@+module Main where++import Text.PrettyPrint.MarkedHughesPJ hiding (Doc)++data Exp = App Exp [Exp]+ | Var String+ | Lit Int+ | List [Exp]+++pretty :: Exp -> Doc+pretty (App e args) = pretty e <+> sep (map (parens . pretty) args)+pretty (Var v) = text v+pretty (Lit l) = scope BOLD $ scope GREEN $ text (show l)+pretty (List es) = brackets (scope RED (sep (punctuate (text ",") (map pretty es))))++type Doc = MDoc Markup++data Markup = Open MStyle | Close MStyle++data MStyle = BOLD | RED | GREEN++open :: MStyle -> Doc+open = mark . Open++close :: MStyle -> Doc+close = mark . Close++scope :: MStyle -> Doc -> Doc+scope s d = open s <> d <> close s++example1 = Var "abc"+example2 = Var "cde"+example3 = App example1 [example2]+example4 = Lit 99+example5 = App example3 [example1,example4,example2,example1,example2,example4,example2]+example6 = List [example1,example2,example3,example4,example5]+example7 = App example3 [example6]+example8 = App example4 [example4]++examples = [ example1+ , example2+ , example3+ , example4+ , example5+ , example6+ , example7+ , example8+ ]++main = do+ putStrLn "<html><body><pre>"+ sequence_ [ putStrLn $ render (pretty ex)+ | ex <- examples+ ]+ putStrLn "</pre><hr><pre>"+ sequence_ [ putStrLn $ fullRender PageMode 100 1.5 html_txt "" (pretty ex) + | ex <- examples+ ]+ putStrLn "</pre></body></html>"++html_txt (Chr c) r = concatMap escape [c] ++ r+html_txt (Str s) r = concatMap escape s ++ r+html_txt (PStr s) r = concatMap escape s ++ r+html_txt (Mark (Open BOLD)) r = "<b>" ++ r +html_txt (Mark (Close BOLD)) r = "</b>" ++ r+html_txt (Mark (Open RED)) r = "<font color=\"red\">" ++ r +html_txt (Mark (Close RED)) r = "</font>" ++ r+html_txt (Mark (Open GREEN)) r = "<font color=\"green\">" ++ r +html_txt (Mark (Close GREEN)) r = "</font>" ++ r++escape '<' = "<"+escape '>' = ">"+escape c = [c]+