{-# 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__ >= 803
import Prelude         hiding ( (<>) )
#endif
#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 (forall x. Rep Doc x -> Doc
forall x. Doc -> Rep Doc x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Doc x -> Doc
$cfrom :: forall x. Doc -> Rep Doc x
Generic)
#endif

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

liftBinary :: (Ann.Doc () -> Ann.Doc () -> Ann.Doc ())
           -> (    Doc    ->     Doc    ->     Doc   )
liftBinary :: (Doc () -> Doc () -> Doc ()) -> Doc -> Doc -> Doc
liftBinary Doc () -> Doc () -> Doc ()
f (Doc Doc ()
a) (Doc Doc ()
b) = Doc () -> Doc
Doc (Doc () -> Doc () -> Doc ()
f Doc ()
a Doc ()
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
    <> :: Doc -> Doc -> Doc
(<>) = Doc -> Doc -> Doc
(Text.PrettyPrint.HughesPJ.<>)

instance Monoid Doc where
    mempty :: Doc
mempty  = Doc
empty
    mappend :: Doc -> Doc -> Doc
mappend = forall a. Semigroup a => a -> a -> a
(Semi.<>)
#else
instance Monoid Doc where
    mempty  = empty
    mappend = (<>)
#endif

instance IsString Doc where
    fromString :: String -> Doc
fromString = String -> Doc
text

instance Show Doc where
  showsPrec :: Int -> Doc -> ShowS
showsPrec Int
_ Doc
doc String
cont = forall a.
Mode -> Int -> Float -> (TextDetails -> a -> a) -> a -> Doc -> a
fullRender (Style -> Mode
mode Style
style) (Style -> Int
lineLength Style
style)
                                    (Style -> Float
ribbonsPerLine Style
style)
                                    TextDetails -> ShowS
txtPrinter String
cont Doc
doc

instance Eq Doc where
  == :: Doc -> Doc -> Bool
(==) = forall a. Eq a => a -> a -> Bool
(==) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Doc -> String
render

instance NFData Doc where
  rnf :: Doc -> ()
rnf (Doc Doc ()
a) = forall a. NFData a => a -> ()
rnf Doc ()
a

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

-- | A document of height and width 1, containing a literal character.
char :: Char -> Doc
char :: Char -> Doc
char Char
c = Doc () -> Doc
Doc (forall a. Char -> Doc a
Ann.char 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 :: String -> Doc
text String
s = Doc () -> Doc
Doc (forall a. String -> Doc a
Ann.text String
s)
{-# INLINE text #-}

-- | Same as @text@. Used to be used for Bytestrings.
ptext :: String -> Doc
ptext :: String -> Doc
ptext String
s = Doc () -> Doc
Doc (forall a. String -> Doc a
Ann.ptext String
s)
{-# INLINE ptext #-}

-- | Some text with any width. (@text s = sizedText (length s) s@)
sizedText :: Int -> String -> Doc
sizedText :: Int -> String -> Doc
sizedText Int
l String
s = Doc () -> Doc
Doc (forall a. Int -> String -> Doc a
Ann.sizedText Int
l String
s)

-- | Some text, but without any width. Use for non-printing text
-- such as a HTML or Latex tags
zeroWidthText :: String -> Doc
zeroWidthText :: String -> Doc
zeroWidthText = Int -> String -> Doc
sizedText Int
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
empty = Doc () -> Doc
Doc forall a. Doc a
Ann.empty

-- | Returns 'True' if the document is empty
isEmpty :: Doc -> Bool
isEmpty :: Doc -> Bool
isEmpty (Doc Doc ()
d) = forall a. Doc a -> Bool
Ann.isEmpty Doc ()
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 :: Doc
semi   = Char -> Doc
char Char
';'
comma :: Doc
comma  = Char -> Doc
char Char
','
colon :: Doc
colon  = Char -> Doc
char Char
':'
space :: Doc
space  = Char -> Doc
char Char
' '
equals :: Doc
equals = Char -> Doc
char Char
'='
lparen :: Doc
lparen = Char -> Doc
char Char
'('
rparen :: Doc
rparen = Char -> Doc
char Char
')'
lbrack :: Doc
lbrack = Char -> Doc
char Char
'['
rbrack :: Doc
rbrack = Char -> Doc
char Char
']'
lbrace :: Doc
lbrace = Char -> Doc
char Char
'{'
rbrace :: Doc
rbrace = Char -> Doc
char 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 :: Int -> Doc
int      Int
n = String -> Doc
text (forall a. Show a => a -> String
show Int
n)
integer :: Integer -> Doc
integer  Integer
n = String -> Doc
text (forall a. Show a => a -> String
show Integer
n)
float :: Float -> Doc
float    Float
n = String -> Doc
text (forall a. Show a => a -> String
show Float
n)
double :: Double -> Doc
double   Double
n = String -> Doc
text (forall a. Show a => a -> String
show Double
n)
rational :: Rational -> Doc
rational Rational
n = String -> Doc
text (forall a. Show a => a -> String
show Rational
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 :: Doc -> Doc
quotes Doc
p       = Char -> Doc
char Char
'\'' Doc -> Doc -> Doc
<> Doc
p Doc -> Doc -> Doc
<> Char -> Doc
char Char
'\''
doubleQuotes :: Doc -> Doc
doubleQuotes Doc
p = Char -> Doc
char Char
'"' Doc -> Doc -> Doc
<> Doc
p Doc -> Doc -> Doc
<> Char -> Doc
char Char
'"'
parens :: Doc -> Doc
parens Doc
p       = Char -> Doc
char Char
'(' Doc -> Doc -> Doc
<> Doc
p Doc -> Doc -> Doc
<> Char -> Doc
char Char
')'
brackets :: Doc -> Doc
brackets Doc
p     = Char -> Doc
char Char
'[' Doc -> Doc -> Doc
<> Doc
p Doc -> Doc -> Doc
<> Char -> Doc
char Char
']'
braces :: Doc -> Doc
braces Doc
p       = Char -> Doc
char Char
'{' Doc -> Doc -> Doc
<> Doc
p Doc -> Doc -> Doc
<> Char -> Doc
char Char
'}'

-- | Apply 'parens' to 'Doc' if boolean is true.
maybeParens :: Bool -> Doc -> Doc
maybeParens :: Bool -> Doc -> Doc
maybeParens Bool
False = forall a. a -> a
id
maybeParens Bool
True = Doc -> Doc
parens

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

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

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

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

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

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

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

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

-- | List version of '$$'.
vcat :: [Doc] -> Doc
vcat :: [Doc] -> Doc
vcat = ([Doc ()] -> Doc ()) -> [Doc] -> Doc
liftList forall a. [Doc a] -> Doc a
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 x '<>' 'nest' k y@
--
-- * @'nest' k (x '$$' y) = 'nest' k x '$$' 'nest' k y@
--
-- * @'nest' k 'empty' = 'empty'@
--
-- * @x '<>' 'nest' k y = x '<>' y@, if @x@ non-empty
--
-- The side condition on the last law is needed because
-- 'empty' is a left identity for '<>'.
nest :: Int -> Doc -> Doc
nest :: Int -> Doc -> Doc
nest Int
k (Doc Doc ()
p) = Doc () -> Doc
Doc (forall a. Int -> Doc a -> Doc a
Ann.nest Int
k Doc ()
p)
{-# INLINE nest #-}

-- | @hang d1 n d2 = sep [d1, nest n d2]@
hang :: Doc -> Int -> Doc -> Doc
hang :: Doc -> Int -> Doc -> Doc
hang (Doc Doc ()
d1) Int
n (Doc Doc ()
d2) = Doc () -> Doc
Doc (forall a. Doc a -> Int -> Doc a -> Doc a
Ann.hang Doc ()
d1 Int
n Doc ()
d2)
{-# INLINE hang #-}

-- | @punctuate p [d1, ... dn] = [d1 \<> p, d2 \<> p, ... dn-1 \<> p, dn]@
punctuate :: Doc -> [Doc] -> [Doc]
punctuate :: Doc -> [Doc] -> [Doc]
punctuate (Doc Doc ()
p) [Doc]
ds = [ Doc () -> Doc
Doc Doc ()
d | Doc ()
d <- forall a. Doc a -> [Doc a] -> [Doc a]
Ann.punctuate Doc ()
p [ Doc ()
d | Doc Doc ()
d <- [Doc]
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
$$ :: Doc -> Doc -> Doc
($$) = (Doc () -> Doc () -> Doc ()) -> Doc -> Doc -> Doc
liftBinary forall a. Doc a -> Doc a -> Doc a
(Ann.$$)
{-# INLINE ($$) #-}

-- | Above, with no overlapping.
-- '$+$' is associative, with identity 'empty'.
($+$) :: Doc -> Doc -> Doc
$+$ :: Doc -> Doc -> Doc
($+$) = (Doc () -> Doc () -> Doc ()) -> Doc -> Doc -> Doc
liftBinary forall a. Doc a -> Doc a -> Doc a
(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
<> :: Doc -> Doc -> Doc
(<>) = (Doc () -> Doc () -> Doc ()) -> Doc -> Doc -> Doc
liftBinary forall a. Doc a -> Doc a -> Doc a
(Ann.<>)
{-# INLINE (<>) #-}

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


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

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

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

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


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

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

-- | \"Paragraph fill\" version of 'sep'.
fsep :: [Doc] -> Doc
fsep :: [Doc] -> Doc
fsep = ([Doc ()] -> Doc ()) -> [Doc] -> Doc
liftList forall a. [Doc a] -> Doc a
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 :: Doc -> Doc -> Doc
first  = (Doc () -> Doc () -> Doc ()) -> Doc -> Doc -> Doc
liftBinary forall a. Doc a -> Doc a -> Doc a
Ann.first
{-# INLINE first #-}


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

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

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

-- | Default TextDetails printer.
txtPrinter :: TextDetails -> String -> String
txtPrinter :: TextDetails -> ShowS
txtPrinter (Chr Char
c)   String
s  = Char
cforall a. a -> [a] -> [a]
:String
s
txtPrinter (Str String
s1)  String
s2 = String
s1 forall a. [a] -> [a] -> [a]
++ String
s2
txtPrinter (PStr String
s1) String
s2 = String
s1 forall a. [a] -> [a] -> [a]
++ String
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 :: forall a.
Mode -> Int -> Float -> (TextDetails -> a -> a) -> a -> Doc -> a
fullRender Mode
m Int
lineLen Float
ribbons TextDetails -> a -> a
txt a
rest (Doc Doc ()
doc)
  = forall a b.
Mode -> Int -> Float -> (TextDetails -> a -> a) -> a -> Doc b -> a
Ann.fullRender Mode
m Int
lineLen Float
ribbons TextDetails -> a -> a
txt a
rest Doc ()
doc
{-# INLINE fullRender #-}