src/Text/PrettyPrint/HughesPJ.hs

    {-# OPTIONS_HADDOCK not-home #-}
    #if __GLASGOW_HASKELL__ >= 701
    {-# LANGUAGE Safe #-}
    {-# LANGUAGE DeriveGeneric #-}
    #endif

    -----------------------------------------------------------------------------
    -- |
    -- Module      :  Text.PrettyPrint.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.HughesPJ (

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

            -- * Constructing documents

            -- ** Converting values into documents
            char, text, ptext, sizedText, zeroWidthText,
            int, integer, float, double, rational,

            -- ** Simple derived documents
            semi, comma, colon, space, equals,
            lparen, rparen, lbrack, rbrack, lbrace, rbrace,

            -- ** Wrapping documents in delimiters
            parens, brackets, braces, quotes, doubleQuotes,
            maybeParens, maybeBrackets, maybeBraces, maybeQuotes, maybeDoubleQuotes,

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

            -- * Predicates on documents
            isEmpty,

            -- * Utility functions for documents
            first, reduceDoc,

            -- * Rendering documents

            -- ** Default rendering
            render,

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

            -- ** General rendering
            fullRender

        ) 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__ >= 800
    import qualified Data.Semigroup as Semi ( Semigroup((<>)) )
    #elif __GLASGOW_HASKELL__ < 709
    import Data.Monoid     ( Monoid(mempty, mappend)  )
    #endif
    import Data.String     ( IsString(fromString) )

    import GHC.Generics

    -- ---------------------------------------------------------------------------
    -- 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.
    newtype Doc = Doc (Ann.Doc ())
    #if __GLASGOW_HASKELL__ >= 701
                        deriving (Generic)
    #endif

    liftList :: ([Ann.Doc ()] -> Ann.Doc ()) -> ([Doc] -> Doc)
    liftList f ds = Doc (f [ d | Doc d <- ds ])
    {-# INLINE liftList #-}

    liftBinary :: (Ann.Doc () -> Ann.Doc () -> Ann.Doc ())
               -> (    Doc    ->     Doc    ->     Doc   )
    liftBinary f (Doc a) (Doc b) = Doc (f a b)
    {-# INLINE liftBinary #-}

    -- | RDoc is a "reduced GDoc", guaranteed not to have a top-level Above or
    -- Beside.
    type RDoc = Doc

    -- Combining @Doc@ values
    #if __GLASGOW_HASKELL__ >= 800
    instance Semi.Semigroup Doc where
        (<>) = (Text.PrettyPrint.HughesPJ.<>)

    instance Monoid Doc where
        mempty  = empty
        mappend = (Semi.<>)
    #else
    instance Monoid Doc where
        mempty  = empty
        mappend = (<>)
    #endif

    instance IsString Doc where
        fromString = text

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

    instance Eq Doc where
      (==) = (==) `on` render

    instance NFData Doc where
      rnf (Doc a) = rnf a

    -- ---------------------------------------------------------------------------
    -- Values and Predicates on GDocs and TextDetails

    -- | A document of height and width 1, containing a literal character.
    char :: Char -> Doc
    char c = Doc (Ann.char c)
    {-# INLINE char #-}

    -- | 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 = Doc (Ann.text s)
    {-# INLINE text #-}

    -- | Same as @text@. Used to be used for Bytestrings.
    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
    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
    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 = Doc Ann.empty

    -- | Returns 'True' if the document is empty
    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 ':'
    space  = char ' '
    equals = char '='
    lparen = char '('
    rparen = char ')'
    lbrack = char '['
    rbrack = char ']'
    lbrace = char '{'
    rbrace = char '}'

    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 @\'...\'@
    doubleQuotes :: Doc -> Doc -- ^ 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 -> Doc
    maybeParens False = id
    maybeParens True = parens

    -- | Apply 'brackets' to 'Doc' if boolean is true.
    maybeBrackets :: Bool -> Doc -> Doc
    maybeBrackets False = id
    maybeBrackets True = brackets

    -- | Apply 'braces' to 'Doc' if boolean is true.
    maybeBraces :: Bool -> Doc -> Doc
    maybeBraces False = id
    maybeBraces True = braces

    -- | Apply 'quotes' to 'Doc' if boolean is true.
    maybeQuotes :: Bool -> Doc -> Doc
    maybeQuotes False = id
    maybeQuotes True = quotes

    -- | Apply 'doubleQuotes' to 'Doc' if boolean is true.
    maybeDoubleQuotes :: Bool -> Doc -> Doc
    maybeDoubleQuotes False = id
    maybeDoubleQuotes True = doubleQuotes

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

    -- | Perform some simplification of a built up @GDoc@.
    reduceDoc :: Doc -> RDoc
    reduceDoc (Doc d) = Doc (Ann.reduceDoc d)
    {-# INLINE reduceDoc #-}

    -- | List version of '<>'.
    hcat :: [Doc] -> Doc
    hcat = liftList Ann.hcat
    {-# INLINE hcat #-}

    -- | List version of '<+>'.
    hsep :: [Doc] -> Doc
    hsep = liftList Ann.hsep
    {-# INLINE hsep #-}

    -- | List version of '$$'.
    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:
    --
    -- * @'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 (Doc p) = Doc (Ann.nest k p)
    {-# INLINE nest #-}

    -- | @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 -> [Doc] -> [Doc]
    punctuate (Doc p) ds = [ Doc d | d <- Ann.punctuate p [ d | Doc d <- ds ] ]
    {-# INLINE punctuate #-}

    -- ---------------------------------------------------------------------------
    -- 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
    ($$) = liftBinary (Ann.$$)
    {-# INLINE ($$) #-}

    -- | Above, with no overlapping.
    -- '$+$' is associative, with identity 'empty'.
    ($+$) :: Doc -> Doc -> Doc
    ($+$) = liftBinary (Ann.$+$)
    {-# INLINE ($+$) #-}

    -- ---------------------------------------------------------------------------
    -- 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
    (<>) = liftBinary (Ann.<>)
    {-# INLINE (<>) #-}

    -- | Beside, separated by space, unless one of the arguments is 'empty'.
    -- '<+>' is associative, with identity 'empty'.
    (<+>) :: Doc -> Doc -> Doc
    (<+>) = liftBinary (Ann.<+>)
    {-# INLINE (<+>) #-}

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

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

    -- | Either 'hsep' or 'vcat'.
    sep  :: [Doc] -> Doc
    sep  = liftList Ann.sep
    {-# INLINE sep #-}

    -- | Either 'hcat' or 'vcat'.
    cat :: [Doc] -> Doc
    cat = liftList Ann.cat
    {-# INLINE cat #-}

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

    -- | \"Paragraph fill\" version of 'cat'.
    fcat :: [Doc] -> Doc
    fcat = liftList Ann.fcat
    {-# INLINE fcat #-}

    -- | \"Paragraph fill\" version of 'sep'.
    fsep :: [Doc] -> Doc
    fsep = liftList Ann.fsep
    {-# INLINE fsep #-}

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

    -- | @first@ returns its first argument if it is non-empty, otherwise its second.
    first :: Doc -> Doc -> Doc
    first  = liftBinary Ann.first
    {-# INLINE first #-}

    -- ---------------------------------------------------------------------------
    -- Rendering

    -- | Render the @Doc@ to a String using the default @Style@ (see 'style').
    render :: Doc -> String
    render = fullRender (mode style) (lineLength style) (ribbonsPerLine style)
                        txtPrinter ""
    {-# INLINE render #-}

    -- | Render the @Doc@ to a String using the given @Style@.
    renderStyle :: Style -> Doc -> String
    renderStyle s = fullRender (mode s) (lineLength s) (ribbonsPerLine s)
                    txtPrinter ""
    {-# INLINE renderStyle #-}

    -- | Default TextDetails printer.
    txtPrinter :: TextDetails -> String -> String
    txtPrinter (Chr c)   s  = c:s
    txtPrinter (Str s1)  s2 = s1 ++ s2
    txtPrinter (PStr s1) s2 = s1 ++ s2

    -- | The general rendering interface. Please refer to the @Style@ and @Mode@
    -- types for a description of rendering mode, line length and ribbons.
    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 m lineLen ribbons txt rest (Doc doc)
      = Ann.fullRender m lineLen ribbons txt rest doc
    {-# INLINE fullRender #-}