diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,8 @@ +# 1.1.2.1 +* Redesigned to be based off of `pretty-1.1.2.1` + +# 0.1 +* Initial commit +* 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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,3 @@ +# marked-pretty [![Hackage version](https://img.shields.io/hackage/v/marked-pretty.svg?style=flat)](http://hackage.haskell.org/package/marked-pretty) [![Build Status](https://img.shields.io/travis/ku-fpg/marked-pretty.svg?style=flat)](https://travis-ci.org/ku-fpg/marked-pretty) + +Pretty-printing library, with scoping, based on `pretty`. diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,6 +1,2 @@ -module Main (main) where - import Distribution.Simple - -main :: IO () main = defaultMain diff --git a/Text/PrettyPrint/MarkedHughesPJ.hs b/Text/PrettyPrint/MarkedHughesPJ.hs deleted file mode 100644 --- a/Text/PrettyPrint/MarkedHughesPJ.hs +++ /dev/null @@ -1,1017 +0,0 @@ ------------------------------------------------------------------------------ --- | --- 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 --- --- --- 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 $$ -~~~~~~~~~~~ - (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 - --- 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 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 "" 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 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 - diff --git a/marked-pretty.cabal b/marked-pretty.cabal --- a/marked-pretty.cabal +++ b/marked-pretty.cabal @@ -1,23 +1,36 @@ -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 +name: marked-pretty +version: 1.1.2.1 +synopsis: Pretty-printing library, with scoping, based on pretty. +description: This package contains a pretty-printing library, with scoping. +homepage: https://github.com/ku-fpg/marked-pretty +bug-reports: https://github.com/ku-fpg/marked-pretty/issues +license: BSD3 +license-file: LICENSE +category: Text +author: Andy Gill +maintainer: Andy Gill +build-type: Simple +stability: Stable +extra-source-files: CHANGELOG.md, README.md +cabal-version: >= 1.8 -Executable test - Main-Is: Main.hs - Hs-Source-Dirs: ., test - buildable: False +source-repository head + type: git + location: git://github.com/ku-fpg/marked-pretty.git +library + build-depends: base >= 4.5 && < 5 + , deepseq >= 1.1 + , ghc-prim + exposed-modules: Text.PrettyPrint.MarkedHughesPJ + Text.PrettyPrint.MarkedHughesPJClass + hs-source-dirs: src + ghc-options: -Wall +test-suite test + type: exitcode-stdio-1.0 + main-is: Main.hs + build-depends: base >= 4.5 && < 5 + , marked-pretty == 1.1.2.1 + hs-source-dirs: test + ghc-options: -Wall diff --git a/src/Text/PrettyPrint/MarkedHughesPJ.hs b/src/Text/PrettyPrint/MarkedHughesPJ.hs new file mode 100644 --- /dev/null +++ b/src/Text/PrettyPrint/MarkedHughesPJ.hs @@ -0,0 +1,999 @@ +{-# LANGUAGE BangPatterns, CPP #-} +#if __GLASGOW_HASKELL__ >= 701 +{-# LANGUAGE Safe #-} +{-# LANGUAGE DeriveGeneric #-} +#endif + +----------------------------------------------------------------------------- +-- | +-- Module : Text.PrettyPrint.MarkedHughesPJ +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Andy Gill +-- Stability : stable +-- Portability : portable +-- +-- Provides a collection of pretty printer combinators, a set of API's +-- that provides a way to easily print out text in a consistent format +-- of your choosing. +-- +-- Originally designed by John Hughes's and Simon Peyton Jones's. +-- +-- Marking added by Andy Gill, Oct 08. +-- +-- For more information you can refer to the +-- that +-- serves as the basis for this libraries design: +-- /The Design -- of a Pretty-printing Library/ by John Hughes, in Advanced +-- Functional Programming, 1995 +-- +----------------------------------------------------------------------------- + +module Text.PrettyPrint.MarkedHughesPJ ( + + -- * The document type + Doc, -- Type synonym + MDoc, -- Abstract + TextDetails(..), + + -- * Constructing documents + + -- ** Converting values into documents + char, text, ptext, sizedText, zeroWidthText, + int, integer, float, double, rational, + + -- ** Simple derived documents + semi, comma, colon, space, equals, + lparen, rparen, lbrack, rbrack, lbrace, rbrace, + + -- ** Wrapping documents in delimiters + parens, brackets, braces, quotes, doubleQuotes, + maybeParens, maybeBrackets, maybeBraces, maybeQuotes, maybeDoubleQuotes, + + -- ** Combining documents + empty, + (<>), (<+>), hcat, hsep, + ($$), ($+$), vcat, + sep, cat, + fsep, fcat, + nest, + hang, punctuate, + + -- * Predicates on documents + isEmpty, + + -- * Utility functions for documents + first, reduceDoc, + + -- * Rendering documents + + -- ** Default rendering + render, + + -- ** Rendering with a particular style + Style(..), + style, + renderStyle, + Mode(..), + + -- ** General rendering + fullRender, + + -- ** Markup extension + mark + ) where + +import Control.DeepSeq ( NFData(rnf) ) +import Data.Function ( on ) +#if __GLASGOW_HASKELL__ < 709 +import Data.Monoid ( Monoid(mempty, mappend) ) +#endif +import Data.String ( IsString(fromString) ) + +import GHC.Generics + +-- --------------------------------------------------------------------------- +-- The MDoc calculus + +{- +Laws for $$ +~~~~~~~~~~~ + (x $$ y) $$ z = x $$ (y $$ z) + empty $$ x = x + x $$ empty = x + + ...ditto $+$... + +Laws for <> +~~~~~~~~~~~ + (x <> y) <> z = x <> (y <> z) + empty <> x = empty + x <> empty = x + + ...ditto <+>... + +Laws for text +~~~~~~~~~~~~~ + text s <> text t = text (s++t) + text "" <> x = x, if x non-empty + +** because of law n6, t2 only holds if x doesn't +** start with `nest'. + + +Laws for nest +~~~~~~~~~~~~~ + nest 0 x = x + nest k (nest k' x) = nest (k+k') x + nest k (x <> y) = nest k x <> nest k y + nest k (x $$ y) = nest k x $$ nest k y + nest k empty = empty + x <> nest k y = x <> y, if x non-empty + +** Note the side condition on ! It is this that +** makes it OK for empty to be a left unit for <>. + +Miscellaneous +~~~~~~~~~~~~~ + (text s <> x) $$ y = text s <> ((text "" <> x) $$ + nest (-length s) y) + + (x $$ y) <> z = x $$ (y <> z) + if y non-empty + + +Laws for list versions +~~~~~~~~~~~~~~~~~~~~~~ + sep (ps++[empty]++qs) = sep (ps ++ qs) + ...ditto hsep, hcat, vcat, fill... + + nest k (sep ps) = sep (map (nest k) ps) + ...ditto hsep, hcat, vcat, fill... + +Laws for oneLiner +~~~~~~~~~~~~~~~~~ + oneLiner (nest k p) = nest k (oneLiner p) + oneLiner (x <> y) = oneLiner x <> oneLiner y + +You might think that the following verion of would +be neater: + +<3 NO> (text s <> x) $$ y = text s <> ((empty <> x)) $$ + nest (-length s) y) + +But it doesn't work, for if x=empty, we would have + + text s $$ y = text s <> (empty $$ nest (-length s) y) + = text s <> nest (-length s) y +-} + +-- --------------------------------------------------------------------------- +-- Operator fixity + +infixl 6 <> +infixl 6 <+> +infixl 5 $$, $+$ + +-- --------------------------------------------------------------------------- +-- The MDoc data type + +-- An Doc is a Marked Doc (MDoc) with no interesting markings. +type Doc = MDoc () + +-- | The abstract type of documents. +-- An MDoc represents a *set* of layouts. A MDoc with +-- no occurrences of Union or NoDoc represents just one layout. +data MDoc a + = Empty -- empty + | NilAbove (MDoc a) -- text "" $$ x + | TextBeside !(TextDetails a) {-# UNPACK #-} !Int (MDoc a) -- text s <> x + | Nest {-# UNPACK #-} !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 +#if __GLASGOW_HASKELL__ >= 701 + deriving (Generic) +#endif + +{- +Here are the invariants: + +1) The argument of NilAbove is never Empty. Therefore + a NilAbove occupies at least two lines. + +2) The argument of @TextBeside@ is never @Nest@. + +3) The layouts of the two arguments of @Union@ both flatten to the same + string. + +4) The arguments of @Union@ are either @TextBeside@, or @NilAbove@. + +5) A @NoDoc@ may only appear on the first line of the left argument of an + union. Therefore, the right argument of an union can never be equivalent + to the empty set (@NoDoc@). + +6) An empty document is always represented by @Empty@. It can't be + hidden inside a @Nest@, or a @Union@ of two @Empty@s. + +7) The first line of every layout in the left argument of @Union@ is + longer than the first line of any layout in the right argument. + (1) ensures that the left argument has a first line. In view of + (3), this invariant means that the right argument must have at + least two lines. + +Notice the difference between + * NoDoc (no documents) + * Empty (one empty document; no height and no width) + * text "" (a document containing the empty string; + one line high, but has no width) +-} + + +-- | RDoc is a "reduced GDoc", guaranteed not to have a top-level Above or Beside. +type RDoc a = MDoc a + +-- | The TextDetails data type +-- +-- A TextDetails represents a fragment of text that will be +-- output at some point. +data TextDetails a = Chr {-# UNPACK #-} !Char -- ^ A single Char fragment + | Str String -- ^ A whole String fragment + | PStr String -- ^ Used to represent a Fast String fragment + -- but now deprecated and identical to the + -- Str constructor. + | Mark a +#if __GLASGOW_HASKELL__ >= 701 + deriving (Show, Eq, Generic) +#endif + +-- Combining @MDoc@ values +instance Monoid (MDoc a) where + mempty = empty + mappend = (<>) + +instance IsString (MDoc a) where + fromString = text + +instance Show (MDoc a) where + showsPrec _ doc cont = fullRender (mode style) (lineLength style) + (ribbonsPerLine style) + txtPrinter cont doc + +instance Eq (MDoc a) where + (==) = (==) `on` render + +instance NFData a => NFData (MDoc a) where + rnf Empty = () + rnf (NilAbove d) = rnf d + rnf (TextBeside td i d) = rnf td `seq` rnf i `seq` rnf d + rnf (Nest k d) = rnf k `seq` rnf d + rnf (Union ur ul) = rnf ur `seq` rnf ul + rnf NoDoc = () + rnf (Beside ld s rd) = rnf ld `seq` rnf s `seq` rnf rd + rnf (Above ud s ld) = rnf ud `seq` rnf s `seq` rnf ld + +instance NFData a => NFData (TextDetails a) where + rnf (Chr c) = rnf c + rnf (Str str) = rnf str + rnf (PStr str) = rnf str + rnf (Mark a) = rnf a + +-- --------------------------------------------------------------------------- +-- Values and Predicates on GDocs and TextDetails + +-- | A document of height and width 1, containing a literal character. +char :: Char -> MDoc a +char c = textBeside_ (Chr c) 1 Empty + +-- | A document of height 1 containing a literal string. +-- 'text' satisfies the following laws: +-- +-- * @'text' s '<>' 'text' t = 'text' (s'++'t)@ +-- +-- * @'text' \"\" '<>' x = x@, if @x@ non-empty +-- +-- The side condition on the last law is necessary because @'text' \"\"@ +-- has height 1, while 'empty' has no height. +text :: String -> MDoc a +text s = case length s of {sl -> textBeside_ (Str s) sl Empty} + +-- | Same as @text@. Used to be used for Bytestrings. +ptext :: String -> MDoc a +ptext s = case length s of {sl -> textBeside_ (PStr s) sl Empty} + +-- | Some text with any width. (@text s = sizedText (length s) s@) +sizedText :: Int -> String -> MDoc a +sizedText l s = textBeside_ (Str s) l Empty + +-- | Some text, but without any width. Use for non-printing text +-- such as a HTML or Latex tags +zeroWidthText :: String -> MDoc a +zeroWidthText = sizedText 0 + +-- | The empty document, with no height and no width. +-- 'empty' is the identity for '<>', '<+>', '$$' and '$+$', and anywhere +-- in the argument list for 'sep', 'hcat', 'hsep', 'vcat', 'fcat' etc. +empty :: MDoc a +empty = Empty + +-- | Returns 'True' if the document is empty +isEmpty :: MDoc a -> Bool +isEmpty Empty = True +isEmpty _ = False + +-- | Produce spacing for indenting the amount specified. +-- +-- an old version inserted tabs being 8 columns apart in the output. +indent :: Int -> String +indent !n = replicate n ' ' + +{- +Q: What is the reason for negative indentation (i.e. argument to indent + is < 0) ? + +A: +This indicates an error in the library client's code. +If we compose a <> b, and the first line of b is more indented than some +other lines of b, the law (<> eats nests) may cause the pretty +printer to produce an invalid layout: + +doc |0123345 +------------------ +d1 |a...| +d2 |...b| + |c...| + +d1<>d2 |ab..| + c|....| + +Consider a <> b, let `s' be the length of the last line of `a', `k' the +indentation of the first line of b, and `k0' the indentation of the +left-most line b_i of b. + +The produced layout will have negative indentation if `k - k0 > s', as +the first line of b will be put on the (s+1)th column, effectively +translating b horizontally by (k-s). Now if the i^th line of b has an +indentation k0 < (k-s), it is translated out-of-page, causing +`negative indentation'. +-} + + +semi :: 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 +semi = char ';' +comma = char ',' +colon = char ':' +space = char ' ' +equals = char '=' +lparen = char '(' +rparen = char ')' +lbrack = char '[' +rbrack = char ']' +lbrace = char '{' +rbrace = char '}' + +spaceText, nlText :: TextDetails a +spaceText = Chr ' ' +nlText = Chr '\n' + +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)@ +int n = text (show n) +integer n = text (show n) +float n = text (show n) +double n = text (show n) +rational n = text (show n) + +parens :: 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 @\"...\"@ +quotes p = char '\'' <> p <> char '\'' +doubleQuotes p = char '"' <> p <> char '"' +parens p = char '(' <> p <> char ')' +brackets p = char '[' <> p <> char ']' +braces p = char '{' <> p <> char '}' + +-- | Apply 'parens' to 'MDoc' if boolean is true. +maybeParens :: Bool -> MDoc a -> MDoc a +maybeParens False = id +maybeParens True = parens + +-- | Apply 'brackets' to 'MDoc' if boolean is true. +maybeBrackets :: Bool -> MDoc a -> MDoc a +maybeBrackets False = id +maybeBrackets True = brackets + +-- | Apply 'braces' to 'MDoc' if boolean is true. +maybeBraces :: Bool -> MDoc a -> MDoc a +maybeBraces False = id +maybeBraces True = braces + +-- | Apply 'quotes' to 'MDoc' if boolean is true. +maybeQuotes :: Bool -> MDoc a -> MDoc a +maybeQuotes False = id +maybeQuotes True = quotes + +-- | Apply 'doubleQuotes' to 'MDoc' if boolean is true. +maybeDoubleQuotes :: Bool -> MDoc a -> MDoc a +maybeDoubleQuotes False = id +maybeDoubleQuotes True = doubleQuotes + +-- --------------------------------------------------------------------------- +-- Structural operations on GDocs + +-- | Perform some simplification of a built up @GDoc@. +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 + +-- | List version of '<>'. +hcat :: [MDoc a] -> MDoc a +hcat = snd . reduceHoriz . foldr (\p q -> Beside p False q) empty + +-- | List version of '<+>'. +hsep :: [MDoc a] -> MDoc a +hsep = snd . reduceHoriz . foldr (\p q -> Beside p True q) empty + +-- | List version of '$$'. +vcat :: [MDoc a] -> MDoc a +vcat = snd . reduceVert . foldr (\p q -> Above p False q) empty + +-- | Nest (or indent) a document by a given number of positions +-- (which may also be negative). 'nest' satisfies the laws: +-- +-- * @'nest' 0 x = x@ +-- +-- * @'nest' k ('nest' k' x) = 'nest' (k+k') x@ +-- +-- * @'nest' k (x '<>' y) = 'nest' k z '<>' 'nest' k y@ +-- +-- * @'nest' k (x '$$' y) = 'nest' k x '$$' 'nest' k y@ +-- +-- * @'nest' k 'empty' = 'empty'@ +-- +-- * @x '<>' 'nest' k y = x '<>' y@, if @x@ non-empty +-- +-- The side condition on the last law is needed because +-- 'empty' is a left identity for '<>'. +nest :: Int -> MDoc a -> MDoc a +nest k p = mkNest k (reduceDoc p) + +-- | @hang d1 n d2 = sep [d1, nest n d2]@ +hang :: MDoc a -> Int -> MDoc a -> MDoc a +hang d1 n d2 = sep [d1, nest n d2] + +-- | @punctuate p [d1, ... dn] = [d1 \<> p, d2 \<> p, ... dn-1 \<> p, dn]@ +punctuate :: MDoc a -> [MDoc a] -> [MDoc a] +punctuate _ [] = [] +punctuate p (x:xs) = go x xs + where go y [] = [y] + go y (z:zs) = (y <> p) : go z zs + +-- mkNest checks for Nest's invariant that it doesn't have an Empty inside it +mkNest :: Int -> MDoc a -> MDoc a +mkNest k _ | k `seq` False = undefined +mkNest k (Nest k1 p) = mkNest (k + k1) p +mkNest _ NoDoc = NoDoc +mkNest _ Empty = Empty +mkNest 0 p = p +mkNest k p = nest_ k p + +-- mkUnion checks for an empty document +mkUnion :: MDoc a -> MDoc a -> MDoc a +mkUnion Empty _ = Empty +mkUnion p q = p `union_` q + +data IsEmpty = IsEmpty | NotEmpty + +reduceHoriz :: MDoc a -> (IsEmpty, MDoc a) +reduceHoriz (Beside p g q) = eliminateEmpty Beside (snd (reduceHoriz p)) g (reduceHoriz q) +reduceHoriz doc = (NotEmpty, doc) + +reduceVert :: MDoc a -> (IsEmpty, MDoc a) +reduceVert (Above p g q) = eliminateEmpty Above (snd (reduceVert p)) g (reduceVert q) +reduceVert doc = (NotEmpty, doc) + +{-# INLINE eliminateEmpty #-} +eliminateEmpty :: + (MDoc a -> Bool -> MDoc a -> MDoc a) -> + MDoc a -> Bool -> (IsEmpty, MDoc a) -> (IsEmpty, MDoc a) +eliminateEmpty _ Empty _ q = q +eliminateEmpty cons p g q = + (NotEmpty, + -- We're not empty whether or not q is empty, so for laziness-sake, + -- after checking that p isn't empty, we put the NotEmpty result + -- outside independent of q. This allows reduceAB to immediately + -- return the appropriate constructor (Above or Beside) without + -- forcing the entire nested MDoc. This allows the foldr in vcat, + -- hsep, and hcat to be lazy on its second argument, avoiding a + -- stack overflow. + case q of + (NotEmpty, q') -> cons p g q' + (IsEmpty, _) -> p) + +nilAbove_ :: RDoc a -> RDoc a +nilAbove_ = NilAbove + +-- Arg of a TextBeside is always an RDoc +textBeside_ :: TextDetails a -> Int -> RDoc a -> RDoc a +textBeside_ = TextBeside + +nest_ :: Int -> RDoc a -> RDoc a +nest_ = Nest + +union_ :: RDoc a -> RDoc a -> RDoc a +union_ = Union + + +-- --------------------------------------------------------------------------- +-- Vertical composition @$$@ + +-- | Above, except that if the last line of the first argument stops +-- at least one position before the first line of the second begins, +-- these two lines are overlapped. For example: +-- +-- > text "hi" $$ nest 5 (text "there") +-- +-- lays out as +-- +-- > hi there +-- +-- rather than +-- +-- > hi +-- > there +-- +-- '$$' is associative, with identity 'empty', and also satisfies +-- +-- * @(x '$$' y) '<>' z = x '$$' (y '<>' z)@, if @y@ non-empty. +-- +($$) :: MDoc a -> MDoc a -> MDoc a +p $$ q = above_ p False q + +-- | Above, with no overlapping. +-- '$+$' is associative, with identity 'empty'. +($+$) :: MDoc a -> MDoc a -> MDoc a +p $+$ q = above_ p True q + +above_ :: MDoc a -> Bool -> MDoc a -> MDoc a +above_ p _ Empty = p +above_ Empty _ q = q +above_ p g q = Above p g 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) + +-- Specfication: aboveNest p g k q = p $g$ (nest k q) +aboveNest :: RDoc a -> Bool -> Int -> RDoc a -> RDoc a +aboveNest _ _ k _ | k `seq` False = undefined +aboveNest NoDoc _ _ _ = NoDoc +aboveNest (p1 `Union` p2) g k q = aboveNest p1 g k q `union_` + aboveNest p2 g k q + +aboveNest Empty _ k q = mkNest k q +aboveNest (Nest k1 p) g k q = nest_ k1 (aboveNest p g (k - k1) q) + -- p can't be Empty, so no need for mkNest + +aboveNest (NilAbove p) g k q = nilAbove_ (aboveNest p g k q) +aboveNest (TextBeside s sl p) g k q = textBeside_ s sl rest + where + !k1 = k - sl + rest = case p of + Empty -> nilAboveNest g k1 q + _ -> aboveNest p g k1 q +aboveNest (Above {}) _ _ _ = error "aboveNest Above" +aboveNest (Beside {}) _ _ _ = error "aboveNest Beside" + +-- Specification: text s <> nilaboveNest g k q +-- = text s <> (text "" $g$ nest k q) +nilAboveNest :: Bool -> Int -> RDoc a -> RDoc a +nilAboveNest _ k _ | k `seq` False = undefined +nilAboveNest _ _ Empty = Empty + -- Here's why the "text s <>" is in the spec! +nilAboveNest g k (Nest k1 q) = nilAboveNest g (k + k1) q +nilAboveNest g k q | not g && k > 0 -- No newline if no overlap + = textBeside_ (Str (indent k)) k q + | otherwise -- Put them really above + = nilAbove_ (mkNest k q) + + +-- --------------------------------------------------------------------------- +-- Horizontal composition @<>@ + +-- We intentionally avoid Data.Monoid.(<>) here due to interactions of +-- Data.Monoid.(<>) and (<+>). See +-- http://www.haskell.org/pipermail/libraries/2011-November/017066.html + +-- | Beside. +-- '<>' is associative, with identity 'empty'. +(<>) :: MDoc a -> MDoc a -> MDoc a +p <> q = beside_ p False q + +-- | Beside, separated by space, unless one of the arguments is 'empty'. +-- '<+>' is associative, with identity 'empty'. +(<+>) :: MDoc a -> MDoc a -> MDoc a +p <+> q = beside_ p True q + +beside_ :: MDoc a -> Bool -> MDoc a -> MDoc a +beside_ p _ Empty = p +beside_ Empty _ q = q +beside_ p g q = Beside p g q + +-- Specification: beside g p q = p q +beside :: MDoc a -> Bool -> RDoc a -> RDoc a +beside NoDoc _ _ = NoDoc +beside (p1 `Union` p2) g q = beside p1 g q `union_` beside p2 g q +beside Empty _ q = q +beside (Nest k p) g q = nest_ k $! beside p g q +beside p@(Beside p1 g1 q1) g2 q2 + | g1 == g2 = beside p1 g1 $! beside q1 g2 q2 + | otherwise = beside (reduceDoc p) g2 q2 +beside p@(Above{}) g q = let !d = reduceDoc p in beside d g q +beside (NilAbove p) g q = nilAbove_ $! beside p g q +beside (TextBeside s sl p) g q = textBeside_ s sl $! rest + where + rest = case p of + Empty -> nilBeside g q + _ -> beside p g q + +-- Specification: text "" <> nilBeside g p +-- = text "" p +nilBeside :: Bool -> RDoc a -> RDoc a +nilBeside _ Empty = Empty -- Hence the text "" in the spec +nilBeside g (Nest _ p) = nilBeside g p +nilBeside g p | g = textBeside_ spaceText 1 p + | otherwise = p + + +-- --------------------------------------------------------------------------- +-- Separate, @sep@ + +-- Specification: sep ps = oneLiner (hsep ps) +-- `union` +-- vcat ps + +-- | Either 'hsep' or 'vcat'. +sep :: [MDoc a] -> MDoc a +sep = sepX True -- Separate with spaces + +-- | Either 'hcat' or 'vcat'. +cat :: [MDoc a] -> MDoc a +cat = sepX False -- Don't + +sepX :: Bool -> [MDoc a] -> MDoc a +sepX _ [] = empty +sepX x (p:ps) = sep1 x (reduceDoc p) 0 ps + + +-- Specification: sep1 g k ys = sep (x : map (nest k) ys) +-- = oneLiner (x nest k (hsep ys)) +-- `union` x $$ nest k (vcat ys) +sep1 :: Bool -> RDoc a -> Int -> [MDoc a] -> RDoc a +sep1 _ _ k _ | k `seq` False = undefined +sep1 _ NoDoc _ _ = NoDoc +sep1 g (p `Union` q) k ys = sep1 g p k ys `union_` + aboveNest q False k (reduceDoc (vcat ys)) + +sep1 g Empty k ys = mkNest k (sepX g ys) +sep1 g (Nest n p) k ys = nest_ n (sep1 g p (k - n) ys) + +sep1 _ (NilAbove p) k ys = nilAbove_ + (aboveNest p False k (reduceDoc (vcat ys))) +sep1 g (TextBeside s sl p) k ys = textBeside_ s sl (sepNB g p (k - sl) ys) +sep1 _ (Above {}) _ _ = error "sep1 Above" +sep1 _ (Beside {}) _ _ = error "sep1 Beside" + +-- Specification: sepNB p k ys = sep1 (text "" <> p) k ys +-- Called when we have already found some text in the first item +-- We have to eat up nests +sepNB :: Bool -> MDoc a -> Int -> [MDoc a] -> MDoc a +sepNB g (Nest _ p) k ys + = sepNB g p k ys -- Never triggered, because of invariant (2) +sepNB g Empty k ys + = oneLiner (nilBeside g (reduceDoc rest)) `mkUnion` + -- XXX: TODO: PRETTY: Used to use True here (but GHC used False...) + nilAboveNest False k (reduceDoc (vcat ys)) + where + rest | g = hsep ys + | otherwise = hcat ys +sepNB g p k ys + = sep1 g p k ys + + +-- --------------------------------------------------------------------------- +-- @fill@ + +-- | \"Paragraph fill\" version of 'cat'. +fcat :: [MDoc a] -> MDoc a +fcat = fill False + +-- | \"Paragraph fill\" version of 'sep'. +fsep :: [MDoc a] -> MDoc a +fsep = fill True + +-- Specification: +-- +-- fill g docs = fillIndent 0 docs +-- +-- fillIndent k [] = [] +-- fillIndent k [p] = p +-- fillIndent k (p1:p2:ps) = +-- oneLiner p1 fillIndent (k + length p1 + g ? 1 : 0) +-- (remove_nests (oneLiner p2) : ps) +-- `Union` +-- (p1 $*$ nest (-k) (fillIndent 0 ps)) +-- +-- $*$ is defined for layouts (not Docs) as +-- layout1 $*$ layout2 | hasMoreThanOneLine layout1 = layout1 $$ layout2 +-- | otherwise = layout1 $+$ layout2 + +fill :: Bool -> [MDoc a] -> RDoc a +fill _ [] = empty +fill g (p:ps) = fill1 g (reduceDoc p) 0 ps + +fill1 :: Bool -> RDoc a -> Int -> [MDoc a] -> MDoc a +fill1 _ _ k _ | k `seq` False = undefined +fill1 _ NoDoc _ _ = NoDoc +fill1 g (p `Union` q) k ys = fill1 g p k ys `union_` + aboveNest q False k (fill g ys) +fill1 g Empty k ys = mkNest k (fill g ys) +fill1 g (Nest n p) k ys = nest_ n (fill1 g p (k - n) ys) +fill1 g (NilAbove p) k ys = nilAbove_ (aboveNest p False k (fill g ys)) +fill1 g (TextBeside s sl p) k ys = textBeside_ s sl (fillNB g p (k - sl) ys) +fill1 _ (Above {}) _ _ = error "fill1 Above" +fill1 _ (Beside {}) _ _ = error "fill1 Beside" + +fillNB :: Bool -> MDoc a -> Int -> [MDoc a] -> MDoc a +fillNB _ _ k _ | k `seq` False = undefined +fillNB g (Nest _ p) k ys = fillNB g p k ys + -- Never triggered, because of invariant (2) +fillNB _ Empty _ [] = Empty +fillNB g Empty k (Empty:ys) = fillNB g Empty k ys +fillNB g Empty k (y:ys) = fillNBE g k y ys +fillNB g p k ys = fill1 g p k ys + + +fillNBE :: Bool -> Int -> MDoc a -> [MDoc a] -> MDoc a +fillNBE g k y ys + = nilBeside g (fill1 g ((elideNest . oneLiner . reduceDoc) y) k' ys) + -- XXX: TODO: PRETTY: Used to use True here (but GHC used False...) + `mkUnion` nilAboveNest False k (fill g (y:ys)) + where k' = if g then k - 1 else k + +elideNest :: MDoc a -> MDoc a +elideNest (Nest _ d) = d +elideNest d = d + + +-- --------------------------------------------------------------------------- +-- Selecting the best layout + +best :: Int -- Line length + -> Int -- Ribbon length + -> RDoc a + -> RDoc a -- No unions in here! +best w0 r = get w0 + where + get w _ | w == 0 && False = undefined + get _ Empty = Empty + get _ NoDoc = NoDoc + get w (NilAbove p) = nilAbove_ (get w p) + get w (TextBeside s sl p) = textBeside_ s sl (get1 w sl p) + get w (Nest k p) = nest_ k (get (w - k) p) + get w (p `Union` q) = nicest w r (get w p) (get w q) + get _ (Above {}) = error "best get Above" + get _ (Beside {}) = error "best get Beside" + + get1 w _ _ | w == 0 && False = undefined + get1 _ _ Empty = Empty + get1 _ _ NoDoc = NoDoc + get1 w sl (NilAbove p) = nilAbove_ (get (w - sl) p) + get1 w sl (TextBeside t tl p) = textBeside_ t tl (get1 w (sl + tl) p) + get1 w sl (Nest _ p) = get1 w sl p + get1 w sl (p `Union` q) = nicest1 w r sl (get1 w sl p) + (get1 w sl q) + get1 _ _ (Above {}) = error "best get1 Above" + get1 _ _ (Beside {}) = error "best get1 Beside" + +nicest :: Int -> Int -> MDoc a -> MDoc a -> MDoc a +nicest !w !r = nicest1 w r 0 + +nicest1 :: Int -> Int -> Int -> MDoc a -> MDoc a -> MDoc a +nicest1 !w !r !sl p q | fits ((w `min` r) - sl) p = p + | otherwise = q + +fits :: Int -- Space available + -> MDoc a + -> Bool -- True if *first line* of MDoc fits in space available +fits n _ | n < 0 = False +fits _ NoDoc = False +fits _ Empty = True +fits _ (NilAbove _) = True +fits n (TextBeside _ sl p) = fits (n - sl) p +fits _ (Above {}) = error "fits Above" +fits _ (Beside {}) = error "fits Beside" +fits _ (Union {}) = error "fits Union" +fits _ (Nest {}) = error "fits Nest" + +-- | @first@ returns its first argument if it is non-empty, otherwise its second. +first :: MDoc a -> MDoc a -> MDoc a +first p q | nonEmptySet p = p -- unused, because (get OneLineMode) is unused + | otherwise = q + +nonEmptySet :: MDoc a -> Bool +nonEmptySet NoDoc = False +nonEmptySet (_ `Union` _) = True +nonEmptySet Empty = True +nonEmptySet (NilAbove _) = True +nonEmptySet (TextBeside _ _ p) = nonEmptySet p +nonEmptySet (Nest _ p) = nonEmptySet p +nonEmptySet (Above {}) = error "nonEmptySet Above" +nonEmptySet (Beside {}) = error "nonEmptySet Beside" + +-- @oneLiner@ returns the one-line members of the given set of @GDoc@s. +oneLiner :: MDoc a -> MDoc a +oneLiner NoDoc = NoDoc +oneLiner Empty = Empty +oneLiner (NilAbove _) = NoDoc +oneLiner (TextBeside s sl p) = textBeside_ s sl (oneLiner p) +oneLiner (Nest k p) = nest_ k (oneLiner p) +oneLiner (p `Union` _) = oneLiner p +oneLiner (Above {}) = error "oneLiner Above" +oneLiner (Beside {}) = error "oneLiner Beside" + + +-- --------------------------------------------------------------------------- +-- Rendering + +-- | A rendering style. +data Style + = Style { mode :: Mode -- ^ The rendering mode + , lineLength :: Int -- ^ Length of line, in chars + , ribbonsPerLine :: Float -- ^ Ratio of line length to ribbon length + } +#if __GLASGOW_HASKELL__ >= 701 + deriving (Show, Eq, Generic) +#endif + +-- | The default style (@mode=PageMode, lineLength=100, ribbonsPerLine=1.5@). +style :: Style +style = Style { lineLength = 100, ribbonsPerLine = 1.5, mode = PageMode } + +-- | Rendering mode. +data Mode = PageMode -- ^ Normal + | ZigZagMode -- ^ With zig-zag cuts + | LeftMode -- ^ No indentation, infinitely long lines + | OneLineMode -- ^ All on one line +#if __GLASGOW_HASKELL__ >= 701 + deriving (Show, Eq, Generic) +#endif + +-- | Render the @MDoc@ to a String using the default @Style@. +render :: MDoc a -> String +render = fullRender (mode style) (lineLength style) (ribbonsPerLine style) + txtPrinter "" + +-- | Render the @MDoc@ to a String using the given @Style@. +renderStyle :: Style -> MDoc a -> String +renderStyle s = fullRender (mode s) (lineLength s) (ribbonsPerLine s) + txtPrinter "" + +-- | Default TextDetails printer +txtPrinter :: TextDetails a -> String -> String +txtPrinter (Chr c) s = c:s +txtPrinter (Str s1) s2 = s1 ++ s2 +txtPrinter (PStr s1) s2 = s1 ++ s2 +txtPrinter (Mark _) s2 = s2 + +-- | 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 +fullRender OneLineMode _ _ txt end doc + = easyDisplay spaceText (\_ y -> y) txt end (reduceDoc doc) +fullRender LeftMode _ _ txt end doc + = easyDisplay nlText first txt end (reduceDoc doc) + +fullRender m lineLen ribbons txt rest doc + = display m lineLen ribbonLen txt rest doc' + where + doc' = best bestLineLen ribbonLen (reduceDoc doc) + + bestLineLen, ribbonLen :: Int + ribbonLen = round (fromIntegral lineLen / ribbons) + bestLineLen = case m of + ZigZagMode -> maxBound + _ -> lineLen + +easyDisplay :: TextDetails b + -> (MDoc b -> MDoc b -> MDoc b) + -> (TextDetails b -> a -> a) + -> a + -> MDoc b + -> a +easyDisplay nlSpaceText choose txt end + = lay + where + lay NoDoc = error "easyDisplay: NoDoc" + lay (Union p q) = lay (choose p q) + lay (Nest _ p) = lay p + lay Empty = end + lay (NilAbove p) = nlSpaceText `txt` lay p + lay (TextBeside s _ p) = s `txt` lay p + lay (Above {}) = error "easyDisplay Above" + lay (Beside {}) = error "easyDisplay Beside" + +display :: Mode -> Int -> Int -> (TextDetails b -> a -> a) -> a -> MDoc b -> a +display m !page_width !ribbon_width txt end doc + = case page_width - ribbon_width of { gap_width -> + case gap_width `quot` 2 of { shift -> + let + lay k _ | k `seq` False = undefined + lay k (Nest k1 p) = lay (k + k1) p + lay _ Empty = end + lay k (NilAbove p) = nlText `txt` lay k p + lay k (TextBeside s sl p) + = case m of + ZigZagMode | k >= gap_width + -> nlText `txt` ( + Str (replicate shift '/') `txt` ( + nlText `txt` + lay1 (k - shift) s sl p )) + + | k < 0 + -> nlText `txt` ( + Str (replicate shift '\\') `txt` ( + nlText `txt` + lay1 (k + shift) s sl p )) + + _ -> lay1 k s sl p + lay _ (Above {}) = error "display lay Above" + lay _ (Beside {}) = error "display lay Beside" + lay _ NoDoc = error "display lay NoDoc" + lay _ (Union {}) = error "display lay Union" + + lay1 !k s !sl p = let !r = k + sl + in Str (indent k) `txt` (s `txt` lay2 r p) + + lay2 k _ | k `seq` False = undefined + lay2 k (NilAbove p) = nlText `txt` lay k p + lay2 k (TextBeside s sl p) = s `txt` lay2 (k + sl) p + lay2 k (Nest _ p) = lay2 k p + lay2 _ Empty = end + lay2 _ (Above {}) = error "display lay2 Above" + lay2 _ (Beside {}) = error "display lay2 Beside" + lay2 _ NoDoc = error "display lay2 NoDoc" + lay2 _ (Union {}) = error "display lay2 Union" + in + lay 0 doc + }} + +------------------------------------------------------------------------------ + +-- | mark inserts a zero width mark into the output document + +mark :: a -> MDoc a +mark m = textBeside_ (Mark m) 0 Empty diff --git a/src/Text/PrettyPrint/MarkedHughesPJClass.hs b/src/Text/PrettyPrint/MarkedHughesPJClass.hs new file mode 100644 --- /dev/null +++ b/src/Text/PrettyPrint/MarkedHughesPJClass.hs @@ -0,0 +1,146 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 701 +{-# LANGUAGE Safe #-} +#endif + +----------------------------------------------------------------------------- +-- | +-- Module : Text.PrettyPrint.HughesPJClass +-- Copyright : (c) Lennart Augustsson 2014 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : David Terei +-- Stability : stable +-- Portability : portable +-- +-- Pretty printing class, simlar to 'Show' but nicer looking. +-- +-- Note that the precedence level is a 'Rational' so there is an unlimited +-- number of levels. This module re-exports 'Text.PrettyPrint.HughesPJ'. +-- +----------------------------------------------------------------------------- + +module Text.PrettyPrint.MarkedHughesPJClass ( + -- * Pretty typeclass + Pretty(..), + + PrettyLevel(..), prettyNormal, + prettyShow, prettyParen, + + -- re-export HughesPJ + module Text.PrettyPrint.MarkedHughesPJ + ) where + +import Text.PrettyPrint.MarkedHughesPJ + +-- | Level of detail in the pretty printed output. +-- Level 0 is the least detail. +newtype PrettyLevel = PrettyLevel Int + deriving (Eq, Ord, Show) + +-- | The "normal" (Level 0) of detail. +prettyNormal :: PrettyLevel +prettyNormal = PrettyLevel 0 + +-- | Pretty printing class. The precedence level is used in a similar way as in +-- the 'Show' class. Minimal complete definition is either 'pPrintPrec' or +-- 'pPrint'. +class Pretty a where + pPrintPrec :: PrettyLevel -> Rational -> a -> MDoc b + pPrintPrec _ _ = pPrint + + pPrint :: a -> MDoc b + pPrint = pPrintPrec prettyNormal 0 + + pPrintList :: PrettyLevel -> [a] -> MDoc b + pPrintList l = brackets . fsep . punctuate comma . map (pPrintPrec l 0) + +#if __GLASGOW_HASKELL__ >= 708 + {-# MINIMAL pPrintPrec | pPrint #-} +#endif + +-- | Pretty print a value with the 'prettyNormal' level. +prettyShow :: (Pretty a) => a -> String +prettyShow = render . pPrint + +pPrint0 :: (Pretty a) => PrettyLevel -> a -> MDoc b +pPrint0 l = pPrintPrec l 0 + +appPrec :: Rational +appPrec = 10 + +-- | Parenthesize an value if the boolean is true. +{-# DEPRECATED prettyParen "Please use 'maybeParens' instead" #-} +prettyParen :: Bool -> MDoc a -> MDoc a +prettyParen = maybeParens + +-- Various Pretty instances +instance Pretty Int where pPrint = int + +instance Pretty Integer where pPrint = integer + +instance Pretty Float where pPrint = float + +instance Pretty Double where pPrint = double + +instance Pretty () where pPrint _ = text "()" + +instance Pretty Bool where pPrint = text . show + +instance Pretty Ordering where pPrint = text . show + +instance Pretty Char where + pPrint = char + pPrintList _ = text . show + +instance (Pretty a) => Pretty (Maybe a) where + pPrintPrec _ _ Nothing = text "Nothing" + pPrintPrec l p (Just x) = + prettyParen (p > appPrec) $ text "Just" <+> pPrintPrec l (appPrec+1) x + +instance (Pretty a, Pretty b) => Pretty (Either a b) where + pPrintPrec l p (Left x) = + prettyParen (p > appPrec) $ text "Left" <+> pPrintPrec l (appPrec+1) x + pPrintPrec l p (Right x) = + prettyParen (p > appPrec) $ text "Right" <+> pPrintPrec l (appPrec+1) x + +instance (Pretty a) => Pretty [a] where + pPrintPrec l _ = pPrintList l + +instance (Pretty a, Pretty b) => Pretty (a, b) where + pPrintPrec l _ (a, b) = + parens $ fsep $ punctuate comma [pPrint0 l a, pPrint0 l b] + +instance (Pretty a, Pretty b, Pretty c) => Pretty (a, b, c) where + pPrintPrec l _ (a, b, c) = + parens $ fsep $ punctuate comma [pPrint0 l a, pPrint0 l b, pPrint0 l c] + +instance (Pretty a, Pretty b, Pretty c, Pretty d) => Pretty (a, b, c, d) where + pPrintPrec l _ (a, b, c, d) = + parens $ fsep $ punctuate comma + [pPrint0 l a, pPrint0 l b, pPrint0 l c, pPrint0 l d] + +instance (Pretty a, Pretty b, Pretty c, Pretty d, Pretty e) => Pretty (a, b, c, d, e) where + pPrintPrec l _ (a, b, c, d, e) = + parens $ fsep $ punctuate comma + [pPrint0 l a, pPrint0 l b, pPrint0 l c, pPrint0 l d, pPrint0 l e] + +instance (Pretty a, Pretty b, Pretty c, Pretty d, Pretty e, Pretty f) => Pretty (a, b, c, d, e, f) where + pPrintPrec l _ (a, b, c, d, e, f) = + parens $ fsep $ punctuate comma + [pPrint0 l a, pPrint0 l b, pPrint0 l c, + pPrint0 l d, pPrint0 l e, pPrint0 l f] + +instance (Pretty a, Pretty b, Pretty c, Pretty d, Pretty e, Pretty f, Pretty g) => + Pretty (a, b, c, d, e, f, g) where + pPrintPrec l _ (a, b, c, d, e, f, g) = + parens $ fsep $ punctuate comma + [pPrint0 l a, pPrint0 l b, pPrint0 l c, + pPrint0 l d, pPrint0 l e, pPrint0 l f, pPrint0 l g] + +instance (Pretty a, Pretty b, Pretty c, Pretty d, Pretty e, Pretty f, Pretty g, Pretty h) => + Pretty (a, b, c, d, e, f, g, h) where + pPrintPrec l _ (a, b, c, d, e, f, g, h) = + parens $ fsep $ punctuate comma + [pPrint0 l a, pPrint0 l b, pPrint0 l c, + pPrint0 l d, pPrint0 l e, pPrint0 l f, pPrint0 l g, pPrint0 l h] diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,4 +1,4 @@ -module Main where +module Main (main) where import Text.PrettyPrint.MarkedHughesPJ hiding (Doc) @@ -29,15 +29,31 @@ scope :: MStyle -> Doc -> Doc scope s d = open s <> d <> close s +example1 :: Exp example1 = Var "abc" + +example2 :: Exp example2 = Var "cde" + +example3 :: Exp example3 = App example1 [example2] + +example4 :: Exp example4 = Lit 99 + +example5 :: Exp example5 = App example3 [example1,example4,example2,example1,example2,example4,example2] + +example6 :: Exp example6 = List [example1,example2,example3,example4,example5] + +example7 :: Exp example7 = App example3 [example6] + +example8 :: Exp example8 = App example4 [example4] +examples :: [Exp] examples = [ example1 , example2 , example3 @@ -48,6 +64,7 @@ , example8 ] +main :: IO () main = do putStrLn "
"
   sequence_ [ putStrLn $ render (pretty ex)
@@ -59,6 +76,7 @@
             ]
   putStrLn "
" +html_txt :: TextDetails Markup -> String -> String 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 @@ -69,7 +87,7 @@ html_txt (Mark (Open GREEN)) r = "" ++ r html_txt (Mark (Close GREEN)) r = "" ++ r +escape :: Char -> String escape '<' = "<" escape '>' = ">" escape c = [c] -