{-# OPTIONS_GHC -fno-warn-orphans #-}
-- |
-- Copyright : (c) 2011 Simon Meier
-- License : GPL v3 (see LICENSE)
--
-- Maintainer : Simon Meier <iridcode@gmail.com>
--
-- 'Document' class allowing to have different interpretations of the
-- HughesPJ pretty-printing combinators.
module Text.PrettyPrint.Class (
P.Doc
, Document(..)
, P.isEmpty
, P.render
, P.renderStyle
, defaultStyle
, P.Style(..)
, P.Mode(..)
, ($--$)
, emptyDoc
, (<>)
, semi
, colon
, comma
, space
, equals
, lparen
, rparen
, lbrack
, rbrack
, lbrace
, rbrace
, int
, integer
, float
, double
, rational
, quotes
, doubleQuotes
, parens
, brackets
, braces
, hang
, punctuate
-- * Additional combinators
, nestBetween
, nestShort
, nestShort'
, nestShortNonEmpty
, nestShortNonEmpty'
, fixedWidthText
, symbol
, numbered
, numbered'
) where
import Control.DeepSeq (NFData(..))
import Data.List (intersperse)
import Extension.Data.Monoid (Monoid(..), (<>))
import Extension.Prelude (flushRight)
import qualified Text.PrettyPrint.HughesPJ as P
infixr 6 <->
infixl 5 $$, $-$, $--$
-- emptyDoc = P.empty
-- (<>) = (P.<>)
class (Monoid d, NFData d) => Document d where
char :: Char -> d
text :: String -> d
zeroWidthText :: String -> d
(<->) :: d -> d -> d
hcat :: [d] -> d
hsep :: [d] -> d
($$) :: d -> d -> d
($-$) :: d -> d -> d
vcat :: [d] -> d
sep :: [d] -> d
cat :: [d] -> d
fsep :: [d] -> d
fcat :: [d] -> d
nest :: Int -> d -> d
caseEmptyDoc :: d -> d -> d -> d
-- | The default 'P.Style'.
defaultStyle :: P.Style
defaultStyle = P.style
-- | The empty document.
emptyDoc :: Document d => d
emptyDoc = mempty
-- | Vertical concatentation of two documents with an empty line in between.
($--$) :: Document d => d -> d -> d
d1 $--$ d2 =
caseEmptyDoc d2 (caseEmptyDoc d1 (d1 $-$ text "" $-$ d2) d2) d1
semi, colon, comma, space, equals,
lparen, rparen, lbrack, rbrack, lbrace, rbrace :: Document d => d
semi = char ';'
colon = char ':'
comma = char ','
space = char ' '
equals = char '='
lparen = char '('
rparen = char ')'
lbrack = char '['
rbrack = char ']'
lbrace = char '{'
rbrace = char '}'
int :: Document d => Int -> d
int n = text (show n)
integer :: Document d => Integer -> d
integer n = text (show n)
float :: Document d => Float -> d
float n = text (show n)
double :: Document d => Double -> d
double n = text (show n)
rational :: Document d => Rational -> d
rational n = text (show n)
quotes, doubleQuotes, parens, brackets, braces :: Document d => d -> d
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 '}'
hang :: Document d => d -> Int -> d -> d
hang d1 n d2 = sep [d1, nest n d2]
punctuate :: Document d => d -> [d] -> [d]
punctuate _ [] = []
punctuate p (d:ds) = go d ds
where
go d' [] = [d']
go d' (e:es) = (d' <> p) : go e es
------------------------------------------------------------------------------
-- The 'Document' instance for 'Text.PrettyPrint.Doc'
------------------------------------------------------------------------------
instance NFData P.Doc where
rnf = rnf . P.render
instance Document P.Doc where
char = P.char
text = P.text
zeroWidthText = P.zeroWidthText
(<->) = (P.<+>)
hcat = P.hcat
hsep = P.hsep
($$) = (P.$$)
($-$) = (P.$+$)
vcat = P.vcat
sep = P.sep
cat = P.cat
fsep = P.fsep
fcat = P.fcat
nest = P.nest
caseEmptyDoc yes no d = if P.isEmpty d then yes else no
------------------------------------------------------------------------------
-- Additional combinators
------------------------------------------------------------------------------
-- | Nest a document surrounded by a leading and a finishing document breaking
-- lead, body, and finish onto separate lines, if they don't fit on a single
-- line.
nestBetween :: Document d =>
Int -- ^ Indent of body
-> d -- ^ Leading document
-> d -- ^ Finishing document
-> d -- ^ Body document
-> d
nestBetween n l r x = sep [l, nest n x, r]
-- | Nest a document surrounded by a leading and a finishing document with an
-- non-compulsory break between lead and body.
nestShort :: Document d =>
Int -- ^ Indent of body
-> d -- ^ Leading document
-> d -- ^ Finishing document
-> d -- ^ Body document
-> d
nestShort n lead finish body = sep [lead $$ nest n body, finish]
-- | Nest document between two strings and indent body by @length lead + 1@.
nestShort' :: Document d => String -> String -> d -> d
nestShort' lead finish =
nestShort (length lead + 1) (text lead) (text finish)
-- | Like 'nestShort' but doesn't print the lead and finish, if the document is
-- empty.
nestShortNonEmpty :: Document d => Int -> d -> d -> d -> d
nestShortNonEmpty n lead finish body =
caseEmptyDoc emptyDoc (nestShort n lead finish body) body
-- | Like 'nestShort'' but doesn't print the lead and finish, if the document is
-- empty.
nestShortNonEmpty' :: Document d => String -> String -> d -> d
nestShortNonEmpty' lead finish =
nestShortNonEmpty (length lead + 1) (text lead) (text finish)
-- | Output text with a fixed width: if it is smaller then nothing happens,
-- otherwise care is taken to make the text appear having the given width.
fixedWidthText :: Document d => Int -> String -> d
fixedWidthText n cs
| length cs <= n = text cs
| otherwise = text as <> zeroWidthText bs
where
(as,bs) = splitAt n cs
-- | Print string as symbol having width 1.
symbol :: Document d => String -> d
symbol = fixedWidthText 1
-- | Number a list of documents that are vertically separated by the given
-- separator.
numbered :: Document d => d -> [d] -> d
numbered _ [] = emptyDoc
numbered vsep ds =
foldr1 ($-$) $ intersperse vsep $ map pp $ zip [(1::Int)..] ds
where
n = length ds
nWidth = length (show n)
pp (i, d) = text (flushRight nWidth (show i)) <> d
-- | Number a list of documents with numbers terminated by "." and vertically
-- separate using an empty line.
numbered' :: Document d => [d] -> d
numbered' = numbered (text "") . map (text ". " <>)