utils/Pretty.hs

    {-# LANGUAGE BangPatterns #-}
    {-# LANGUAGE MagicHash #-}

    -----------------------------------------------------------------------------
    -- |
    -- Module      :  Pretty
    -- Copyright   :  (c) The University of Glasgow 2001
    -- License     :  BSD-style (see the file LICENSE)
    --
    -- Maintainer  :  David Terei <code@davidterei.com>
    -- Stability   :  stable
    -- Portability :  portable
    --
    -- John Hughes's and Simon Peyton Jones's Pretty Printer Combinators
    --
    -- Based on /The Design of a Pretty-printing Library/
    -- in Advanced Functional Programming,
    -- Johan Jeuring and Erik Meijer (eds), LNCS 925
    -- <http://www.cs.chalmers.se/~rjmh/Papers/pretty.ps>
    --
    -----------------------------------------------------------------------------

    {-
    Note [Differences between libraries/pretty and compiler/utils/Pretty.hs]

    For historical reasons, there are two different copies of `Pretty` in the GHC
    source tree:
     * `libraries/pretty` is a submodule containing
       https://github.com/haskell/pretty. This is the `pretty` library as released
       on hackage. It is used by several other libraries in the GHC source tree
       (e.g. template-haskell and Cabal).
     * `compiler/utils/Pretty.hs` (this module). It is used by GHC only.

    There is an ongoing effort in https://github.com/haskell/pretty/issues/1 and
    https://ghc.haskell.org/trac/ghc/ticket/10735 to try to get rid of GHC's copy
    of Pretty.

    Currently, GHC's copy of Pretty resembles pretty-1.1.2.0, with the following
    major differences:
     * GHC's copy uses `Faststring` for performance reasons.
     * GHC's copy has received a backported bugfix for #12227, which was
       released as pretty-1.1.3.4 ("Remove harmful $! forcing in beside",
       https://github.com/haskell/pretty/pull/35).

    Other differences are minor. Both copies define some extra functions and
    instances not defined in the other copy. To see all differences, do this in a
    ghc git tree:

        $ cd libraries/pretty
        $ git checkout v1.1.2.0
        $ cd -
        $ vimdiff compiler/utils/Pretty.hs \
                  libraries/pretty/src/Text/PrettyPrint/HughesPJ.hs

    For parity with `pretty-1.1.2.1`, the following two `pretty` commits would
    have to be backported:
      * "Resolve foldr-strictness stack overflow bug"
        (307b8173f41cd776eae8f547267df6d72bff2d68)
      * "Special-case reduce for horiz/vert"
        (c57c7a9dfc49617ba8d6e4fcdb019a3f29f1044c)
    This has not been done sofar, because these commits seem to cause more
    allocation in the compiler (see thomie's comments in
    https://github.com/haskell/pretty/pull/9).
    -}

    module Pretty (

            -- * The document type
            Doc, TextDetails(..),

            -- * Constructing documents

            -- ** Converting values into documents
            char, text, ftext, ptext, ztext, 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, quote, doubleQuotes,
            maybeParens,

            -- ** Combining documents
            empty,
            (<>), (<+>), hcat, hsep,
            ($$), ($+$), vcat,
            sep, cat,
            fsep, fcat,
            nest,
            hang, hangNotEmpty, punctuate,

            -- * Predicates on documents
            isEmpty,

            -- * Rendering documents

            -- ** Rendering with a particular style
            Style(..),
            style,
            renderStyle,
            Mode(..),

            -- ** General rendering
            fullRender,

            -- ** GHC-specific rendering
            printDoc, printDoc_,
            bufLeftRender -- performance hack

      ) where

    import BufWrite
    import FastString
    import Panic
    import System.IO
    import Prelude hiding (error)

    --for a RULES
    import GHC.Base ( unpackCString# )
    import GHC.Ptr  ( Ptr(..) )

    -- Don't import Util( assertPanic ) because it makes a loop in the module structure

    -- ---------------------------------------------------------------------------
    -- 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
      = 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

    {-
    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

    -- | 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 FastString                      -- a hashed string
                     | ZStr FastZString                     -- a z-encoded string
                     | LStr {-# UNPACK #-} !LitString {-#UNPACK #-} !Int
                       -- a '\0'-terminated array of bytes

    instance Show Doc where
      showsPrec _ doc cont = fullRender (mode style) (lineLength style)
                                        (ribbonsPerLine style)
                                        txtPrinter cont doc

    -- ---------------------------------------------------------------------------
    -- 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

    -- | 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
    text s = case length s of {sl -> textBeside_ (Str s)  sl Empty}
    {-# NOINLINE [0] text #-}   -- Give the RULE a chance to fire
                                -- It must wait till after phase 1 when
                                -- the unpackCString first is manifested

    -- RULE that turns (text "abc") into (ptext (A# "abc"#)) to avoid the
    -- intermediate packing/unpacking of the string.
    {-# RULES
      "text/str" forall a. text (unpackCString# a) = ptext (Ptr a)
     #-}

    ftext :: FastString -> Doc
    ftext s = case lengthFS s of {sl -> textBeside_ (PStr s) sl Empty}

    ptext :: LitString -> Doc
    ptext s = case lengthLS s of {sl -> textBeside_ (LStr s sl) sl Empty}

    ztext :: FastZString -> Doc
    ztext s = case lengthFZS s of {sl -> textBeside_ (ZStr s) sl Empty}

    -- | Some text with any width. (@text s = sizedText (length s) s@)
    sizedText :: Int -> String -> Doc
    sizedText l s = textBeside_ (Str s) l Empty

    -- | Some text, but without any width. Use for non-printing text
    -- such as a HTML or Latex tags
    zeroWidthText :: String -> 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
    empty = 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.
    spaces :: Int -> String
    spaces !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 ';' 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 ':'
    space  = char ' '
    equals = char '='
    lparen = char '('
    rparen = char ')'
    lbrack = char '['
    rbrack = char ']'
    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)@
    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 -> Doc -- ^ Wrap document in @(...)@
    brackets     :: Doc -> Doc -- ^ Wrap document in @[...]@
    braces       :: Doc -> Doc -- ^ Wrap document in @{...}@
    quotes       :: Doc -> Doc -- ^ Wrap document in @\'...\'@
    quote        :: Doc -> Doc
    doubleQuotes :: Doc -> Doc -- ^ Wrap document in @\"...\"@
    quotes p       = char '`' <> p <> char '\''
    quote p        = char '\'' <> p
    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 -> Doc
    maybeParens False = id
    maybeParens True = parens

    -- ---------------------------------------------------------------------------
    -- Structural operations on GDocs

    -- | 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

    -- | List version of '<>'.
    hcat :: [Doc] -> Doc
    hcat = reduceAB . foldr (beside_' False) empty

    -- | List version of '<+>'.
    hsep :: [Doc] -> Doc
    hsep = reduceAB . foldr (beside_' True)  empty

    -- | List version of '$$'.
    vcat :: [Doc] -> Doc
    vcat = reduceAB . foldr (above_' False) 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 -> Doc
    nest k p = mkNest k (reduceDoc p)

    -- | @hang d1 n d2 = sep [d1, nest n d2]@
    hang :: Doc -> Int -> Doc -> Doc
    hang d1 n d2 = sep [d1, nest n d2]

    -- | Apply 'hang' to the arguments if the first 'Doc' is not empty.
    hangNotEmpty :: Doc -> Int -> Doc -> Doc
    hangNotEmpty d1 n d2 = if isEmpty d1
                           then d2
                           else hang d1 n d2

    -- | @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

    beside_' :: Bool -> Doc -> Doc -> Doc
    beside_' _ p Empty = p
    beside_' g p q     = Beside p g q

    above_' :: Bool -> Doc -> Doc -> Doc
    above_' _ p Empty = p
    above_' g p q     = Above p g q

    reduceAB :: Doc -> Doc
    reduceAB (Above  Empty _ q) = q
    reduceAB (Beside Empty _ q) = q
    reduceAB doc                = doc

    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

    -- ---------------------------------------------------------------------------
    -- 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 -> Doc -> Doc
    p $$  q = above_ p False q

    -- | 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)

    -- Specification: 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 (spaces 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 -> Doc -> Doc
    p <>  q = beside_ p False q

    -- | 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

    -- ---------------------------------------------------------------------------
    -- Separate, @sep@

    -- Specification: sep ps  = oneLiner (hsep ps)
    --                         `union`
    --                          vcat ps

    -- | Either 'hsep' or 'vcat'.
    sep  :: [Doc] -> Doc
    sep = sepX True   -- Separate with spaces

    -- | 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

    -- ---------------------------------------------------------------------------
    -- @fill@

    -- | \"Paragraph fill\" version of 'cat'.
    fcat :: [Doc] -> Doc
    fcat = fill False

    -- | \"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

    -- ---------------------------------------------------------------------------
    -- Selecting the best layout

    best :: Int   -- Line length
         -> Int   -- Ribbon length
         -> RDoc
         -> RDoc  -- No unions in here!
    best w0 r = get w0
      where
        get :: Int          -- (Remaining) width of line
            -> Doc -> Doc
        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 :: Int         -- (Remaining) width of line
             -> Int         -- Amount of first line already eaten up
             -> Doc         -- This is an argument to TextBeside => eat Nests
             -> Doc         -- No unions in here!

        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"

    -- ---------------------------------------------------------------------------
    -- 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
              }

    -- | 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

    -- | Render the @Doc@ to a String using the given @Style@.
    renderStyle :: Style -> Doc -> 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 = unpackFS s1 ++ s2
    txtPrinter (ZStr s1) s2 = zString s1 ++ s2
    txtPrinter (LStr s1 _) s2 = unpackLitString 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                      -- ^ 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 indent k (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"

            -- optimise long indentations using LitString chunks of 8 spaces
            indent !n r | n >= 8    = LStr (sLit "        ") 8 `txt`
                                      indent (n - 8) r
                        | otherwise = Str (spaces n) `txt` r
        in
        lay 0 doc
        }}

    printDoc :: Mode -> Int -> Handle -> Doc -> IO ()
    -- printDoc adds a newline to the end
    printDoc mode cols hdl doc = printDoc_ mode cols hdl (doc $$ text "")

    printDoc_ :: Mode -> Int -> Handle -> Doc -> IO ()
    -- printDoc_ does not add a newline at the end, so that
    -- successive calls can output stuff on the same line
    -- Rather like putStr vs putStrLn
    printDoc_ LeftMode _ hdl doc
      = do { printLeftRender hdl doc; hFlush hdl }
    printDoc_ mode pprCols hdl doc
      = do { fullRender mode pprCols 1.5 put done doc ;
             hFlush hdl }
      where
        put (Chr c)  next = hPutChar hdl c >> next
        put (Str s)  next = hPutStr  hdl s >> next
        put (PStr s) next = hPutStr  hdl (unpackFS s) >> next
                            -- NB. not hPutFS, we want this to go through
                            -- the I/O library's encoding layer. (#3398)
        put (ZStr s) next = hPutFZS  hdl s >> next
        put (LStr s l) next = hPutLitString hdl s l >> next

        done = return () -- hPutChar hdl '\n'

      -- some versions of hPutBuf will barf if the length is zero
    hPutLitString :: Handle -> Ptr a -> Int -> IO ()
    hPutLitString handle a l = if l == 0
                                then return ()
                                else hPutBuf handle a l

    -- Printing output in LeftMode is performance critical: it's used when
    -- dumping C and assembly output, so we allow ourselves a few dirty
    -- hacks:
    --
    -- (1) we specialise fullRender for LeftMode with IO output.
    --
    -- (2) we add a layer of buffering on top of Handles.  Handles
    --     don't perform well with lots of hPutChars, which is mostly
    --     what we're doing here, because Handles have to be thread-safe
    --     and async exception-safe.  We only have a single thread and don't
    --     care about exceptions, so we add a layer of fast buffering
    --     over the Handle interface.

    printLeftRender :: Handle -> Doc -> IO ()
    printLeftRender hdl doc = do
      b <- newBufHandle hdl
      bufLeftRender b doc
      bFlush b

    bufLeftRender :: BufHandle -> Doc -> IO ()
    bufLeftRender b doc = layLeft b (reduceDoc doc)

    layLeft :: BufHandle -> Doc -> IO ()
    layLeft b _ | b `seq` False  = undefined -- make it strict in b
    layLeft _ NoDoc              = error "layLeft: NoDoc"
    layLeft b (Union p q)        = layLeft b (first p q)
    layLeft b (Nest _ p)         = layLeft b p
    layLeft b Empty              = bPutChar b '\n'
    layLeft b (NilAbove p)       = bPutChar b '\n' >> layLeft b p
    layLeft b (TextBeside s _ p) = put b s >> layLeft b p
     where
        put b _ | b `seq` False = undefined
        put b (Chr c)    = bPutChar b c
        put b (Str s)    = bPutStr  b s
        put b (PStr s)   = bPutFS   b s
        put b (ZStr s)   = bPutFZS  b s
        put b (LStr s l) = bPutLitString b s l
    layLeft _ _                  = panic "layLeft: Unhandled case"

    -- Define error=panic, for easier comparison with libraries/pretty.
    error :: String -> a
    error = panic