Build in compatibility with the old pretty API
authorTrevor Elliott <trevor@galois.com>
Sat, 24 Jan 2015 20:19:19 +0000 (12:19 -0800)
committerTrevor Elliott <trevor@galois.com>
Sat, 24 Jan 2015 20:19:19 +0000 (12:19 -0800)
src/Text/PrettyPrint/Annotated.hs [new file with mode: 0644]
src/Text/PrettyPrint/Annotated/HughesPJ.hs [new file with mode: 0644]
src/Text/PrettyPrint/Annotated/HughesPJClass.hs [new file with mode: 0644]
src/Text/PrettyPrint/HughesPJ.hs
src/Text/PrettyPrint/HughesPJClass.hs

diff --git a/src/Text/PrettyPrint/Annotated.hs b/src/Text/PrettyPrint/Annotated.hs
new file mode 100644 (file)
index 0000000..3bfc353
--- /dev/null
@@ -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.PrettyPrintAnnotated ( 
+
+        -- * The document type
+        Doc,
+
+        -- * Constructing documents
+
+        -- ** Converting values into documents
+        char, text, ptext, sizedText, zeroWidthText,
+        int, integer, float, double, rational,
+
+        -- ** Simple derived documents
+        semi, comma, colon, space, equals,
+        lparen, rparen, lbrack, rbrack, lbrace, rbrace,
+
+        -- ** Wrapping documents in delimiters
+        parens, brackets, braces, quotes, doubleQuotes,
+
+        -- ** Combining documents
+        empty,
+        (<>), (<+>), hcat, hsep,
+        ($$), ($+$), vcat,
+        sep, cat,
+        fsep, fcat,
+        nest,
+        hang, punctuate,
+
+        -- ** Annotating documents
+        annotate,
+
+        -- * Predicates on documents
+        isEmpty,
+
+        -- * Rendering documents
+
+        -- ** Default rendering
+        render,
+
+        -- ** Annotation rendering
+        renderSpans, Span(..),
+
+        -- ** Rendering with a particular style
+        Style(..),
+        style,
+        renderStyle,
+
+        -- ** General rendering
+        fullRender,
+        fullRenderAnn,
+        Mode(..), TextDetails(..)
+
+    ) where
+
+import Text.PrettyPrint.Annotated.HughesPJ
+
diff --git a/src/Text/PrettyPrint/Annotated/HughesPJ.hs b/src/Text/PrettyPrint/Annotated/HughesPJ.hs
new file mode 100644 (file)
index 0000000..971a53f
--- /dev/null
@@ -0,0 +1,1098 @@
+{-# 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(..),
+
+        -- ** 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 a
+                    | NoAnnot TextDetails {-# UNPACK #-} !Int
+                    | AnnotEnd
+                      deriving (Show,Eq)
+
+instance Functor AnnotDetails where
+  fmap f (AnnotStart a) = AnnotStart (f a)
+  fmap _ (NoAnnot d i)  = NoAnnot d i
+  fmap _ AnnotEnd       = AnnotEnd
+
+-- 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 a) = rnf a
+  rnf (NoAnnot d sl) = rnf d `seq` rnf sl
+  rnf AnnotEnd       = ()
+
+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 a)
+             $ beside (reduceDoc d) False
+             $ TextBeside AnnotEnd 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 -> a -> 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 end start a = 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 a) s =
+    case sStack s of
+      sp : rest -> s { sSpans = sp (sOffset s) a : sSpans s, sStack = rest }
+      _         -> error "renderSpans: stack underflow"
+
+  spanPrinter AnnotEnd s =
+    s { sStack = mkSpan (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 }
diff --git a/src/Text/PrettyPrint/Annotated/HughesPJClass.hs b/src/Text/PrettyPrint/Annotated/HughesPJClass.hs
new file mode 100644 (file)
index 0000000..4e2b2c7
--- /dev/null
@@ -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]
+
index a892faf..090b222 100644 (file)
@@ -33,7 +33,7 @@
 module Text.PrettyPrint.HughesPJ (
 
         -- * The document type
-        Doc, TextDetails(..), AnnotDetails(..),
+        Doc, TextDetails(..),
 
         -- * Constructing documents
 
@@ -58,9 +58,6 @@ module Text.PrettyPrint.HughesPJ (
         nest,
         hang, punctuate,
 
-        -- ** Annotating documents
-        annotate,
-
         -- * Predicates on documents
         isEmpty,
 
@@ -72,9 +69,6 @@ module Text.PrettyPrint.HughesPJ (
         -- ** Default rendering
         render,
 
-        -- ** Annotation rendering
-        renderSpans, Span(..),
-
         -- ** Rendering with a particular style
         Style(..),
         style,
@@ -82,12 +76,15 @@ module Text.PrettyPrint.HughesPJ (
         Mode(..),
 
         -- ** General rendering
-        fullRender,
-        fullRenderAnn
+        fullRender
 
     ) 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
@@ -97,80 +94,6 @@ 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
@@ -185,143 +108,50 @@ infixl 5 $$, $+$
 -- | 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
+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.
+liftList :: ([Ann.Doc ()] -> Ann.Doc ()) -> ([Doc] -> Doc)
+liftList f ds = Doc (f [ d | Doc d <- ds ])
+{-# INLINE liftList #-}
 
-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)
--}
+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
 
-data AnnotDetails a = AnnotStart a
-                    | NoAnnot TextDetails {-# UNPACK #-} !Int
-                    | AnnotEnd
-                      deriving (Show,Eq)
-
-instance Functor AnnotDetails where
-  fmap f (AnnotStart a) = AnnotStart (f a)
-  fmap _ (NoAnnot d i)  = NoAnnot d i
-  fmap _ AnnotEnd       = AnnotEnd
-
--- 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
+instance Monoid Doc where
     mempty  = empty
     mappend = (<>)
 
-instance IsString (Doc a) where
+instance IsString Doc where
     fromString = text
 
-instance Show (Doc a) where
+instance Show Doc where
   showsPrec _ doc cont = fullRender (mode style) (lineLength style)
                                     (ribbonsPerLine style)
                                     txtPrinter cont doc
 
-instance Eq (Doc a) where
+instance Eq Doc 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 a) = rnf a
-  rnf (NoAnnot d sl) = rnf d `seq` rnf sl
-  rnf AnnotEnd       = ()
-
-instance NFData TextDetails where
-  rnf (Chr c)    = rnf c
-  rnf (Str str)  = rnf str
-  rnf (PStr str) = rnf str
+instance NFData Doc where
+  rnf (Doc a) = rnf a
 
 -- ---------------------------------------------------------------------------
 -- Values and Predicates on GDocs and TextDetails
 
--- | Attach an annotation to a document.
-annotate :: a -> Doc a -> Doc a
-annotate a d = TextBeside (AnnotStart a)
-             $ beside (reduceDoc d) False
-             $ TextBeside AnnotEnd Empty
-
-
 -- | A document of height and width 1, containing a literal character.
-char :: Char -> Doc a
-char c = textBeside_ (NoAnnot (Chr c) 1) Empty
+char :: Char -> Doc
+char c = Doc (Ann.char c)
+{-# INLINE char #-}
 
 -- | A document of height 1 containing a literal string.
 -- 'text' satisfies the following laws:
@@ -332,81 +162,45 @@ char c = textBeside_ (NoAnnot (Chr c) 1) 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}
+text :: String -> Doc
+text s = Doc (Ann.text s)
+{-# INLINE text #-}
 
 -- | 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}
+ptext :: String -> Doc
+ptext s = Doc (Ann.ptext s)
+{-# INLINE ptext #-}
 
 -- | 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
+sizedText :: Int -> String -> Doc
+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
-zeroWidthText :: String -> Doc a
+zeroWidthText :: String -> Doc
 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
+empty :: Doc
+empty = Doc Ann.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
+isEmpty :: Doc -> Bool
+isEmpty (Doc d) = Ann.isEmpty d
+
+semi   :: Doc -- ^ A ';' character
+comma  :: Doc -- ^ A ',' character
+colon  :: Doc -- ^ A ':' character
+space  :: Doc -- ^ A space character
+equals :: Doc -- ^ A '=' character
+lparen :: Doc -- ^ A '(' character
+rparen :: Doc -- ^ A ')' character
+lbrack :: Doc -- ^ A '[' character
+rbrack :: Doc -- ^ A ']' character
+lbrace :: Doc -- ^ A '{' character
+rbrace :: Doc -- ^ A '}' character
 semi   = char ';'
 comma  = char ','
 colon  = char ':'
@@ -419,26 +213,22 @@ 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      :: Int      -> Doc -- ^ @int n = text (show n)@
+integer  :: Integer  -> Doc -- ^ @integer n = text (show n)@
+float    :: Float    -> Doc -- ^ @float n = text (show n)@
+double   :: Double   -> Doc -- ^ @double n = text (show n)@
+rational :: Rational -> Doc -- ^ @rational n = text (show n)@
 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 @\"...\"@
+parens       :: Doc -> Doc -- ^ Wrap document in @(...)@
+brackets     :: Doc -> Doc -- ^ Wrap document in @[...]@
+braces       :: Doc -> Doc -- ^ Wrap document in @{...}@
+quotes       :: Doc -> Doc -- ^ Wrap document in @\'...\'@
+doubleQuotes :: Doc -> Doc -- ^ Wrap document in @\"...\"@
 quotes p       = char '\'' <> p <> char '\''
 doubleQuotes p = char '"' <> p <> char '"'
 parens p       = char '(' <> p <> char ')'
@@ -446,27 +236,27 @@ 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 :: Bool -> Doc -> Doc
 maybeParens False = id
 maybeParens True = parens
 
 -- | Apply 'brackets' to 'Doc' if boolean is true.
-maybeBrackets :: Bool -> Doc a -> Doc a
+maybeBrackets :: Bool -> Doc -> Doc
 maybeBrackets False = id
 maybeBrackets True = brackets
 
 -- | Apply 'braces' to 'Doc' if boolean is true.
-maybeBraces :: Bool -> Doc a -> Doc a
+maybeBraces :: Bool -> Doc -> Doc
 maybeBraces False = id
 maybeBraces True = braces
 
 -- | Apply 'quotes' to 'Doc' if boolean is true.
-maybeQuotes :: Bool -> Doc a -> Doc a
+maybeQuotes :: Bool -> Doc -> Doc
 maybeQuotes False = id
 maybeQuotes True = quotes
 
 -- | Apply 'doubleQuotes' to 'Doc' if boolean is true.
-maybeDoubleQuotes :: Bool -> Doc a -> Doc a
+maybeDoubleQuotes :: Bool -> Doc -> Doc
 maybeDoubleQuotes False = id
 maybeDoubleQuotes True = doubleQuotes
 
@@ -474,22 +264,24 @@ 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
+reduceDoc :: Doc -> RDoc
+reduceDoc (Doc d) = Doc (Ann.reduceDoc d)
+{-# INLINE reduceDoc #-}
 
 -- | List version of '<>'.
-hcat :: [Doc a] -> Doc a
-hcat = snd . reduceHoriz . foldr (\p q -> Beside p False q) empty
+hcat :: [Doc] -> Doc
+hcat = liftList Ann.hcat
+{-# INLINE hcat #-}
 
 -- | List version of '<+>'.
-hsep :: [Doc a] -> Doc a
-hsep = snd . reduceHoriz . foldr (\p q -> Beside p True q)  empty
+hsep :: [Doc] -> Doc
+hsep = liftList Ann.hsep
+{-# INLINE hsep #-}
 
 -- | List version of '$$'.
-vcat :: [Doc a] -> Doc a
-vcat = snd . reduceVert . foldr (\p q -> Above p False q) empty
+vcat :: [Doc] -> Doc
+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:
@@ -508,74 +300,19 @@ vcat = snd . reduceVert . foldr (\p q -> Above p False q) 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)
+nest :: Int -> Doc -> Doc
+nest k (Doc p) = Doc (Ann.nest k p)
+{-# INLINE nest #-}
 
 -- | @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]
+hang :: Doc -> Int -> Doc -> Doc
+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 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
+punctuate :: Doc -> [Doc] -> [Doc]
+punctuate (Doc p) ds = [ Doc d | d <- Ann.punctuate p [ d | Doc d <- ds ] ]
+{-# INLINE punctuate #-}
 
 
 -- ---------------------------------------------------------------------------
@@ -600,57 +337,15 @@ union_ = Union
 --
 -- * @(x '$$' y) '<>' z = x '$$' (y '<>' z)@, if @y@ non-empty.
 --
-($$) :: Doc a -> Doc a -> Doc a
-p $$  q = above_ p False q
+($$) :: Doc -> Doc -> Doc
+($$) = liftBinary (Ann.$$)
+{-# INLINE ($$) #-}
 
 -- | 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)
+($+$) :: Doc -> Doc -> Doc
+($+$) = liftBinary (Ann.$+$)
+{-# INLINE ($+$) #-}
 
 
 -- ---------------------------------------------------------------------------
@@ -662,43 +357,15 @@ nilAboveNest g k q           | not g && k > 0      -- No newline if no overlap
 
 -- | Beside.
 -- '<>' is associative, with identity 'empty'.
-(<>) :: Doc a -> Doc a -> Doc a
-p <>  q = beside_ p False q
+(<>) :: Doc -> Doc -> Doc
+(<>) = liftBinary (Ann.<>)
+{-# INLINE (<>) #-}
 
 -- | 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
+(<+>) :: Doc -> Doc -> Doc
+(<+>) = liftBinary (Ann.<+>)
+{-# INLINE (<+>) #-}
 
 
 -- ---------------------------------------------------------------------------
@@ -709,230 +376,53 @@ nilBeside g p | g         = textBeside_ spaceText p
 --                          vcat ps
 
 -- | Either 'hsep' or 'vcat'.
-sep  :: [Doc a] -> Doc a
-sep = sepX True   -- Separate with spaces
+sep  :: [Doc] -> Doc
+sep  = liftList Ann.sep
+{-# INLINE sep #-}
 
 -- | 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
+cat :: [Doc] -> Doc
+cat = liftList Ann.cat
+{-# INLINE cat #-}
 
 
 -- ---------------------------------------------------------------------------
 -- @fill@
 
 -- | \"Paragraph fill\" version of 'cat'.
-fcat :: [Doc a] -> Doc a
-fcat = fill False
+fcat :: [Doc] -> Doc
+fcat = liftList Ann.fcat
+{-# INLINE fcat #-}
 
 -- | \"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
+fsep :: [Doc] -> Doc
+fsep = liftList Ann.fsep
+{-# INLINE fsep #-}
 
 
 -- ---------------------------------------------------------------------------
 -- 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"
+first :: Doc -> Doc -> Doc
+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 :: 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 :: Style -> Doc -> String
 renderStyle s = fullRender (mode s) (lineLength s) (ribbonsPerLine s)
                 txtPrinter ""
+{-# INLINE renderStyle #-}
 
 -- | Default TextDetails printer
 txtPrinter :: TextDetails -> String -> String
@@ -946,153 +436,9 @@ fullRender :: Mode                     -- ^ Rendering mode
            -> Float                    -- ^ Ribbons per line
            -> (TextDetails -> a -> a)  -- ^ What to do with text
            -> a                        -- ^ What to do at the end
-           -> Doc b                    -- ^ The document
+           -> Doc                      -- ^ The document
            -> a                        -- ^ Result
-fullRender m l r txt = fullRenderAnn m l r annTxt
-  where
-  annTxt (NoAnnot s _) = txt s
-  annTxt _             = id
+fullRender m lineLen ribbons txt rest (Doc doc)
+  = Ann.fullRender m lineLen ribbons txt rest doc
+{-# INLINE fullRender #-}
 
-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 -> a -> 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 end start a = 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 a) s =
-    case sStack s of
-      sp : rest -> s { sSpans = sp (sOffset s) a : sSpans s, sStack = rest }
-      _         -> error "renderSpans: stack underflow"
-
-  spanPrinter AnnotEnd s =
-    s { sStack = mkSpan (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 }
index 0c9693f..298f447 100644 (file)
@@ -45,13 +45,13 @@ prettyNormal = PrettyLevel 0
 -- the 'Show' class. Minimal complete definition is either 'pPrintPrec' or
 -- 'pPrint'.
 class Pretty a where
-  pPrintPrec :: PrettyLevel -> Rational -> a -> Doc ann
+  pPrintPrec :: PrettyLevel -> Rational -> a -> Doc
   pPrintPrec _ _ = pPrint
 
-  pPrint :: a -> Doc ann
+  pPrint :: a -> Doc
   pPrint = pPrintPrec prettyNormal 0
 
-  pPrintList :: PrettyLevel -> [a] -> Doc ann
+  pPrintList :: PrettyLevel -> [a] -> Doc
   pPrintList l = brackets . fsep . punctuate comma . map (pPrintPrec l 0)
 
 #if __GLASGOW_HASKELL__ >= 708
@@ -62,7 +62,7 @@ class Pretty a where
 prettyShow :: (Pretty a) => a -> String
 prettyShow = render . pPrint
 
-pPrint0 :: (Pretty a) => PrettyLevel -> a -> Doc ann
+pPrint0 :: (Pretty a) => PrettyLevel -> a -> Doc
 pPrint0 l = pPrintPrec l 0
 
 appPrec :: Rational
@@ -70,7 +70,7 @@ appPrec = 10
 
 -- | Parenthesize an value if the boolean is true.
 {-# DEPRECATED prettyParen "Please use 'maybeParens' instead" #-}
-prettyParen :: Bool -> Doc ann -> Doc ann
+prettyParen :: Bool -> Doc -> Doc
 prettyParen = maybeParens
 
 -- Various Pretty instances