diff --git a/pretty.cabal b/pretty.cabal --- a/pretty.cabal +++ b/pretty.cabal @@ -1,5 +1,5 @@ name: pretty -version: 1.1.2.1 +version: 1.1.3.1 synopsis: Pretty-printing library description: This package contains a pretty-printing library, a set of API's @@ -31,7 +31,10 @@ Text.PrettyPrint Text.PrettyPrint.HughesPJ Text.PrettyPrint.HughesPJClass - build-depends: base >= 3 && < 5, + Text.PrettyPrint.Annotated + Text.PrettyPrint.Annotated.HughesPJ + Text.PrettyPrint.Annotated.HughesPJClass + build-depends: base >= 4.5 && < 5, deepseq >= 1.1, ghc-prim extensions: CPP, BangPatterns, DeriveGeneric @@ -41,7 +44,7 @@ type: exitcode-stdio-1.0 hs-source-dirs: tests src - build-depends: base >= 3 && < 5, + build-depends: base >= 4.5 && < 5, deepseq >= 1.1, ghc-prim, QuickCheck >= 2.5 && <3 @@ -55,7 +58,7 @@ UnitPP1 UnitT3911 extensions: CPP, BangPatterns, DeriveGeneric - include-dirs: src/Text/PrettyPrint + include-dirs: src/Text/PrettyPrint/Annotated -- Executable Bench1 -- main-is: Bench1.hs diff --git a/src/Text/PrettyPrint/Annotated.hs b/src/Text/PrettyPrint/Annotated.hs new file mode 100644 --- /dev/null +++ b/src/Text/PrettyPrint/Annotated.hs @@ -0,0 +1,78 @@ +#if __GLASGOW_HASKELL__ >= 701 +{-# LANGUAGE Safe #-} +#endif +----------------------------------------------------------------------------- +-- | +-- Module : Text.PrettyPrint.Annotated +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : David Terei +-- Stability : stable +-- Portability : portable +-- +-- Provides a collection of pretty printer combinators, a set of API's +-- that provides a way to easily print out text in a consistent format +-- of your choosing. +-- +-- This module should be used as opposed to the "Text.PrettyPrint.HughesPJ" +-- module. Both are equivalent though as this module simply re-exports the +-- other. +-- +----------------------------------------------------------------------------- + +module Text.PrettyPrint.Annotated ( + + -- * The document type + Doc, + + -- * Constructing documents + + -- ** Converting values into documents + char, text, ptext, sizedText, zeroWidthText, + int, integer, float, double, rational, + + -- ** Simple derived documents + semi, comma, colon, space, equals, + lparen, rparen, lbrack, rbrack, lbrace, rbrace, + + -- ** Wrapping documents in delimiters + parens, brackets, braces, quotes, doubleQuotes, + + -- ** Combining documents + empty, + (<>), (<+>), hcat, hsep, + ($$), ($+$), vcat, + sep, cat, + fsep, fcat, + nest, + hang, punctuate, + + -- ** Annotating documents + annotate, + + -- * Predicates on documents + isEmpty, + + -- * Rendering documents + + -- ** Default rendering + render, + + -- ** Annotation rendering + renderSpans, Span(..), + + -- ** Rendering with a particular style + Style(..), + style, + renderStyle, + + -- ** General rendering + fullRender, + fullRenderAnn, + Mode(..), TextDetails(..) + + ) where + +import Text.PrettyPrint.Annotated.HughesPJ + diff --git a/src/Text/PrettyPrint/Annotated/HughesPJ.hs b/src/Text/PrettyPrint/Annotated/HughesPJ.hs new file mode 100644 --- /dev/null +++ b/src/Text/PrettyPrint/Annotated/HughesPJ.hs @@ -0,0 +1,1158 @@ +{-# OPTIONS_HADDOCK not-home #-} +{-# LANGUAGE BangPatterns #-} +#if __GLASGOW_HASKELL__ >= 701 +{-# LANGUAGE Safe #-} +{-# LANGUAGE DeriveGeneric #-} +#endif + +----------------------------------------------------------------------------- +-- | +-- Module : Text.PrettyPrint.Annotated.HughesPJ +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : David Terei +-- Stability : stable +-- Portability : portable +-- +-- Provides a collection of pretty printer combinators, a set of API's +-- that provides a way to easily print out text in a consistent format +-- of your choosing. +-- +-- Originally designed by John Hughes's and Simon Peyton Jones's. +-- +-- For more information you can refer to the +-- that +-- serves as the basis for this libraries design: +-- /The Design -- of a Pretty-printing Library/ by John Hughes, in Advanced +-- Functional Programming, 1995 +-- +----------------------------------------------------------------------------- + +#ifndef TESTING +module Text.PrettyPrint.Annotated.HughesPJ ( + + -- * The document type + Doc, TextDetails(..), AnnotDetails(..), + + -- * Constructing documents + + -- ** Converting values into documents + char, text, ptext, sizedText, zeroWidthText, + int, integer, float, double, rational, + + -- ** Simple derived documents + semi, comma, colon, space, equals, + lparen, rparen, lbrack, rbrack, lbrace, rbrace, + + -- ** Wrapping documents in delimiters + parens, brackets, braces, quotes, doubleQuotes, + maybeParens, maybeBrackets, maybeBraces, maybeQuotes, maybeDoubleQuotes, + + -- ** Combining documents + empty, + (<>), (<+>), hcat, hsep, + ($$), ($+$), vcat, + sep, cat, + fsep, fcat, + nest, + hang, punctuate, + + -- ** Annotating documents + annotate, + + -- * Predicates on documents + isEmpty, + + -- * Utility functions for documents + first, reduceDoc, + + -- * Rendering documents + + -- ** Default rendering + render, + + -- ** Annotation rendering + renderSpans, Span(..), + renderDecorated, + renderDecoratedM, + + -- ** Rendering with a particular style + Style(..), + style, + renderStyle, + Mode(..), + + -- ** General rendering + fullRender, + fullRenderAnn + + ) where +#endif + +import Control.DeepSeq ( NFData(rnf) ) +import Data.Function ( on ) +#if __GLASGOW_HASKELL__ < 709 +import Data.Monoid ( Monoid(mempty, mappend) ) +#endif +import Data.String ( IsString(fromString) ) + +import GHC.Generics + +-- --------------------------------------------------------------------------- +-- The Doc 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 Doc data type + +-- | The abstract type of documents. +-- A Doc represents a *set* of layouts. A Doc with +-- no occurrences of Union or NoDoc represents just one layout. +data Doc a + = Empty -- empty + | NilAbove (Doc a) -- text "" $$ x + | TextBeside !(AnnotDetails a) (Doc a) -- text s <> x + | Nest {-# UNPACK #-} !Int (Doc a) -- nest k x + | Union (Doc a) (Doc a) -- ul `union` ur + | NoDoc -- The empty set of documents + | Beside (Doc a) Bool (Doc a) -- True <=> space between + | Above (Doc a) Bool (Doc a) -- True <=> never overlap +#if __GLASGOW_HASKELL__ >= 701 + deriving (Generic) +#endif + +{- +Here are the invariants: + +1) The argument of NilAbove is never Empty. Therefore + a NilAbove occupies at least two lines. + +2) The argument of @TextBeside@ is never @Nest@. + +3) The layouts of the two arguments of @Union@ both flatten to the same + string. + +4) The arguments of @Union@ are either @TextBeside@, or @NilAbove@. + +5) A @NoDoc@ may only appear on the first line of the left argument of an + union. Therefore, the right argument of an union can never be equivalent + to the empty set (@NoDoc@). + +6) An empty document is always represented by @Empty@. It can't be + hidden inside a @Nest@, or a @Union@ of two @Empty@s. + +7) The first line of every layout in the left argument of @Union@ is + longer than the first line of any layout in the right argument. + (1) ensures that the left argument has a first line. In view of + (3), this invariant means that the right argument must have at + least two lines. + +Notice the difference between + * NoDoc (no documents) + * Empty (one empty document; no height and no width) + * text "" (a document containing the empty string; + one line high, but has no width) +-} + + +-- | RDoc is a "reduced GDoc", guaranteed not to have a top-level Above or Beside. +type RDoc = Doc + +data AnnotDetails a = AnnotStart + | NoAnnot !TextDetails {-# UNPACK #-} !Int + | AnnotEnd a + deriving (Show,Eq) + +instance Functor AnnotDetails where + fmap _ AnnotStart = AnnotStart + fmap _ (NoAnnot d i) = NoAnnot d i + fmap f (AnnotEnd a) = AnnotEnd (f a) + +-- NOTE: Annotations are assumed to have zero length; only text has a length. +annotSize :: AnnotDetails a -> Int +annotSize (NoAnnot _ l) = l +annotSize _ = 0 + +-- | The TextDetails data type +-- +-- A TextDetails represents a fragment of text that will be +-- output at some point. +data TextDetails = Chr {-# UNPACK #-} !Char -- ^ A single Char fragment + | Str String -- ^ A whole String fragment + | PStr String -- ^ Used to represent a Fast String fragment + -- but now deprecated and identical to the + -- Str constructor. +#if __GLASGOW_HASKELL__ >= 701 + deriving (Show, Eq, Generic) +#endif + +-- Combining @Doc@ values +instance Monoid (Doc a) where + mempty = empty + mappend = (<>) + +instance IsString (Doc a) where + fromString = text + +instance Show (Doc a) where + showsPrec _ doc cont = fullRender (mode style) (lineLength style) + (ribbonsPerLine style) + txtPrinter cont doc + +instance Eq (Doc a) where + (==) = (==) `on` render + +instance Functor Doc where + fmap _ Empty = Empty + fmap f (NilAbove d) = NilAbove (fmap f d) + fmap f (TextBeside td d) = TextBeside (fmap f td) (fmap f d) + fmap f (Nest k d) = Nest k (fmap f d) + fmap f (Union ur ul) = Union (fmap f ur) (fmap f ul) + fmap _ NoDoc = NoDoc + fmap f (Beside ld s rd) = Beside (fmap f ld) s (fmap f rd) + fmap f (Above ud s ld) = Above (fmap f ud) s (fmap f ld) + +instance NFData a => NFData (Doc a) where + rnf Empty = () + rnf (NilAbove d) = rnf d + rnf (TextBeside td d) = rnf td `seq` rnf d + rnf (Nest k d) = rnf k `seq` rnf d + rnf (Union ur ul) = rnf ur `seq` rnf ul + rnf NoDoc = () + rnf (Beside ld s rd) = rnf ld `seq` rnf s `seq` rnf rd + rnf (Above ud s ld) = rnf ud `seq` rnf s `seq` rnf ld + +instance NFData a => NFData (AnnotDetails a) where + rnf AnnotStart = () + rnf (NoAnnot d sl) = rnf d `seq` rnf sl + rnf (AnnotEnd a) = rnf a + +instance NFData TextDetails where + rnf (Chr c) = rnf c + rnf (Str str) = rnf str + rnf (PStr str) = rnf str + +-- --------------------------------------------------------------------------- +-- Values and Predicates on GDocs and TextDetails + +-- | Attach an annotation to a document. +annotate :: a -> Doc a -> Doc a +annotate a d = TextBeside AnnotStart + $ beside (reduceDoc d) False + $ TextBeside (AnnotEnd a) Empty + + +-- | A document of height and width 1, containing a literal character. +char :: Char -> Doc a +char c = textBeside_ (NoAnnot (Chr c) 1) Empty + +-- | A document of height 1 containing a literal string. +-- 'text' satisfies the following laws: +-- +-- * @'text' s '<>' 'text' t = 'text' (s'++'t)@ +-- +-- * @'text' \"\" '<>' x = x@, if @x@ non-empty +-- +-- The side condition on the last law is necessary because @'text' \"\"@ +-- has height 1, while 'empty' has no height. +text :: String -> Doc a +text s = case length s of {sl -> textBeside_ (NoAnnot (Str s) sl) Empty} + +-- | Same as @text@. Used to be used for Bytestrings. +ptext :: String -> Doc a +ptext s = case length s of {sl -> textBeside_ (NoAnnot (PStr s) sl) Empty} + +-- | Some text with any width. (@text s = sizedText (length s) s@) +sizedText :: Int -> String -> Doc a +sizedText l s = textBeside_ (NoAnnot (Str s) l) Empty + +-- | Some text, but without any width. Use for non-printing text +-- such as a HTML or Latex tags +zeroWidthText :: String -> Doc a +zeroWidthText = sizedText 0 + +-- | The empty document, with no height and no width. +-- 'empty' is the identity for '<>', '<+>', '$$' and '$+$', and anywhere +-- in the argument list for 'sep', 'hcat', 'hsep', 'vcat', 'fcat' etc. +empty :: Doc a +empty = Empty + +-- | Returns 'True' if the document is empty +isEmpty :: Doc a -> Bool +isEmpty Empty = True +isEmpty _ = False + +-- | Produce spacing for indenting the amount specified. +-- +-- an old version inserted tabs being 8 columns apart in the output. +indent :: Int -> String +indent !n = replicate n ' ' + +{- +Q: What is the reason for negative indentation (i.e. argument to indent + is < 0) ? + +A: +This indicates an error in the library client's code. +If we compose a <> b, and the first line of b is more indented than some +other lines of b, the law (<> eats nests) may cause the pretty +printer to produce an invalid layout: + +doc |0123345 +------------------ +d1 |a...| +d2 |...b| + |c...| + +d1<>d2 |ab..| + c|....| + +Consider a <> b, let `s' be the length of the last line of `a', `k' the +indentation of the first line of b, and `k0' the indentation of the +left-most line b_i of b. + +The produced layout will have negative indentation if `k - k0 > s', as +the first line of b will be put on the (s+1)th column, effectively +translating b horizontally by (k-s). Now if the i^th line of b has an +indentation k0 < (k-s), it is translated out-of-page, causing +`negative indentation'. +-} + + +semi :: Doc a -- ^ A ';' character +comma :: Doc a -- ^ A ',' character +colon :: Doc a -- ^ A ':' character +space :: Doc a -- ^ A space character +equals :: Doc a -- ^ A '=' character +lparen :: Doc a -- ^ A '(' character +rparen :: Doc a -- ^ A ')' character +lbrack :: Doc a -- ^ A '[' character +rbrack :: Doc a -- ^ A ']' character +lbrace :: Doc a -- ^ A '{' character +rbrace :: Doc a -- ^ A '}' character +semi = char ';' +comma = char ',' +colon = char ':' +space = char ' ' +equals = char '=' +lparen = char '(' +rparen = char ')' +lbrack = char '[' +rbrack = char ']' +lbrace = char '{' +rbrace = char '}' + +spaceText, nlText :: AnnotDetails a +spaceText = NoAnnot (Chr ' ') 1 +nlText = NoAnnot (Chr '\n') 1 + +int :: Int -> Doc a -- ^ @int n = text (show n)@ +integer :: Integer -> Doc a -- ^ @integer n = text (show n)@ +float :: Float -> Doc a -- ^ @float n = text (show n)@ +double :: Double -> Doc a -- ^ @double n = text (show n)@ +rational :: Rational -> Doc a -- ^ @rational n = text (show n)@ +int n = text (show n) +integer n = text (show n) +float n = text (show n) +double n = text (show n) +rational n = text (show n) + +parens :: Doc a -> Doc a -- ^ Wrap document in @(...)@ +brackets :: Doc a -> Doc a -- ^ Wrap document in @[...]@ +braces :: Doc a -> Doc a -- ^ Wrap document in @{...}@ +quotes :: Doc a -> Doc a -- ^ Wrap document in @\'...\'@ +doubleQuotes :: Doc a -> Doc a -- ^ Wrap document in @\"...\"@ +quotes p = char '\'' <> p <> char '\'' +doubleQuotes p = char '"' <> p <> char '"' +parens p = char '(' <> p <> char ')' +brackets p = char '[' <> p <> char ']' +braces p = char '{' <> p <> char '}' + +-- | Apply 'parens' to 'Doc' if boolean is true. +maybeParens :: Bool -> Doc a -> Doc a +maybeParens False = id +maybeParens True = parens + +-- | Apply 'brackets' to 'Doc' if boolean is true. +maybeBrackets :: Bool -> Doc a -> Doc a +maybeBrackets False = id +maybeBrackets True = brackets + +-- | Apply 'braces' to 'Doc' if boolean is true. +maybeBraces :: Bool -> Doc a -> Doc a +maybeBraces False = id +maybeBraces True = braces + +-- | Apply 'quotes' to 'Doc' if boolean is true. +maybeQuotes :: Bool -> Doc a -> Doc a +maybeQuotes False = id +maybeQuotes True = quotes + +-- | Apply 'doubleQuotes' to 'Doc' if boolean is true. +maybeDoubleQuotes :: Bool -> Doc a -> Doc a +maybeDoubleQuotes False = id +maybeDoubleQuotes True = doubleQuotes + +-- --------------------------------------------------------------------------- +-- Structural operations on GDocs + +-- | Perform some simplification of a built up @GDoc@. +reduceDoc :: Doc a -> RDoc a +reduceDoc (Beside p g q) = beside p g (reduceDoc q) +reduceDoc (Above p g q) = above p g (reduceDoc q) +reduceDoc p = p + +-- | List version of '<>'. +hcat :: [Doc a] -> Doc a +hcat = snd . reduceHoriz . foldr (\p q -> Beside p False q) empty + +-- | List version of '<+>'. +hsep :: [Doc a] -> Doc a +hsep = snd . reduceHoriz . foldr (\p q -> Beside p True q) empty + +-- | List version of '$$'. +vcat :: [Doc a] -> Doc a +vcat = snd . reduceVert . foldr (\p q -> Above p False q) empty + +-- | Nest (or indent) a document by a given number of positions +-- (which may also be negative). 'nest' satisfies the laws: +-- +-- * @'nest' 0 x = x@ +-- +-- * @'nest' k ('nest' k' x) = 'nest' (k+k') x@ +-- +-- * @'nest' k (x '<>' y) = 'nest' k z '<>' 'nest' k y@ +-- +-- * @'nest' k (x '$$' y) = 'nest' k x '$$' 'nest' k y@ +-- +-- * @'nest' k 'empty' = 'empty'@ +-- +-- * @x '<>' 'nest' k y = x '<>' y@, if @x@ non-empty +-- +-- The side condition on the last law is needed because +-- 'empty' is a left identity for '<>'. +nest :: Int -> Doc a -> Doc a +nest k p = mkNest k (reduceDoc p) + +-- | @hang d1 n d2 = sep [d1, nest n d2]@ +hang :: Doc a -> Int -> Doc a -> Doc a +hang d1 n d2 = sep [d1, nest n d2] + +-- | @punctuate p [d1, ... dn] = [d1 \<> p, d2 \<> p, ... dn-1 \<> p, dn]@ +punctuate :: Doc a -> [Doc a] -> [Doc a] +punctuate _ [] = [] +punctuate p (x:xs) = go x xs + where go y [] = [y] + go y (z:zs) = (y <> p) : go z zs + +-- mkNest checks for Nest's invariant that it doesn't have an Empty inside it +mkNest :: Int -> Doc a -> Doc a +mkNest k _ | k `seq` False = undefined +mkNest k (Nest k1 p) = mkNest (k + k1) p +mkNest _ NoDoc = NoDoc +mkNest _ Empty = Empty +mkNest 0 p = p +mkNest k p = nest_ k p + +-- mkUnion checks for an empty document +mkUnion :: Doc a -> Doc a -> Doc a +mkUnion Empty _ = Empty +mkUnion p q = p `union_` q + +data IsEmpty = IsEmpty | NotEmpty + +reduceHoriz :: Doc a -> (IsEmpty, Doc a) +reduceHoriz (Beside p g q) = eliminateEmpty Beside (snd (reduceHoriz p)) g (reduceHoriz q) +reduceHoriz doc = (NotEmpty, doc) + +reduceVert :: Doc a -> (IsEmpty, Doc a) +reduceVert (Above p g q) = eliminateEmpty Above (snd (reduceVert p)) g (reduceVert q) +reduceVert doc = (NotEmpty, doc) + +{-# INLINE eliminateEmpty #-} +eliminateEmpty :: + (Doc a -> Bool -> Doc a -> Doc a) -> + Doc a -> Bool -> (IsEmpty, Doc a) -> (IsEmpty, Doc a) +eliminateEmpty _ Empty _ q = q +eliminateEmpty cons p g q = + (NotEmpty, + -- We're not empty whether or not q is empty, so for laziness-sake, + -- after checking that p isn't empty, we put the NotEmpty result + -- outside independent of q. This allows reduceAB to immediately + -- return the appropriate constructor (Above or Beside) without + -- forcing the entire nested Doc. This allows the foldr in vcat, + -- hsep, and hcat to be lazy on its second argument, avoiding a + -- stack overflow. + case q of + (NotEmpty, q') -> cons p g q' + (IsEmpty, _) -> p) + +nilAbove_ :: RDoc a -> RDoc a +nilAbove_ = NilAbove + +-- Arg of a TextBeside is always an RDoc +textBeside_ :: AnnotDetails a -> RDoc a -> RDoc a +textBeside_ = TextBeside + +nest_ :: Int -> RDoc a -> RDoc a +nest_ = Nest + +union_ :: RDoc a -> RDoc a -> RDoc a +union_ = Union + + +-- --------------------------------------------------------------------------- +-- Vertical composition @$$@ + +-- | Above, except that if the last line of the first argument stops +-- at least one position before the first line of the second begins, +-- these two lines are overlapped. For example: +-- +-- > text "hi" $$ nest 5 (text "there") +-- +-- lays out as +-- +-- > hi there +-- +-- rather than +-- +-- > hi +-- > there +-- +-- '$$' is associative, with identity 'empty', and also satisfies +-- +-- * @(x '$$' y) '<>' z = x '$$' (y '<>' z)@, if @y@ non-empty. +-- +($$) :: Doc a -> Doc a -> Doc a +p $$ q = above_ p False q + +-- | Above, with no overlapping. +-- '$+$' is associative, with identity 'empty'. +($+$) :: Doc a -> Doc a -> Doc a +p $+$ q = above_ p True q + +above_ :: Doc a -> Bool -> Doc a -> Doc a +above_ p _ Empty = p +above_ Empty _ q = q +above_ p g q = Above p g q + +above :: Doc a -> Bool -> RDoc a -> RDoc a +above (Above p g1 q1) g2 q2 = above p g1 (above q1 g2 q2) +above p@(Beside{}) g q = aboveNest (reduceDoc p) g 0 (reduceDoc q) +above p g q = aboveNest p g 0 (reduceDoc q) + +-- Specfication: aboveNest p g k q = p $g$ (nest k q) +aboveNest :: RDoc a -> Bool -> Int -> RDoc a -> RDoc a +aboveNest _ _ k _ | k `seq` False = undefined +aboveNest NoDoc _ _ _ = NoDoc +aboveNest (p1 `Union` p2) g k q = aboveNest p1 g k q `union_` + aboveNest p2 g k q + +aboveNest Empty _ k q = mkNest k q +aboveNest (Nest k1 p) g k q = nest_ k1 (aboveNest p g (k - k1) q) + -- p can't be Empty, so no need for mkNest + +aboveNest (NilAbove p) g k q = nilAbove_ (aboveNest p g k q) +aboveNest (TextBeside s p) g k q = TextBeside s rest + where + !k1 = k - annotSize s + rest = case p of + Empty -> nilAboveNest g k1 q + _ -> aboveNest p g k1 q + +aboveNest (Above {}) _ _ _ = error "aboveNest Above" +aboveNest (Beside {}) _ _ _ = error "aboveNest Beside" + +-- Specification: text s <> nilaboveNest g k q +-- = text s <> (text "" $g$ nest k q) +nilAboveNest :: Bool -> Int -> RDoc a -> RDoc a +nilAboveNest _ k _ | k `seq` False = undefined +nilAboveNest _ _ Empty = Empty + -- Here's why the "text s <>" is in the spec! +nilAboveNest g k (Nest k1 q) = nilAboveNest g (k + k1) q +nilAboveNest g k q | not g && k > 0 -- No newline if no overlap + = textBeside_ (NoAnnot (Str (indent k)) k) q + | otherwise -- Put them really above + = nilAbove_ (mkNest k q) + + +-- --------------------------------------------------------------------------- +-- Horizontal composition @<>@ + +-- We intentionally avoid Data.Monoid.(<>) here due to interactions of +-- Data.Monoid.(<>) and (<+>). See +-- http://www.haskell.org/pipermail/libraries/2011-November/017066.html + +-- | Beside. +-- '<>' is associative, with identity 'empty'. +(<>) :: Doc a -> Doc a -> Doc a +p <> q = beside_ p False q + +-- | Beside, separated by space, unless one of the arguments is 'empty'. +-- '<+>' is associative, with identity 'empty'. +(<+>) :: Doc a -> Doc a -> Doc a +p <+> q = beside_ p True q + +beside_ :: Doc a -> Bool -> Doc a -> Doc a +beside_ p _ Empty = p +beside_ Empty _ q = q +beside_ p g q = Beside p g q + +-- Specification: beside g p q = p q +beside :: Doc a -> Bool -> RDoc a -> RDoc a +beside NoDoc _ _ = NoDoc +beside (p1 `Union` p2) g q = beside p1 g q `union_` beside p2 g q +beside Empty _ q = q +beside (Nest k p) g q = nest_ k $! beside p g q +beside p@(Beside p1 g1 q1) g2 q2 + | g1 == g2 = beside p1 g1 $! beside q1 g2 q2 + | otherwise = beside (reduceDoc p) g2 q2 +beside p@(Above{}) g q = let !d = reduceDoc p in beside d g q +beside (NilAbove p) g q = nilAbove_ $! beside p g q +beside (TextBeside t p) g q = TextBeside t $! rest + where + rest = case p of + Empty -> nilBeside g q + _ -> beside p g q + +-- Specification: text "" <> nilBeside g p +-- = text "" p +nilBeside :: Bool -> RDoc a -> RDoc a +nilBeside _ Empty = Empty -- Hence the text "" in the spec +nilBeside g (Nest _ p) = nilBeside g p +nilBeside g p | g = textBeside_ spaceText p + | otherwise = p + + +-- --------------------------------------------------------------------------- +-- Separate, @sep@ + +-- Specification: sep ps = oneLiner (hsep ps) +-- `union` +-- vcat ps + +-- | Either 'hsep' or 'vcat'. +sep :: [Doc a] -> Doc a +sep = sepX True -- Separate with spaces + +-- | Either 'hcat' or 'vcat'. +cat :: [Doc a] -> Doc a +cat = sepX False -- Don't + +sepX :: Bool -> [Doc a] -> Doc a +sepX _ [] = empty +sepX x (p:ps) = sep1 x (reduceDoc p) 0 ps + + +-- Specification: sep1 g k ys = sep (x : map (nest k) ys) +-- = oneLiner (x nest k (hsep ys)) +-- `union` x $$ nest k (vcat ys) +sep1 :: Bool -> RDoc a -> Int -> [Doc a] -> RDoc a +sep1 _ _ k _ | k `seq` False = undefined +sep1 _ NoDoc _ _ = NoDoc +sep1 g (p `Union` q) k ys = sep1 g p k ys `union_` + aboveNest q False k (reduceDoc (vcat ys)) + +sep1 g Empty k ys = mkNest k (sepX g ys) +sep1 g (Nest n p) k ys = nest_ n (sep1 g p (k - n) ys) + +sep1 _ (NilAbove p) k ys = nilAbove_ + (aboveNest p False k (reduceDoc (vcat ys))) +sep1 g (TextBeside s p) k ys = textBeside_ s (sepNB g p (k - annotSize s) ys) +sep1 _ (Above {}) _ _ = error "sep1 Above" +sep1 _ (Beside {}) _ _ = error "sep1 Beside" + +-- Specification: sepNB p k ys = sep1 (text "" <> p) k ys +-- Called when we have already found some text in the first item +-- We have to eat up nests +sepNB :: Bool -> Doc a -> Int -> [Doc a] -> Doc a +sepNB g (Nest _ p) k ys + = sepNB g p k ys -- Never triggered, because of invariant (2) +sepNB g Empty k ys + = oneLiner (nilBeside g (reduceDoc rest)) `mkUnion` + -- XXX: TODO: PRETTY: Used to use True here (but GHC used False...) + nilAboveNest False k (reduceDoc (vcat ys)) + where + rest | g = hsep ys + | otherwise = hcat ys +sepNB g p k ys + = sep1 g p k ys + + +-- --------------------------------------------------------------------------- +-- @fill@ + +-- | \"Paragraph fill\" version of 'cat'. +fcat :: [Doc a] -> Doc a +fcat = fill False + +-- | \"Paragraph fill\" version of 'sep'. +fsep :: [Doc a] -> Doc a +fsep = fill True + +-- Specification: +-- +-- fill g docs = fillIndent 0 docs +-- +-- fillIndent k [] = [] +-- fillIndent k [p] = p +-- fillIndent k (p1:p2:ps) = +-- oneLiner p1 fillIndent (k + length p1 + g ? 1 : 0) +-- (remove_nests (oneLiner p2) : ps) +-- `Union` +-- (p1 $*$ nest (-k) (fillIndent 0 ps)) +-- +-- $*$ is defined for layouts (not Docs) as +-- layout1 $*$ layout2 | hasMoreThanOneLine layout1 = layout1 $$ layout2 +-- | otherwise = layout1 $+$ layout2 + +fill :: Bool -> [Doc a] -> RDoc a +fill _ [] = empty +fill g (p:ps) = fill1 g (reduceDoc p) 0 ps + +fill1 :: Bool -> RDoc a -> Int -> [Doc a] -> Doc a +fill1 _ _ k _ | k `seq` False = undefined +fill1 _ NoDoc _ _ = NoDoc +fill1 g (p `Union` q) k ys = fill1 g p k ys `union_` + aboveNest q False k (fill g ys) +fill1 g Empty k ys = mkNest k (fill g ys) +fill1 g (Nest n p) k ys = nest_ n (fill1 g p (k - n) ys) +fill1 g (NilAbove p) k ys = nilAbove_ (aboveNest p False k (fill g ys)) +fill1 g (TextBeside s p) k ys = textBeside_ s (fillNB g p (k - annotSize s) ys) +fill1 _ (Above {}) _ _ = error "fill1 Above" +fill1 _ (Beside {}) _ _ = error "fill1 Beside" + +fillNB :: Bool -> Doc a -> Int -> [Doc a] -> Doc a +fillNB _ _ k _ | k `seq` False = undefined +fillNB g (Nest _ p) k ys = fillNB g p k ys + -- Never triggered, because of invariant (2) +fillNB _ Empty _ [] = Empty +fillNB g Empty k (Empty:ys) = fillNB g Empty k ys +fillNB g Empty k (y:ys) = fillNBE g k y ys +fillNB g p k ys = fill1 g p k ys + + +fillNBE :: Bool -> Int -> Doc a -> [Doc a] -> Doc a +fillNBE g k y ys + = nilBeside g (fill1 g ((elideNest . oneLiner . reduceDoc) y) k' ys) + -- XXX: TODO: PRETTY: Used to use True here (but GHC used False...) + `mkUnion` nilAboveNest False k (fill g (y:ys)) + where k' = if g then k - 1 else k + +elideNest :: Doc a -> Doc a +elideNest (Nest _ d) = d +elideNest d = d + + +-- --------------------------------------------------------------------------- +-- Selecting the best layout + +best :: Int -- Line length + -> Int -- Ribbon length + -> RDoc a + -> RDoc a -- No unions in here! +best w0 r = get w0 + where + get w _ | w == 0 && False = undefined + get _ Empty = Empty + get _ NoDoc = NoDoc + get w (NilAbove p) = nilAbove_ (get w p) + get w (TextBeside s p) = textBeside_ s (get1 w (annotSize s) p) + get w (Nest k p) = nest_ k (get (w - k) p) + get w (p `Union` q) = nicest w r (get w p) (get w q) + get _ (Above {}) = error "best get Above" + get _ (Beside {}) = error "best get Beside" + + get1 w _ _ | w == 0 && False = undefined + get1 _ _ Empty = Empty + get1 _ _ NoDoc = NoDoc + get1 w sl (NilAbove p) = nilAbove_ (get (w - sl) p) + get1 w sl (TextBeside s p) = textBeside_ s (get1 w (sl + annotSize s) p) + get1 w sl (Nest _ p) = get1 w sl p + get1 w sl (p `Union` q) = nicest1 w r sl (get1 w sl p) + (get1 w sl q) + get1 _ _ (Above {}) = error "best get1 Above" + get1 _ _ (Beside {}) = error "best get1 Beside" + +nicest :: Int -> Int -> Doc a -> Doc a -> Doc a +nicest !w !r = nicest1 w r 0 + +nicest1 :: Int -> Int -> Int -> Doc a -> Doc a -> Doc a +nicest1 !w !r !sl p q | fits ((w `min` r) - sl) p = p + | otherwise = q + +fits :: Int -- Space available + -> Doc a + -> Bool -- True if *first line* of Doc fits in space available +fits n _ | n < 0 = False +fits _ NoDoc = False +fits _ Empty = True +fits _ (NilAbove _) = True +fits n (TextBeside s p) = fits (n - annotSize s) p +fits _ (Above {}) = error "fits Above" +fits _ (Beside {}) = error "fits Beside" +fits _ (Union {}) = error "fits Union" +fits _ (Nest {}) = error "fits Nest" + +-- | @first@ returns its first argument if it is non-empty, otherwise its second. +first :: Doc a -> Doc a -> Doc a +first p q | nonEmptySet p = p -- unused, because (get OneLineMode) is unused + | otherwise = q + +nonEmptySet :: Doc a -> Bool +nonEmptySet NoDoc = False +nonEmptySet (_ `Union` _) = True +nonEmptySet Empty = True +nonEmptySet (NilAbove _) = True +nonEmptySet (TextBeside _ p) = nonEmptySet p +nonEmptySet (Nest _ p) = nonEmptySet p +nonEmptySet (Above {}) = error "nonEmptySet Above" +nonEmptySet (Beside {}) = error "nonEmptySet Beside" + +-- @oneLiner@ returns the one-line members of the given set of @GDoc@s. +oneLiner :: Doc a -> Doc a +oneLiner NoDoc = NoDoc +oneLiner Empty = Empty +oneLiner (NilAbove _) = NoDoc +oneLiner (TextBeside s p) = textBeside_ s (oneLiner p) +oneLiner (Nest k p) = nest_ k (oneLiner p) +oneLiner (p `Union` _) = oneLiner p +oneLiner (Above {}) = error "oneLiner Above" +oneLiner (Beside {}) = error "oneLiner Beside" + + +-- --------------------------------------------------------------------------- +-- Rendering + +-- | A rendering style. +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 @Doc@ to a String using the default @Style@. +render :: Doc a -> String +render = fullRender (mode style) (lineLength style) (ribbonsPerLine style) + txtPrinter "" + +-- | Render the @Doc@ to a String using the given @Style@. +renderStyle :: Style -> Doc a -> String +renderStyle s = fullRender (mode s) (lineLength s) (ribbonsPerLine s) + txtPrinter "" + +-- | Default TextDetails printer +txtPrinter :: TextDetails -> String -> String +txtPrinter (Chr c) s = c:s +txtPrinter (Str s1) s2 = s1 ++ s2 +txtPrinter (PStr s1) s2 = s1 ++ s2 + +-- | The general rendering interface. +fullRender :: Mode -- ^ Rendering mode + -> Int -- ^ Line length + -> Float -- ^ Ribbons per line + -> (TextDetails -> a -> a) -- ^ What to do with text + -> a -- ^ What to do at the end + -> Doc b -- ^ The document + -> a -- ^ Result +fullRender m l r txt = fullRenderAnn m l r annTxt + where + annTxt (NoAnnot s _) = txt s + annTxt _ = id + +fullRenderAnn :: Mode -- ^ Rendering mode + -> Int -- ^ Line length + -> Float -- ^ Ribbons per line + -> (AnnotDetails b -> a -> a) -- ^ What to do with text + -> a -- ^ What to do at the end + -> Doc b -- ^ The document + -> a -- ^ Result +fullRenderAnn OneLineMode _ _ txt end doc + = easyDisplay spaceText (\_ y -> y) txt end (reduceDoc doc) +fullRenderAnn LeftMode _ _ txt end doc + = easyDisplay nlText first txt end (reduceDoc doc) + +fullRenderAnn m lineLen ribbons txt rest doc + = display m lineLen ribbonLen txt rest doc' + where + doc' = best bestLineLen ribbonLen (reduceDoc doc) + + bestLineLen, ribbonLen :: Int + ribbonLen = round (fromIntegral lineLen / ribbons) + bestLineLen = case m of + ZigZagMode -> maxBound + _ -> lineLen + +easyDisplay :: AnnotDetails b + -> (Doc b -> Doc b -> Doc b) + -> (AnnotDetails b -> a -> a) + -> a + -> Doc b + -> a +easyDisplay nlSpaceText choose txt end + = lay + where + lay NoDoc = error "easyDisplay: NoDoc" + lay (Union p q) = lay (choose p q) + lay (Nest _ p) = lay p + lay Empty = end + lay (NilAbove p) = nlSpaceText `txt` lay p + lay (TextBeside s p) = s `txt` lay p + lay (Above {}) = error "easyDisplay Above" + lay (Beside {}) = error "easyDisplay Beside" + +display :: Mode -> Int -> Int -> (AnnotDetails b -> a -> a) -> a -> Doc b -> a +display m !page_width !ribbon_width txt end doc + = case page_width - ribbon_width of { gap_width -> + case gap_width `quot` 2 of { shift -> + let + lay k _ | k `seq` False = undefined + lay k (Nest k1 p) = lay (k + k1) p + lay _ Empty = end + lay k (NilAbove p) = nlText `txt` lay k p + lay k (TextBeside s p) + = case m of + ZigZagMode | k >= gap_width + -> nlText `txt` ( + NoAnnot (Str (replicate shift '/')) shift `txt` ( + nlText `txt` + lay1 (k - shift) s p )) + + | k < 0 + -> nlText `txt` ( + NoAnnot (Str (replicate shift '\\')) shift `txt` ( + nlText `txt` + lay1 (k + shift) s p )) + + _ -> lay1 k s p + + lay _ (Above {}) = error "display lay Above" + lay _ (Beside {}) = error "display lay Beside" + lay _ NoDoc = error "display lay NoDoc" + lay _ (Union {}) = error "display lay Union" + + lay1 !k s p = let !r = k + annotSize s + in NoAnnot (Str (indent k)) k `txt` (s `txt` lay2 r p) + + lay2 k _ | k `seq` False = undefined + lay2 k (NilAbove p) = nlText `txt` lay k p + lay2 k (TextBeside s p) = s `txt` lay2 (k + annotSize s) p + lay2 k (Nest _ p) = lay2 k p + lay2 _ Empty = end + lay2 _ (Above {}) = error "display lay2 Above" + lay2 _ (Beside {}) = error "display lay2 Beside" + lay2 _ NoDoc = error "display lay2 NoDoc" + lay2 _ (Union {}) = error "display lay2 Union" + in + lay 0 doc + }} + + + +-- Rendering Annotations ------------------------------------------------------- + +data Span a = Span { spanStart + , spanLength :: !Int + , spanAnnotation :: a + } deriving (Show,Eq) + +instance Functor Span where + fmap f (Span x y a) = Span x y (f a) + + +-- State required for generating document spans. +data Spans a = Spans { sOffset :: !Int + -- ^ Current offset from the end of the document + , sStack :: [Int -> Span a] + -- ^ Currently open spans + , sSpans :: [Span a] + -- ^ Collected annotation regions + , sOutput :: String + -- ^ Collected output + } + +renderSpans :: Doc ann -> (String,[Span ann]) +renderSpans = finalize + . fullRenderAnn (mode style) (lineLength style) (ribbonsPerLine style) + spanPrinter + Spans { sOffset = 0, sStack = [], sSpans = [], sOutput = "" } + where + + finalize (Spans size _ spans out) = (out, map adjust spans) + where + adjust s = s { spanStart = size - spanStart s } + + mkSpan a end start = Span { spanStart = start + , spanLength = start - end + -- ^ this seems wrong, but remember that it's + -- working backwards at this point + , spanAnnotation = a } + + -- the document gets generated in reverse, which is why the starting + -- annotation ends the annotation. + spanPrinter AnnotStart s = + case sStack s of + sp : rest -> s { sSpans = sp (sOffset s) : sSpans s, sStack = rest } + _ -> error "renderSpans: stack underflow" + + spanPrinter (AnnotEnd a) s = + s { sStack = mkSpan a (sOffset s) : sStack s } + + spanPrinter (NoAnnot td l) s = + case td of + Chr c -> s { sOutput = c : sOutput s, sOffset = sOffset s + l } + Str t -> s { sOutput = t ++ sOutput s, sOffset = sOffset s + l } + PStr t -> s { sOutput = t ++ sOutput s, sOffset = sOffset s + l } + + +-- | Render out a String, interpreting the annotations as part of the resulting +-- document. +-- +-- IMPORTANT: the size of the annotation string does NOT figure into the layout +-- of the document, so the document will lay out as though the annotations are +-- not present. +renderDecorated :: (ann -> String) -- ^ Starting an annotation + -> (ann -> String) -- ^ Ending an annotation + -> Doc ann -> String +renderDecorated startAnn endAnn = + finalize . fullRenderAnn (mode style) (lineLength style) (ribbonsPerLine style) + annPrinter + ("", []) + where + annPrinter AnnotStart (rest,stack) = + case stack of + a : as -> (startAnn a ++ rest, as) + _ -> error "renderDecorated: stack underflow" + + annPrinter (AnnotEnd a) (rest,stack) = + (endAnn a ++ rest, a : stack) + + annPrinter (NoAnnot s _) (rest,stack) = + (txtPrinter s rest, stack) + + finalize (str,_) = str + + +-- | Render a document with annotations, by interpreting the start and end of +-- the annotations, as well as the text details in the context of a monad. +renderDecoratedM :: Monad m + => (ann -> m r) -- ^ Starting an annotation + -> (ann -> m r) -- ^ Ending an annotation + -> (String -> m r) -- ^ Text formatting + -> m r -- ^ Document end + -> Doc ann -> m r +renderDecoratedM startAnn endAnn txt docEnd = + finalize . fullRenderAnn (mode style) (lineLength style) (ribbonsPerLine style) + annPrinter + (docEnd, []) + where + annPrinter AnnotStart (rest,stack) = + case stack of + a : as -> (startAnn a >> rest, as) + _ -> error "renderDecorated: stack underflow" + + annPrinter (AnnotEnd a) (rest,stack) = + (endAnn a >> rest, a : stack) + + annPrinter (NoAnnot td _) (rest,stack) = + case td of + Chr c -> (txt [c] >> rest, stack) + Str s -> (txt s >> rest, stack) + PStr s -> (txt s >> rest, stack) + + finalize (m,_) = m diff --git a/src/Text/PrettyPrint/Annotated/HughesPJClass.hs b/src/Text/PrettyPrint/Annotated/HughesPJClass.hs new file mode 100644 --- /dev/null +++ b/src/Text/PrettyPrint/Annotated/HughesPJClass.hs @@ -0,0 +1,146 @@ +#if __GLASGOW_HASKELL__ >= 701 +{-# LANGUAGE Safe #-} +#endif + +----------------------------------------------------------------------------- +-- | +-- Module : Text.PrettyPrint.Annotated.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.Annotated.HughesPJClass ( + -- * Pretty typeclass + Pretty(..), + + PrettyLevel(..), prettyNormal, + prettyShow, prettyParen, + + -- re-export HughesPJ + module Text.PrettyPrint.Annotated.HughesPJ + ) where + +import Text.PrettyPrint.Annotated.HughesPJ + +-- | Level of detail in the pretty printed output. +-- Level 0 is the least detail. +newtype PrettyLevel = PrettyLevel Int + deriving (Eq, Ord, Show) + +-- | The "normal" (Level 0) of detail. +prettyNormal :: PrettyLevel +prettyNormal = PrettyLevel 0 + +-- | Pretty printing class. The precedence level is used in a similar way as in +-- the 'Show' class. Minimal complete definition is either 'pPrintPrec' or +-- 'pPrint'. +class Pretty a where + pPrintPrec :: PrettyLevel -> Rational -> a -> Doc ann + pPrintPrec _ _ = pPrint + + pPrint :: a -> Doc ann + pPrint = pPrintPrec prettyNormal 0 + + pPrintList :: PrettyLevel -> [a] -> Doc ann + pPrintList l = brackets . fsep . punctuate comma . map (pPrintPrec l 0) + +#if __GLASGOW_HASKELL__ >= 708 + {-# MINIMAL pPrintPrec | pPrint #-} +#endif + +-- | Pretty print a value with the 'prettyNormal' level. +prettyShow :: (Pretty a) => a -> String +prettyShow = render . pPrint + +pPrint0 :: (Pretty a) => PrettyLevel -> a -> Doc ann +pPrint0 l = pPrintPrec l 0 + +appPrec :: Rational +appPrec = 10 + +-- | Parenthesize an value if the boolean is true. +{-# DEPRECATED prettyParen "Please use 'maybeParens' instead" #-} +prettyParen :: Bool -> Doc ann -> Doc ann +prettyParen = maybeParens + +-- Various Pretty instances +instance Pretty Int where pPrint = int + +instance Pretty Integer where pPrint = integer + +instance Pretty Float where pPrint = float + +instance Pretty Double where pPrint = double + +instance Pretty () where pPrint _ = text "()" + +instance Pretty Bool where pPrint = text . show + +instance Pretty Ordering where pPrint = text . show + +instance Pretty Char where + pPrint = char + pPrintList _ = text . show + +instance (Pretty a) => Pretty (Maybe a) where + pPrintPrec _ _ Nothing = text "Nothing" + pPrintPrec l p (Just x) = + prettyParen (p > appPrec) $ text "Just" <+> pPrintPrec l (appPrec+1) x + +instance (Pretty a, Pretty b) => Pretty (Either a b) where + pPrintPrec l p (Left x) = + prettyParen (p > appPrec) $ text "Left" <+> pPrintPrec l (appPrec+1) x + pPrintPrec l p (Right x) = + prettyParen (p > appPrec) $ text "Right" <+> pPrintPrec l (appPrec+1) x + +instance (Pretty a) => Pretty [a] where + pPrintPrec l _ = pPrintList l + +instance (Pretty a, Pretty b) => Pretty (a, b) where + pPrintPrec l _ (a, b) = + parens $ fsep $ punctuate comma [pPrint0 l a, pPrint0 l b] + +instance (Pretty a, Pretty b, Pretty c) => Pretty (a, b, c) where + pPrintPrec l _ (a, b, c) = + parens $ fsep $ punctuate comma [pPrint0 l a, pPrint0 l b, pPrint0 l c] + +instance (Pretty a, Pretty b, Pretty c, Pretty d) => Pretty (a, b, c, d) where + pPrintPrec l _ (a, b, c, d) = + parens $ fsep $ punctuate comma + [pPrint0 l a, pPrint0 l b, pPrint0 l c, pPrint0 l d] + +instance (Pretty a, Pretty b, Pretty c, Pretty d, Pretty e) => Pretty (a, b, c, d, e) where + pPrintPrec l _ (a, b, c, d, e) = + parens $ fsep $ punctuate comma + [pPrint0 l a, pPrint0 l b, pPrint0 l c, pPrint0 l d, pPrint0 l e] + +instance (Pretty a, Pretty b, Pretty c, Pretty d, Pretty e, Pretty f) => Pretty (a, b, c, d, e, f) where + pPrintPrec l _ (a, b, c, d, e, f) = + parens $ fsep $ punctuate comma + [pPrint0 l a, pPrint0 l b, pPrint0 l c, + pPrint0 l d, pPrint0 l e, pPrint0 l f] + +instance (Pretty a, Pretty b, Pretty c, Pretty d, Pretty e, Pretty f, Pretty g) => + Pretty (a, b, c, d, e, f, g) where + pPrintPrec l _ (a, b, c, d, e, f, g) = + parens $ fsep $ punctuate comma + [pPrint0 l a, pPrint0 l b, pPrint0 l c, + pPrint0 l d, pPrint0 l e, pPrint0 l f, pPrint0 l g] + +instance (Pretty a, Pretty b, Pretty c, Pretty d, Pretty e, Pretty f, Pretty g, Pretty h) => + Pretty (a, b, c, d, e, f, g, h) where + pPrintPrec l _ (a, b, c, d, e, f, g, h) = + parens $ fsep $ punctuate comma + [pPrint0 l a, pPrint0 l b, pPrint0 l c, + pPrint0 l d, pPrint0 l e, pPrint0 l f, pPrint0 l g, pPrint0 l h] + diff --git a/src/Text/PrettyPrint/HughesPJ.hs b/src/Text/PrettyPrint/HughesPJ.hs --- a/src/Text/PrettyPrint/HughesPJ.hs +++ b/src/Text/PrettyPrint/HughesPJ.hs @@ -81,6 +81,10 @@ ) where #endif +import Text.PrettyPrint.Annotated.HughesPJ + ( TextDetails(..), Mode(..), Style(..), style ) +import qualified Text.PrettyPrint.Annotated.HughesPJ as Ann + import Control.DeepSeq ( NFData(rnf) ) import Data.Function ( on ) #if __GLASGOW_HASKELL__ < 709 @@ -90,81 +94,7 @@ import GHC.Generics --- --------------------------------------------------------------------------- --- The Doc 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 @@ -178,69 +108,24 @@ -- | The abstract type of documents. -- A Doc represents a *set* of layouts. A Doc with -- no occurrences of Union or NoDoc represents just one layout. -data Doc - = Empty -- empty - | NilAbove Doc -- text "" $$ x - | TextBeside !TextDetails {-# UNPACK #-} !Int Doc -- text s <> x - | Nest {-# UNPACK #-} !Int Doc -- nest k x - | Union Doc Doc -- ul `union` ur - | NoDoc -- The empty set of documents - | Beside Doc Bool Doc -- True <=> space between - | Above Doc Bool Doc -- True <=> never overlap +newtype Doc = Doc (Ann.Doc ()) #if __GLASGOW_HASKELL__ >= 701 - deriving (Generic) + 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) --} +liftList :: ([Ann.Doc ()] -> Ann.Doc ()) -> ([Doc] -> Doc) +liftList f ds = Doc (f [ d | Doc d <- ds ]) +{-# INLINE liftList #-} +liftBinary :: (Ann.Doc () -> Ann.Doc () -> Ann.Doc ()) + -> ( Doc -> Doc -> Doc ) +liftBinary f (Doc a) (Doc b) = Doc (f a b) +{-# INLINE liftBinary #-} --- | RDoc is a "reduced GDoc", guaranteed not to have a top-level Above or Beside. +-- | RDoc is a "reduced GDoc", guaranteed not to have a top-level Above or +-- Beside. type RDoc = Doc --- | The TextDetails data type --- --- A TextDetails represents a fragment of text that will be --- output at some point. -data TextDetails = Chr {-# UNPACK #-} !Char -- ^ A single Char fragment - | Str String -- ^ A whole String fragment - | PStr String -- ^ Used to represent a Fast String fragment - -- but now deprecated and identical to the - -- Str constructor. -#if __GLASGOW_HASKELL__ >= 701 - deriving (Show, Eq, Generic) -#endif - -- Combining @Doc@ values instance Monoid Doc where mempty = empty @@ -258,26 +143,15 @@ (==) = (==) `on` render instance NFData Doc 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 TextDetails where - rnf (Chr c) = rnf c - rnf (Str str) = rnf str - rnf (PStr str) = rnf str + rnf (Doc a) = rnf a -- --------------------------------------------------------------------------- -- Values and Predicates on GDocs and TextDetails -- | A document of height and width 1, containing a literal character. char :: Char -> Doc -char c = textBeside_ (Chr c) 1 Empty +char c = Doc (Ann.char c) +{-# INLINE char #-} -- | A document of height 1 containing a literal string. -- 'text' satisfies the following laws: @@ -289,15 +163,17 @@ -- The side condition on the last law is necessary because @'text' \"\"@ -- has height 1, while 'empty' has no height. text :: String -> Doc -text s = case length s of {sl -> textBeside_ (Str s) sl Empty} +text s = Doc (Ann.text s) +{-# INLINE text #-} -- | Same as @text@. Used to be used for Bytestrings. ptext :: String -> Doc -ptext s = case length s of {sl -> textBeside_ (PStr s) sl Empty} +ptext s = Doc (Ann.ptext s) +{-# INLINE ptext #-} -- | Some text with any width. (@text s = sizedText (length s) s@) sizedText :: Int -> String -> Doc -sizedText l s = textBeside_ (Str s) l Empty +sizedText l s = Doc (Ann.sizedText l s) -- | Some text, but without any width. Use for non-printing text -- such as a HTML or Latex tags @@ -308,49 +184,11 @@ -- 'empty' is the identity for '<>', '<+>', '$$' and '$+$', and anywhere -- in the argument list for 'sep', 'hcat', 'hsep', 'vcat', 'fcat' etc. empty :: Doc -empty = Empty +empty = Doc Ann.empty -- | Returns 'True' if the document is empty isEmpty :: Doc -> 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'. --} - +isEmpty (Doc d) = Ann.isEmpty d semi :: Doc -- ^ A ';' character comma :: Doc -- ^ A ',' character @@ -375,10 +213,6 @@ lbrace = char '{' rbrace = char '}' -spaceText, nlText :: TextDetails -spaceText = Chr ' ' -nlText = Chr '\n' - int :: Int -> Doc -- ^ @int n = text (show n)@ integer :: Integer -> Doc -- ^ @integer n = text (show n)@ float :: Float -> Doc -- ^ @float n = text (show n)@ @@ -431,21 +265,23 @@ -- | Perform some simplification of a built up @GDoc@. reduceDoc :: Doc -> RDoc -reduceDoc (Beside p g q) = beside p g (reduceDoc q) -reduceDoc (Above p g q) = above p g (reduceDoc q) -reduceDoc p = p +reduceDoc (Doc d) = Doc (Ann.reduceDoc d) +{-# INLINE reduceDoc #-} -- | List version of '<>'. hcat :: [Doc] -> Doc -hcat = snd . reduceHoriz . foldr (\p q -> Beside p False q) empty +hcat = liftList Ann.hcat +{-# INLINE hcat #-} -- | List version of '<+>'. hsep :: [Doc] -> Doc -hsep = snd . reduceHoriz . foldr (\p q -> Beside p True q) empty +hsep = liftList Ann.hsep +{-# INLINE hsep #-} -- | List version of '$$'. vcat :: [Doc] -> Doc -vcat = snd . reduceVert . foldr (\p q -> Above p False q) empty +vcat = liftList Ann.vcat +{-# INLINE vcat #-} -- | Nest (or indent) a document by a given number of positions -- (which may also be negative). 'nest' satisfies the laws: @@ -465,73 +301,18 @@ -- The side condition on the last law is needed because -- 'empty' is a left identity for '<>'. nest :: Int -> Doc -> Doc -nest k p = mkNest k (reduceDoc p) +nest k (Doc p) = Doc (Ann.nest k p) +{-# INLINE nest #-} -- | @hang d1 n d2 = sep [d1, nest n d2]@ hang :: Doc -> Int -> Doc -> Doc -hang d1 n d2 = sep [d1, nest n d2] +hang (Doc d1) n (Doc d2) = Doc (Ann.hang d1 n d2) +{-# INLINE hang #-} -- | @punctuate p [d1, ... dn] = [d1 \<> p, d2 \<> p, ... dn-1 \<> p, dn]@ punctuate :: Doc -> [Doc] -> [Doc] -punctuate _ [] = [] -punctuate p (x:xs) = go x xs - where go y [] = [y] - go y (z:zs) = (y <> p) : go z zs - --- mkNest checks for Nest's invariant that it doesn't have an Empty inside it -mkNest :: Int -> Doc -> Doc -mkNest k _ | k `seq` False = undefined -mkNest k (Nest k1 p) = mkNest (k + k1) p -mkNest _ NoDoc = NoDoc -mkNest _ Empty = Empty -mkNest 0 p = p -mkNest k p = nest_ k p - --- mkUnion checks for an empty document -mkUnion :: Doc -> Doc -> Doc -mkUnion Empty _ = Empty -mkUnion p q = p `union_` q - -data IsEmpty = IsEmpty | NotEmpty - -reduceHoriz :: Doc -> (IsEmpty, Doc) -reduceHoriz (Beside p g q) = eliminateEmpty Beside (snd (reduceHoriz p)) g (reduceHoriz q) -reduceHoriz doc = (NotEmpty, doc) - -reduceVert :: Doc -> (IsEmpty, Doc) -reduceVert (Above p g q) = eliminateEmpty Above (snd (reduceVert p)) g (reduceVert q) -reduceVert doc = (NotEmpty, doc) - -{-# INLINE eliminateEmpty #-} -eliminateEmpty :: - (Doc -> Bool -> Doc -> Doc) -> - Doc -> Bool -> (IsEmpty, Doc) -> (IsEmpty, Doc) -eliminateEmpty _ Empty _ q = q -eliminateEmpty cons p g q = - (NotEmpty, - -- We're not empty whether or not q is empty, so for laziness-sake, - -- after checking that p isn't empty, we put the NotEmpty result - -- outside independent of q. This allows reduceAB to immediately - -- return the appropriate constructor (Above or Beside) without - -- forcing the entire nested Doc. This allows the foldr in vcat, - -- hsep, and hcat to be lazy on its second argument, avoiding a - -- stack overflow. - case q of - (NotEmpty, q') -> cons p g q' - (IsEmpty, _) -> p) - -nilAbove_ :: RDoc -> RDoc -nilAbove_ = NilAbove - --- Arg of a TextBeside is always an RDoc -textBeside_ :: TextDetails -> Int -> RDoc -> RDoc -textBeside_ = TextBeside - -nest_ :: Int -> RDoc -> RDoc -nest_ = Nest - -union_ :: RDoc -> RDoc -> RDoc -union_ = Union +punctuate (Doc p) ds = [ Doc d | d <- Ann.punctuate p [ d | Doc d <- ds ] ] +{-# INLINE punctuate #-} -- --------------------------------------------------------------------------- @@ -557,55 +338,14 @@ -- * @(x '$$' y) '<>' z = x '$$' (y '<>' z)@, if @y@ non-empty. -- ($$) :: Doc -> Doc -> Doc -p $$ q = above_ p False q +($$) = liftBinary (Ann.$$) +{-# INLINE ($$) #-} -- | Above, with no overlapping. -- '$+$' is associative, with identity 'empty'. ($+$) :: Doc -> Doc -> Doc -p $+$ q = above_ p True q - -above_ :: Doc -> Bool -> Doc -> Doc -above_ p _ Empty = p -above_ Empty _ q = q -above_ p g q = Above p g q - -above :: Doc -> Bool -> RDoc -> RDoc -above (Above p g1 q1) g2 q2 = above p g1 (above q1 g2 q2) -above p@(Beside{}) g q = aboveNest (reduceDoc p) g 0 (reduceDoc q) -above p g q = aboveNest p g 0 (reduceDoc q) - --- Specfication: aboveNest p g k q = p $g$ (nest k q) -aboveNest :: RDoc -> Bool -> Int -> RDoc -> RDoc -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 -> RDoc -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) +($+$) = liftBinary (Ann.$+$) +{-# INLINE ($+$) #-} -- --------------------------------------------------------------------------- @@ -618,42 +358,14 @@ -- | Beside. -- '<>' is associative, with identity 'empty'. (<>) :: Doc -> Doc -> Doc -p <> q = beside_ p False q +(<>) = liftBinary (Ann.<>) +{-# INLINE (<>) #-} -- | Beside, separated by space, unless one of the arguments is 'empty'. -- '<+>' is associative, with identity 'empty'. (<+>) :: Doc -> Doc -> Doc -p <+> q = beside_ p True q - -beside_ :: Doc -> Bool -> Doc -> Doc -beside_ p _ Empty = p -beside_ Empty _ q = q -beside_ p g q = Beside p g q - --- Specification: beside g p q = p q -beside :: Doc -> Bool -> RDoc -> RDoc -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 -> RDoc -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 +(<+>) = liftBinary (Ann.<+>) +{-# INLINE (<+>) #-} -- --------------------------------------------------------------------------- @@ -665,50 +377,13 @@ -- | Either 'hsep' or 'vcat'. sep :: [Doc] -> Doc -sep = sepX True -- Separate with spaces +sep = liftList Ann.sep +{-# INLINE sep #-} -- | Either 'hcat' or 'vcat'. cat :: [Doc] -> Doc -cat = sepX False -- Don't - -sepX :: Bool -> [Doc] -> Doc -sepX _ [] = empty -sepX x (p:ps) = sep1 x (reduceDoc p) 0 ps - - --- Specification: sep1 g k ys = sep (x : map (nest k) ys) --- = oneLiner (x nest k (hsep ys)) --- `union` x $$ nest k (vcat ys) -sep1 :: Bool -> RDoc -> Int -> [Doc] -> RDoc -sep1 _ _ k _ | k `seq` False = undefined -sep1 _ NoDoc _ _ = NoDoc -sep1 g (p `Union` q) k ys = sep1 g p k ys `union_` - aboveNest q False k (reduceDoc (vcat ys)) - -sep1 g Empty k ys = mkNest k (sepX g ys) -sep1 g (Nest n p) k ys = nest_ n (sep1 g p (k - n) ys) - -sep1 _ (NilAbove p) k ys = nilAbove_ - (aboveNest p False k (reduceDoc (vcat ys))) -sep1 g (TextBeside s sl p) k ys = textBeside_ s sl (sepNB g p (k - sl) ys) -sep1 _ (Above {}) _ _ = error "sep1 Above" -sep1 _ (Beside {}) _ _ = error "sep1 Beside" - --- Specification: sepNB p k ys = sep1 (text "" <> p) k ys --- Called when we have already found some text in the first item --- We have to eat up nests -sepNB :: Bool -> Doc -> Int -> [Doc] -> Doc -sepNB g (Nest _ p) k ys - = sepNB g p k ys -- Never triggered, because of invariant (2) -sepNB g Empty k ys - = oneLiner (nilBeside g (reduceDoc rest)) `mkUnion` - -- 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 +cat = liftList Ann.cat +{-# INLINE cat #-} -- --------------------------------------------------------------------------- @@ -716,178 +391,38 @@ -- | \"Paragraph fill\" version of 'cat'. fcat :: [Doc] -> Doc -fcat = fill False +fcat = liftList Ann.fcat +{-# INLINE fcat #-} -- | \"Paragraph fill\" version of 'sep'. fsep :: [Doc] -> Doc -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 -> [Doc] -> RDoc -fill _ [] = empty -fill g (p:ps) = fill1 g (reduceDoc p) 0 ps - -fill1 :: Bool -> RDoc -> Int -> [Doc] -> Doc -fill1 _ _ k _ | k `seq` False = undefined -fill1 _ NoDoc _ _ = NoDoc -fill1 g (p `Union` q) k ys = fill1 g p k ys `union_` - aboveNest q False k (fill g ys) -fill1 g Empty k ys = mkNest k (fill g ys) -fill1 g (Nest n p) k ys = nest_ n (fill1 g p (k - n) ys) -fill1 g (NilAbove p) k ys = nilAbove_ (aboveNest p False k (fill g ys)) -fill1 g (TextBeside s sl p) k ys = textBeside_ s sl (fillNB g p (k - sl) ys) -fill1 _ (Above {}) _ _ = error "fill1 Above" -fill1 _ (Beside {}) _ _ = error "fill1 Beside" - -fillNB :: Bool -> Doc -> Int -> [Doc] -> Doc -fillNB _ _ k _ | k `seq` False = undefined -fillNB g (Nest _ p) k ys = fillNB g p k ys - -- Never triggered, because of invariant (2) -fillNB _ Empty _ [] = Empty -fillNB g Empty k (Empty:ys) = fillNB g Empty k ys -fillNB g Empty k (y:ys) = fillNBE g k y ys -fillNB g p k ys = fill1 g p k ys - - -fillNBE :: Bool -> Int -> Doc -> [Doc] -> Doc -fillNBE g k y ys - = nilBeside g (fill1 g ((elideNest . oneLiner . reduceDoc) y) k' ys) - -- XXX: TODO: PRETTY: Used to use True here (but GHC used False...) - `mkUnion` nilAboveNest False k (fill g (y:ys)) - where k' = if g then k - 1 else k - -elideNest :: Doc -> Doc -elideNest (Nest _ d) = d -elideNest d = d +fsep = liftList Ann.fsep +{-# INLINE fsep #-} -- --------------------------------------------------------------------------- -- Selecting the best layout -best :: Int -- Line length - -> Int -- Ribbon length - -> RDoc - -> RDoc -- 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 -> Doc -> Doc -> Doc -nicest !w !r = nicest1 w r 0 - -nicest1 :: Int -> Int -> Int -> Doc -> Doc -> Doc -nicest1 !w !r !sl p q | fits ((w `min` r) - sl) p = p - | otherwise = q - -fits :: Int -- Space available - -> Doc - -> Bool -- True if *first line* of Doc fits in space available -fits n _ | n < 0 = False -fits _ NoDoc = False -fits _ Empty = True -fits _ (NilAbove _) = True -fits n (TextBeside _ sl p) = fits (n - sl) p -fits _ (Above {}) = error "fits Above" -fits _ (Beside {}) = error "fits Beside" -fits _ (Union {}) = error "fits Union" -fits _ (Nest {}) = error "fits Nest" - -- | @first@ returns its first argument if it is non-empty, otherwise its second. first :: Doc -> Doc -> Doc -first p q | nonEmptySet p = p -- unused, because (get OneLineMode) is unused - | otherwise = q - -nonEmptySet :: Doc -> Bool -nonEmptySet NoDoc = False -nonEmptySet (_ `Union` _) = True -nonEmptySet Empty = True -nonEmptySet (NilAbove _) = True -nonEmptySet (TextBeside _ _ p) = nonEmptySet p -nonEmptySet (Nest _ p) = nonEmptySet p -nonEmptySet (Above {}) = error "nonEmptySet Above" -nonEmptySet (Beside {}) = error "nonEmptySet Beside" - --- @oneLiner@ returns the one-line members of the given set of @GDoc@s. -oneLiner :: Doc -> Doc -oneLiner NoDoc = NoDoc -oneLiner Empty = Empty -oneLiner (NilAbove _) = NoDoc -oneLiner (TextBeside s sl p) = textBeside_ s sl (oneLiner p) -oneLiner (Nest k p) = nest_ k (oneLiner p) -oneLiner (p `Union` _) = oneLiner p -oneLiner (Above {}) = error "oneLiner Above" -oneLiner (Beside {}) = error "oneLiner Beside" +first = liftBinary Ann.first +{-# INLINE first #-} -- --------------------------------------------------------------------------- -- 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 @Doc@ to a String using the default @Style@. render :: Doc -> String render = fullRender (mode style) (lineLength style) (ribbonsPerLine style) txtPrinter "" +{-# INLINE render #-} -- | Render the @Doc@ to a String using the given @Style@. renderStyle :: Style -> Doc -> String renderStyle s = fullRender (mode s) (lineLength s) (ribbonsPerLine s) txtPrinter "" +{-# INLINE renderStyle #-} -- | Default TextDetails printer txtPrinter :: TextDetails -> String -> String @@ -903,82 +438,7 @@ -> a -- ^ What to do at the end -> Doc -- ^ 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 - -> (Doc -> Doc -> Doc) - -> (TextDetails -> a -> a) - -> a - -> Doc - -> 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 -> a -> a) -> a -> Doc -> 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 - }} +fullRender m lineLen ribbons txt rest (Doc doc) + = Ann.fullRender m lineLen ribbons txt rest doc +{-# INLINE fullRender #-} diff --git a/tests/Test.hs b/tests/Test.hs --- a/tests/Test.hs +++ b/tests/Test.hs @@ -78,53 +78,53 @@ tdEq td1 td2 = (tdToStr td1) == (tdToStr td2) -- algebraic equality on reduced docs -docEq :: RDoc -> RDoc -> Bool +docEq :: RDoc () -> RDoc () -> Bool docEq rd1 rd2 = case (rd1, rd2) of (Empty, Empty) -> True (NoDoc, NoDoc) -> True (NilAbove ds1, NilAbove ds2) -> docEq ds1 ds2 - (TextBeside td1 l1 ds1, TextBeside td2 l2 ds2) | td1 `tdEq` td2 -> docEq ds1 ds2 + (TextBeside td1 ds1, TextBeside td2 ds2) | annotToTd td1 `tdEq` annotToTd td2 -> docEq ds1 ds2 (Nest k1 d1, Nest k2 d2) | k1 == k2 -> docEq d1 d2 (Union d11 d12, Union d21 d22) -> docEq d11 d21 && docEq d12 d22 (d1,d2) -> False -- algebraic equality, with text reduction -deq :: Doc -> Doc -> Bool +deq :: Doc () -> Doc () -> Bool deq d1 d2 = docEq (reduceDoc' d1) (reduceDoc' d2) where reduceDoc' = mergeTexts . reduceDoc -deqs :: [Doc] -> [Doc] -> Bool +deqs :: [Doc ()] -> [Doc ()] -> Bool deqs ds1 ds2 = case zipE ds1 ds2 of Nothing -> False (Just zds) -> all (uncurry deq) zds -zipLayouts :: Doc -> Doc -> Maybe [(Doc,Doc)] +zipLayouts :: Doc () -> Doc () -> Maybe [(Doc (),Doc ())] zipLayouts d1 d2 = zipE (reducedDocs d1) (reducedDocs d2) where reducedDocs = map mergeTexts . flattenDoc -zipE :: [Doc] -> [Doc] -> Maybe [(Doc, Doc)] +zipE :: [Doc ()] -> [Doc ()] -> Maybe [(Doc (), Doc ())] zipE l1 l2 | length l1 == length l2 = Just $ zip l1 l2 | otherwise = Nothing -- algebraic equality for layouts (without permutations) -lseq :: Doc -> Doc -> Bool +lseq :: Doc () -> Doc () -> Bool lseq d1 d2 = maybe False id . fmap (all (uncurry docEq)) $ zipLayouts d1 d2 -- abstract render equality for layouts -- should only be performed if the number of layouts is reasonably small -rdeq :: Doc -> Doc -> Bool +rdeq :: Doc () -> Doc () -> Bool rdeq d1 d2 = maybe False id . fmap (all (uncurry layoutEq)) $ zipLayouts d1 d2 where layoutEq d1 d2 = (abstractLayout d1) == (abstractLayout d2) -layoutsCountBounded :: Int -> [Doc] -> Bool +layoutsCountBounded :: Int -> [Doc ()] -> Bool layoutsCountBounded k docs = isBoundedBy k (concatMap flattenDoc docs) where isBoundedBy k [] = True isBoundedBy 0 (x:xs) = False isBoundedBy k (x:xs) = isBoundedBy (k-1) xs -layoutCountBounded :: Int -> Doc -> Bool +layoutCountBounded :: Int -> Doc () -> Bool layoutCountBounded k doc = layoutsCountBounded k [doc] maxLayouts :: Int @@ -134,7 +134,7 @@ infix 4 `lseq` infix 4 `rdeq` -debugRender :: Int -> Doc -> IO () +debugRender :: Int -> Doc () -> IO () debugRender k = putStr . visibleSpaces . renderStyle (Style PageMode k 1) visibleSpaces = unlines . map (map visibleSpace) . lines @@ -177,7 +177,7 @@ prop_t2 x = not (isEmpty x) ==> text "" <> x `deq` x prop_t2_a x = not (isEmpty x) && not (isNest x) ==> text "" <> x `deq` x -isNest :: Doc -> Bool +isNest :: Doc () -> Bool isNest d = case reduceDoc d of (Nest _ _) -> True (Union d1 d2) -> isNest d1 || isNest d2 @@ -282,13 +282,13 @@ hcat = foldr (<>) empty hsep = foldr (<+>) empty -} -prop_hcat :: [Doc] -> Bool +prop_hcat :: [Doc ()] -> Bool prop_hcat ds = hcat ds `deq` (foldr (<>) empty) ds -prop_hsep :: [Doc] -> Bool +prop_hsep :: [Doc ()] -> Bool prop_hsep ds = hsep ds `deq` (foldr (<+>) empty) ds -prop_vcat :: [Doc] -> Bool +prop_vcat :: [Doc ()] -> Bool prop_vcat ds = vcat ds `deq` (foldr ($$) empty) ds {- @@ -296,10 +296,10 @@ *failing* definition of sep: oneLiner (hsep ps) `union` vcat ps ? -} -prop_sep :: [Doc] -> Bool +prop_sep :: [Doc ()] -> Bool prop_sep ds = sep ds `rdeq` (sepDef ds) -sepDef :: [Doc] -> Doc +sepDef :: [Doc ()] -> Doc () sepDef docs = let ds = filter (not . isEmpty) docs in case ds of [] -> empty @@ -361,31 +361,31 @@ -- ==> (nest 1; text a; text b; nest -5 c) -} -prop_fcat_vcat :: [Doc] -> Bool +prop_fcat_vcat :: [Doc ()] -> Bool prop_fcat_vcat ds = last (flattenDoc $ fcat ds) `deq` last (flattenDoc $ vcat ds) -prop_fcat :: [Doc] -> Bool +prop_fcat :: [Doc ()] -> Bool prop_fcat ds = fcat ds `rdeq` fillDef False (filter (not . isEmpty) ds) -prop_fsep :: [Doc] -> Bool +prop_fsep :: [Doc ()] -> Bool prop_fsep ds = fsep ds `rdeq` fillDef True (filter (not . isEmpty) ds) -prop_fcat_old :: [Doc] -> Bool +prop_fcat_old :: [Doc ()] -> Bool prop_fcat_old ds = fillOld2 False ds `rdeq` fillDef False (filter (not . isEmpty) ds) -prop_fcat_old_old :: [Doc] -> Bool +prop_fcat_old_old :: [Doc ()] -> Bool prop_fcat_old_old ds = fillOld2 False ds `rdeq` fillDefOld False (filter (not . isEmpty) ds) -prop_restrict_sz :: (Testable a) => Int -> ([Doc] -> a) -> ([Doc] -> Property) +prop_restrict_sz :: (Testable a) => Int -> ([Doc ()] -> a) -> ([Doc ()] -> Property) prop_restrict_sz k p ds = layoutCountBounded k (fsep ds) ==> p ds -prop_restrict_ol :: (Testable a) => ([Doc] -> a) -> ([Doc] -> Property) +prop_restrict_ol :: (Testable a) => ([Doc ()] -> a) -> ([Doc ()] -> Property) prop_restrict_ol p ds = (all isOneLiner . map normalize $ ds) ==> p ds -prop_restrict_no_nest_start :: (Testable a) => ([Doc] -> a) -> ([Doc] -> Property) +prop_restrict_no_nest_start :: (Testable a) => ([Doc ()] -> a) -> ([Doc ()] -> Property) prop_restrict_no_nest_start p ds = (all (not .isNest) ds) ==> p ds -fillDef :: Bool -> [Doc] -> Doc +fillDef :: Bool -> [Doc ()] -> Doc () fillDef g = normalize . fill' 0 . filter (not.isEmpty) . map reduceDoc where fill' _ [] = Empty @@ -402,7 +402,7 @@ oneLiner' (Nest k d) = oneLiner' d oneLiner' d = oneLiner d -($*$) :: RDoc -> RDoc -> RDoc +($*$) :: RDoc () -> RDoc () -> RDoc () ($*$) p ps = case flattenDoc p of [] -> NoDoc ls -> foldr1 Union (map combine ls) @@ -410,7 +410,7 @@ combine p | isOneLiner p = p $+$ ps | otherwise = p $$ ps -fillDefOld :: Bool -> [Doc] -> Doc +fillDefOld :: Bool -> [Doc ()] -> Doc () fillDefOld g = normalize . fill' . filter (not.isEmpty) . map normalize where fill' [] = Empty fill' [p1] = p1 @@ -421,7 +421,7 @@ append = if g then (<+>) else (<>) union = Union -check_fill_prop :: Testable a => String -> ([Doc] -> a) -> IO () +check_fill_prop :: Testable a => String -> ([Doc ()] -> a) -> IO () check_fill_prop msg p = myTest msg (prop_restrict_sz maxLayouts p . buildDocList) check_fill_def_fail :: IO () @@ -486,7 +486,7 @@ recurse a = (a,True) -- strategy: generic synthesize with stop condition -- terms are combined top-down, left-right (latin text order) -genericProp :: (a -> a -> a) -> (Doc -> (a,Bool)) -> Doc -> a +genericProp :: (a -> a -> a) -> (Doc () -> (a,Bool)) -> Doc () -> a genericProp c q doc = case q doc of (v,False) -> v @@ -496,7 +496,7 @@ subs d = case d of Empty -> [] NilAbove d -> [rec d] - TextBeside _ _ d -> [rec d] + TextBeside _ d -> [rec d] Nest _ d -> [rec d] Union d1 d2 -> [rec d1, rec d2] NoDoc -> [] @@ -508,7 +508,7 @@ * The argument of NilAbove is never Empty. Therefore a NilAbove occupies at least two lines. -} -prop_inv1 :: Doc -> Bool +prop_inv1 :: Doc () -> Bool prop_inv1 d = genericProp (&&) nilAboveNotEmpty d where nilAboveNotEmpty (NilAbove Empty) = stop False nilAboveNotEmpty _ = recurse True @@ -516,15 +516,15 @@ {- * The argument of @TextBeside@ is never @Nest@. -} -prop_inv2 :: Doc -> Bool +prop_inv2 :: Doc () -> Bool prop_inv2 = genericProp (&&) textBesideNotNest where - textBesideNotNest (TextBeside _ _ (Nest _ _)) = stop False + textBesideNotNest (TextBeside _ (Nest _ _)) = stop False textBesideNotNest _ = recurse True {- * The layouts of the two arguments of @Union@ both flatten to the same string -} -prop_inv3 :: Doc -> Bool +prop_inv3 :: Doc () -> Bool prop_inv3 = genericProp (&&) unionsFlattenSame where unionsFlattenSame (Union d1 d2) = stop (pairwiseEqual (extractTexts d1 ++ extractTexts d2)) unionsFlattenSame _ = recurse True @@ -535,12 +535,12 @@ {- * The arguments of @Union@ are either @TextBeside@, or @NilAbove@. -} -prop_inv4 :: Doc -> Bool +prop_inv4 :: Doc () -> Bool prop_inv4 = genericProp (&&) unionArgs where unionArgs (Union d1 d2) | goodUnionArg d1 && goodUnionArg d2 = recurse True | otherwise = stop False unionArgs _ = recurse True - goodUnionArg (TextBeside _ _ _) = True + goodUnionArg (TextBeside _ _) = True goodUnionArg (NilAbove _) = True goodUnionArg _ = False @@ -549,7 +549,7 @@ an union. Therefore, the right argument of an union can never be equivalent to the empty set. -} -prop_inv5 :: Doc -> Bool +prop_inv5 :: Doc () -> Bool prop_inv5 = genericProp (&&) unionArgs . reduceDoc where unionArgs NoDoc = stop False unionArgs (Union d1 d2) = stop $ genericProp (&&) noDocIsFirstLine d1 && nonEmptySet (reduceDoc d2) @@ -561,19 +561,19 @@ * An empty document is always represented by @Empty@. It can't be hidden inside a @Nest@, or a @Union@ of two @Empty@s. -} -prop_inv6 :: Doc -> Bool +prop_inv6 :: Doc () -> Bool prop_inv6 d | not (prop_inv1 d) || not (prop_inv2 d) = False | not (isEmptyDoc d) = True | otherwise = case d of Empty -> True ; _ -> False -isEmptyDoc :: Doc -> Bool +isEmptyDoc :: Doc () -> Bool isEmptyDoc d = case emptyReduction d of Empty -> True; _ -> False {- * Consistency If all arguments of one of the list versions are empty documents, the list is an empty document -} -prop_inv6a :: ([Doc] -> Doc) -> Property +prop_inv6a :: ([Doc ()] -> Doc ()) -> Property prop_inv6a sep = forAll emptyDocListGen $ \ds -> isEmptyRepr (sep $ buildDocList ds) where @@ -589,7 +589,7 @@ -} counterexample_inv7 = cat [ text " ", nest 2 ( text "a") ] -prop_inv7 :: Doc -> Bool +prop_inv7 :: Doc () -> Bool prop_inv7 = genericProp (&&) firstLonger where firstLonger (Union d1 d2) = (firstLineLength d1 >= firstLineLength d2, True) firstLonger _ = (True, True) @@ -654,13 +654,13 @@ noNegSpaces = go 0 . reduceDoc where go k Empty = True go k (NilAbove d) = go k d - go k (TextBeside _ s d) | k < 0 = False - go k (TextBeside _ s d) = go (k+s) d + go k (TextBeside _ d) | k < 0 = False + go k (TextBeside s d) = go (k+annotSize s) d go k (Nest k' d) = go (k+k') d go k (Union d1 d2) = (if nonEmptySet d1 then (&&) (go k d1) else id) (go k d2) go k NoDoc = True -counterexample_fail9 :: Doc +counterexample_fail9 :: Doc () counterexample_fail9 = text "a" <> ( nest 2 ( text "b") $$ text "c") -- reduces to textb "a" ; textb "b" ; nilabove ; nest -3 ; textb "c" ; empty @@ -742,7 +742,7 @@ extractTextZZ :: String -> String extractTextZZ = filter (\c -> not (isSpace c) && c /= '/' && c /= '\\') -punctuateDef :: Doc -> [Doc] -> [Doc] +punctuateDef :: Doc () -> [Doc ()] -> [Doc ()] punctuateDef p [] = [] punctuateDef p ps = let (dsInit,dLast) = (init ps, last ps) in @@ -759,7 +759,7 @@ c c c b -} -prop_fill_empty_reduce :: [Doc] -> Bool +prop_fill_empty_reduce :: [Doc ()] -> Bool prop_fill_empty_reduce ds = fill True ds `deq` fillOld True (filter (not.isEmpty.reduceDoc) ds) check_improvements :: IO () @@ -768,10 +768,10 @@ (prop_fill_empty_reduce . filter (not .isNest) . buildDocList) -- old implementation of fill -fillOld :: Bool -> [Doc] -> RDoc +fillOld :: Bool -> [Doc ()] -> RDoc () fillOld _ [] = empty fillOld g (p:ps) = fill1 g (reduceDoc p) 0 ps where - fill1 :: Bool -> RDoc -> Int -> [Doc] -> Doc + fill1 :: Bool -> RDoc () -> Int -> [Doc ()] -> Doc () fill1 _ _ k _ | k `seq` False = undefined fill1 _ NoDoc _ _ = NoDoc fill1 g (p `Union` q) k ys = fill1 g p k ys @@ -782,11 +782,11 @@ fill1 g (Nest n p) k ys = nest_ n (fill1 g p (k - n) ys) fill1 g (NilAbove p) k ys = nilAbove_ (aboveNest p False k (fillOld g ys)) - fill1 g (TextBeside s sl p) k ys = textBeside_ s sl (fillNB g p (k - sl) ys) + fill1 g (TextBeside s p) k ys = textBeside_ s (fillNB g p (k - annotSize s) ys) fill1 _ (Above {}) _ _ = error "fill1 Above" fill1 _ (Beside {}) _ _ = error "fill1 Beside" -- fillNB gap textBesideArgument space_left docs - fillNB :: Bool -> Doc -> Int -> [Doc] -> Doc + fillNB :: Bool -> Doc () -> Int -> [Doc ()] -> Doc () fillNB _ _ k _ | k `seq` False = undefined fillNB g (Nest _ p) k ys = fillNB g p k ys fillNB _ Empty _ [] = Empty @@ -806,10 +806,10 @@ -- (fill (oneLiner p2 : ps)) -- `union` -- p1 $$ fill ps -fillOld2 :: Bool -> [Doc] -> RDoc +fillOld2 :: Bool -> [Doc ()] -> RDoc () fillOld2 _ [] = empty fillOld2 g (p:ps) = fill1 g (reduceDoc p) 0 ps where - fill1 :: Bool -> RDoc -> Int -> [Doc] -> Doc + fill1 :: Bool -> RDoc () -> Int -> [Doc ()] -> Doc () fill1 _ _ k _ | k `seq` False = undefined fill1 _ NoDoc _ _ = NoDoc fill1 g (p `Union` q) k ys = fill1 g p k ys @@ -820,11 +820,11 @@ 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 g (TextBeside s p) k ys = textBeside_ s (fillNB g p (k - annotSize s) ys) fill1 _ (Above {}) _ _ = error "fill1 Above" fill1 _ (Beside {}) _ _ = error "fill1 Beside" - fillNB :: Bool -> Doc -> Int -> [Doc] -> Doc + fillNB :: Bool -> Doc () -> Int -> [Doc ()] -> Doc () fillNB _ _ k _ | k `seq` False = undefined fillNB g (Nest _ p) k ys = fillNB g p k ys fillNB _ Empty _ [] = Empty @@ -841,36 +841,36 @@ -- (5) Pretty printing RDocs and RDOC properties -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -prettyDoc :: Doc -> Doc +prettyDoc :: Doc () -> Doc () prettyDoc d = case reduceDoc d of Empty -> text "empty" NilAbove d -> (text "nilabove") <> semi <+> (prettyDoc d) - TextBeside s sl d -> (text ("text \""++tdToStr s ++ "\"" ++ show sl)) <> semi <+> (prettyDoc d) + TextBeside s d -> (text ("text \""++tdToStr (annotToTd s) ++ "\"" ++ show (annotSize s))) <> semi <+> (prettyDoc d) Nest k d -> text "nest" <+> integer (fromIntegral k) <> semi <+> prettyDoc d Union d1 d2 -> sep [text "union", parens (prettyDoc d1), parens (prettyDoc d2)] NoDoc -> text "nodoc" -- TODO: map strategy for Docs to avoid code duplication -- Debug: Doc -> [Layout] -flattenDoc :: Doc -> [RDoc] +flattenDoc :: Doc () -> [RDoc ()] flattenDoc d = flatten (reduceDoc d) where flatten NoDoc = [] flatten Empty = return Empty flatten (NilAbove d) = map NilAbove (flatten d) - flatten (TextBeside s sl d) = map (TextBeside s sl) (flatten d) + flatten (TextBeside s d) = map (TextBeside s) (flatten d) flatten (Nest k d) = map (Nest k) (flatten d) flatten (Union d1 d2) = flattenDoc d1 ++ flattenDoc d2 flatten (Beside d1 b d2) = error $ "flattenDoc Beside" flatten (Above d1 b d2) = error $ "flattenDoc Above" -normalize :: Doc -> RDoc +normalize :: Doc () -> RDoc () normalize d = norm d where norm NoDoc = NoDoc norm Empty = Empty norm (NilAbove d) = NilAbove (norm d) - norm (TextBeside s sl (Nest k d)) = norm (TextBeside s sl d) - norm (TextBeside s sl d) = (TextBeside s sl) (norm d) + norm (TextBeside s (Nest k d)) = norm (TextBeside s d) + norm (TextBeside s d) = (TextBeside s) (norm d) norm (Nest k (Nest k' d)) = norm $ Nest (k+k') d norm (Nest 0 d) = norm d norm (Nest k d) = (Nest k) (norm d) @@ -886,37 +886,39 @@ normUnion d1 (Nest _ _) = error$ "normUnion Nset "++topLevelCTor d1 normUnion p1 p2 = Union p1 p2 -topLevelCTor :: Doc -> String +topLevelCTor :: Doc () -> String topLevelCTor d = tlc d where tlc NoDoc = "NoDoc" tlc Empty = "Empty" tlc (NilAbove d) = "NilAbove" - tlc (TextBeside s sl d) = "TextBeside" + tlc (TextBeside s d) = "TextBeside" tlc (Nest k d) = "Nest" tlc (Union d1 d2) = "Union" tlc (Above _ _ _) = "Above" tlc (Beside _ _ _) = "Beside" -- normalize TextBeside (and consequently apply some laws for simplification) -mergeTexts :: RDoc -> RDoc +mergeTexts :: RDoc () -> RDoc () mergeTexts = merge where merge NoDoc = NoDoc merge Empty = Empty merge (NilAbove d) = NilAbove (merge d) - merge (TextBeside t1 l1 (TextBeside t2 l2 doc)) = (merge.normalize) (TextBeside (mergeText t1 t2) (l1 +l2) doc) - merge (TextBeside s sl d) = TextBeside s sl (merge d) + merge (TextBeside t1 (TextBeside t2 doc)) = (merge.normalize) (TextBeside (mergeText t1 t2) doc) + merge (TextBeside s d) = TextBeside s (merge d) merge (Nest k d) = Nest k (merge d) merge (Union d1 d2) = Union (merge d1) (merge d2) - mergeText t1 t2 = Str $ tdToStr t1 ++ tdToStr t2 + mergeText t1 t2 = + NoAnnot (Str $ tdToStr (annotToTd t1) ++ tdToStr (annotToTd t2)) + (annotSize t1 + annotSize t2) -isOneLiner :: RDoc -> Bool +isOneLiner :: RDoc () -> Bool isOneLiner = genericProp (&&) iol where iol (NilAbove _) = stop False iol (Union _ _) = stop False iol NoDoc = stop False iol _ = recurse True -hasOneLiner :: RDoc -> Bool +hasOneLiner :: RDoc () -> Bool hasOneLiner = genericProp (&&) iol where iol (NilAbove _) = stop False iol (Union d1 _) = stop $ hasOneLiner d1 @@ -924,10 +926,10 @@ iol _ = recurse True -- use elementwise concatenation as generic combinator -extractTexts :: Doc -> [String] +extractTexts :: Doc () -> [String] extractTexts = map normWS . genericProp combine go where combine xs ys = [ a ++ b | a <- xs, b <- ys ] - go (TextBeside s _ _ ) = recurse [tdToStr s] + go (TextBeside s _ ) = recurse [tdToStr (annotToTd s)] go (Union d1 d2) = stop $ extractTexts d1 ++ extractTexts d2 go NoDoc = stop [] go _ = recurse [""] @@ -936,35 +938,35 @@ isWS ws | ws == ' ' || ws == '\n' || ws == '\t' = True | otherwise = False -emptyReduction :: Doc -> Doc +emptyReduction :: Doc () -> Doc () emptyReduction doc = case doc of Empty -> Empty NilAbove d -> case emptyReduction d of Empty -> Empty ; d' -> NilAbove d' - TextBeside s sl d -> TextBeside s sl (emptyReduction d) + TextBeside s d -> TextBeside s (emptyReduction d) Nest k d -> case emptyReduction d of Empty -> Empty; d -> Nest k d Union d1 d2 -> case emptyReduction d2 of Empty -> Empty; _ -> Union d1 d2 -- if d2 is empty, both have to be NoDoc -> NoDoc Beside d1 _ d2 -> emptyReduction (reduceDoc doc) Above d1 _ d2 -> emptyReduction (reduceDoc doc) -firstLineLength :: Doc -> Int +firstLineLength :: Doc () -> Int firstLineLength = genericProp (+) fll . reduceDoc where fll (NilAbove d) = stop 0 - fll (TextBeside _ l d) = recurse l + fll (TextBeside s d) = recurse (annotSize s) fll (Nest k d) = recurse k fll (Union d1 d2) = stop (firstLineLength d1) -- inductively assuming inv7 fll (Above _ _ _) = error "Above" fll (Beside _ _ _) = error "Beside" fll _ = (0,True) -abstractLayout :: Doc -> [(Int,String)] +abstractLayout :: Doc () -> [(Int,String)] abstractLayout d = cal 0 Nothing (reduceDoc d) where -- current column -> this line -> doc -> [(indent,line)] - cal :: Int -> (Maybe (Int,String)) -> Doc -> [(Int,String)] + cal :: Int -> (Maybe (Int,String)) -> Doc () -> [(Int,String)] cal k cur Empty = [ addTextEOL k (Str "") cur ] cal k cur (NilAbove d) = (addTextEOL k (Str "") cur) : cal k Nothing d - cal k cur (TextBeside s sl d) = cal (k+sl) (addText k s cur) d + cal k cur (TextBeside s d) = cal (k + annotSize s) (addText k s cur) d cal k cur (Nest n d) = cal (k+n) cur d cal _ _ (Union d1 d2) = error "abstractLayout: Union" cal _ _ NoDoc = error "NoDoc" @@ -972,23 +974,23 @@ cal _ _ (Beside _ _ _) = error "Beside" addTextEOL k str Nothing = (k,tdToStr str) addTextEOL _ str (Just (k,pre)) = (k,pre++ tdToStr str) - addText k str = Just . addTextEOL k str + addText k str = Just . addTextEOL k (annotToTd str) -docifyLayout :: [(Int,String)] -> Doc +docifyLayout :: [(Int,String)] -> Doc () docifyLayout = vcat . map (\(k,t) -> nest k (text t)) -oneLineRender :: Doc -> String +oneLineRender :: Doc () -> String oneLineRender = olr . abstractLayout . last . flattenDoc where olr = concat . intersperse " " . map snd -- because of invariant 4, we do not have to expand to layouts here -- but it is easier, so for now we use abstractLayout -firstLineIsLeftMost :: Doc -> Bool +firstLineIsLeftMost :: Doc () -> Bool firstLineIsLeftMost = all (firstIsLeftMost . abstractLayout) . flattenDoc where firstIsLeftMost ((k,_):xs@(_:_)) = all ( (>= k) . fst) xs firstIsLeftMost _ = True -noNegativeIndent :: Doc -> Bool +noNegativeIndent :: Doc () -> Bool noNegativeIndent = all (noNegIndent . abstractLayout) . flattenDoc where noNegIndent = all ( (>= 0) . fst) diff --git a/tests/TestStructures.hs b/tests/TestStructures.hs --- a/tests/TestStructures.hs +++ b/tests/TestStructures.hs @@ -9,7 +9,7 @@ CDoc(..), CList(..), CDocList(..), Text(..), buildDoc, liftDoc2, liftDoc3, buildDocList, - text', tdToStr, genericCProp + text', annotToTd, tdToStr, genericCProp ) where import PrettyTestVersion @@ -44,7 +44,7 @@ instance Show CDocList where show = show . unDocList -buildDoc :: CDoc -> Doc +buildDoc :: CDoc -> Doc () buildDoc CEmpty = empty buildDoc (CText s) = text s buildDoc (CList sp ds) = (listComb sp) $ map buildDoc ds @@ -52,20 +52,24 @@ buildDoc (CAbove noOvlap d1 d2) = (if noOvlap then ($+$) else ($$)) (buildDoc d1) (buildDoc d2) buildDoc (CNest k d) = nest k $ buildDoc d -listComb :: CList -> ([Doc] -> Doc) +listComb :: CList -> ([Doc ()] -> Doc ()) listComb cs = case cs of CCat -> cat ; CSep -> sep ; CFCat -> fcat ; CFSep -> fsep -liftDoc2 :: (Doc -> Doc -> a) -> (CDoc -> CDoc -> a) +liftDoc2 :: (Doc () -> Doc () -> a) -> (CDoc -> CDoc -> a) liftDoc2 f cd1 cd2 = f (buildDoc cd1) (buildDoc cd2) -liftDoc3 :: (Doc -> Doc -> Doc -> a) -> (CDoc -> CDoc -> CDoc -> a) +liftDoc3 :: (Doc () -> Doc () -> Doc () -> a) -> (CDoc -> CDoc -> CDoc -> a) liftDoc3 f cd1 cd2 cd3 = f (buildDoc cd1) (buildDoc cd2) (buildDoc cd3) -buildDocList :: CDocList -> [Doc] +buildDocList :: CDocList -> [Doc ()] buildDocList = map buildDoc . unDocList -text' :: Text -> Doc +text' :: Text -> Doc () text' (Text str) = text str + +annotToTd :: AnnotDetails a -> TextDetails +annotToTd (NoAnnot s _) = s +annotToTd _ = Str "" -- convert text details to string tdToStr :: TextDetails -> String