packages feed

pretty 1.1.2.1 → 1.1.3.1

raw patch · 7 files changed

+1548/−697 lines, 7 filesdep ~base

Dependency ranges changed: base

Files

pretty.cabal view
@@ -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
+ src/Text/PrettyPrint/Annotated.hs view
@@ -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 <code@davidterei.com>+-- 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+
+ src/Text/PrettyPrint/Annotated/HughesPJ.hs view
@@ -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 <code@davidterei.com>+-- 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+-- <http://belle.sourceforge.net/doc/hughes95design.pdf original paper> 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 $$+~~~~~~~~~~~+<a1>    (x $$ y) $$ z   = x $$ (y $$ z)+<a2>    empty $$ x      = x+<a3>    x $$ empty      = x++        ...ditto $+$...++Laws for <>+~~~~~~~~~~~+<b1>    (x <> y) <> z   = x <> (y <> z)+<b2>    empty <> x      = empty+<b3>    x <> empty      = x++        ...ditto <+>...++Laws for text+~~~~~~~~~~~~~+<t1>    text s <> text t        = text (s++t)+<t2>    text "" <> x            = x, if x non-empty++** because of law n6, t2 only holds if x doesn't+** start with `nest'.+++Laws for nest+~~~~~~~~~~~~~+<n1>    nest 0 x                = x+<n2>    nest k (nest k' x)      = nest (k+k') x+<n3>    nest k (x <> y)         = nest k x <> nest k y+<n4>    nest k (x $$ y)         = nest k x $$ nest k y+<n5>    nest k empty            = empty+<n6>    x <> nest k y           = x <> y, if x non-empty++** Note the side condition on <n6>!  It is this that+** makes it OK for empty to be a left unit for <>.++Miscellaneous+~~~~~~~~~~~~~+<m1>    (text s <> x) $$ y = text s <> ((text "" <> x) $$+                                         nest (-length s) y)++<m2>    (x $$ y) <> z = x $$ (y <> z)+        if y non-empty+++Laws for list versions+~~~~~~~~~~~~~~~~~~~~~~+<l1>    sep (ps++[empty]++qs)   = sep (ps ++ qs)+        ...ditto hsep, hcat, vcat, fill...++<l2>    nest k (sep ps) = sep (map (nest k) ps)+        ...ditto hsep, hcat, vcat, fill...++Laws for oneLiner+~~~~~~~~~~~~~~~~~+<o1>    oneLiner (nest k p) = nest k (oneLiner p)+<o2>    oneLiner (x <> y)   = oneLiner x <> oneLiner y++You might think that the following verion of <m1> would+be neater:++<3 NO>  (text s <> x) $$ y = text s <> ((empty <> x)) $$+                                         nest (-length s) y)++But it doesn't work, for if x=empty, we would have++        text s $$ y = text s <> (empty $$ nest (-length s) y)+                    = text s <> nest (-length s) y+-}++-- ---------------------------------------------------------------------------+-- 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 <n6> (<> 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 <g> 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 "" <g> 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 <g> 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 <g> 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
+ src/Text/PrettyPrint/Annotated/HughesPJClass.hs view
@@ -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 <code@davidterei.com>+-- 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]+
src/Text/PrettyPrint/HughesPJ.hs view
@@ -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 $$-~~~~~~~~~~~-<a1>    (x $$ y) $$ z   = x $$ (y $$ z)-<a2>    empty $$ x      = x-<a3>    x $$ empty      = x--        ...ditto $+$...--Laws for <>-~~~~~~~~~~~-<b1>    (x <> y) <> z   = x <> (y <> z)-<b2>    empty <> x      = empty-<b3>    x <> empty      = x--        ...ditto <+>...--Laws for text-~~~~~~~~~~~~~-<t1>    text s <> text t        = text (s++t)-<t2>    text "" <> x            = x, if x non-empty--** because of law n6, t2 only holds if x doesn't-** start with `nest'.---Laws for nest-~~~~~~~~~~~~~-<n1>    nest 0 x                = x-<n2>    nest k (nest k' x)      = nest (k+k') x-<n3>    nest k (x <> y)         = nest k x <> nest k y-<n4>    nest k (x $$ y)         = nest k x $$ nest k y-<n5>    nest k empty            = empty-<n6>    x <> nest k y           = x <> y, if x non-empty--** Note the side condition on <n6>!  It is this that-** makes it OK for empty to be a left unit for <>.--Miscellaneous-~~~~~~~~~~~~~-<m1>    (text s <> x) $$ y = text s <> ((text "" <> x) $$-                                         nest (-length s) y)--<m2>    (x $$ y) <> z = x $$ (y <> z)-        if y non-empty---Laws for list versions-~~~~~~~~~~~~~~~~~~~~~~-<l1>    sep (ps++[empty]++qs)   = sep (ps ++ qs)-        ...ditto hsep, hcat, vcat, fill...--<l2>    nest k (sep ps) = sep (map (nest k) ps)-        ...ditto hsep, hcat, vcat, fill...--Laws for oneLiner-~~~~~~~~~~~~~~~~~-<o1>    oneLiner (nest k p) = nest k (oneLiner p)-<o2>    oneLiner (x <> y)   = oneLiner x <> oneLiner y--You might think that the following verion of <m1> would-be neater:--<3 NO>  (text s <> x) $$ y = text s <> ((empty <> x)) $$-                                         nest (-length s) y)--But it doesn't work, for if x=empty, we would have--        text s $$ y = text s <> (empty $$ nest (-length s) y)-                    = text s <> nest (-length s) y--}- -- --------------------------------------------------------------------------- -- 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 <n6> (<> 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 <g> 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 "" <g> 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 <g> 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 <g> 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 #-}
tests/Test.hs view
@@ -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 @@ <ldef2> hcat = foldr (<>) empty <ldef3> 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 <ldef4> ? -}-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)
tests/TestStructures.hs view
@@ -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