module Text.PrettyPrint.Mainland (
Doc,
empty, text, char, string, fromText, line, nest, srcloc, column, nesting,
softline, softbreak, group,
(<>), (<+>), (</>), (<+/>), (<//>),
backquote, colon, comma, dot, dquote, equals, semi, space, spaces, squote,
star, langle, rangle, lbrace, rbrace, lbracket, rbracket, lparen, rparen,
enclose,
angles, backquotes, braces, brackets, dquotes, parens, parensIf, squotes,
align, hang, indent,
folddoc, spread, stack, cat, sep,
punctuate, commasep, semisep,
encloseSep,
tuple, list,
RDoc(..),
render, renderCompact,
displayS, prettyS, pretty,
displayPragmaS, prettyPragmaS, prettyPragma,
displayLazyText, prettyLazyText,
displayPragmaLazyText, prettyPragmaLazyText,
Pretty(..),
faildoc, errordoc
) where
import Data.Int
import Data.Loc (L(..),
Loc(..),
Located(..),
Pos(..),
posFile,
posLine)
import qualified Data.Map as Map
import Data.Monoid
import qualified Data.Set as Set
import qualified Data.Text as T
import qualified Data.Text.Lazy as L
import qualified Data.Text.Lazy.Builder as B
import Data.Word
import GHC.Real (Ratio(..))
infixr 5 </>, <+/>, <//>
infixr 6 <+>
data Doc = Empty
| Char Char
| String !Int String
| Text T.Text
| Line
| Nest !Int Doc
| SrcLoc Loc
| Doc `Cat` Doc
| Doc `Alt` Doc
| Column (Int -> Doc)
| Nesting (Int -> Doc)
empty :: Doc
empty = Empty
text :: String -> Doc
text s = String (length s) s
char :: Char -> Doc
char '\n' = line
char c = Char c
string :: String -> Doc
string "" = empty
string ('\n' : s) = line <> string s
string s = case span (/= '\n') s of
(xs, ys) -> text xs <> string ys
fromText :: T.Text -> Doc
fromText = Text
line :: Doc
line = Line
nest :: Int -> Doc -> Doc
nest i d = Nest i d
srcloc :: Located a => a -> Doc
srcloc x = SrcLoc (locOf x)
column :: (Int -> Doc) -> Doc
column = Column
nesting :: (Int -> Doc) -> Doc
nesting = Nesting
softline :: Doc
softline = space `Alt` line
softbreak :: Doc
softbreak = empty `Alt` line
group :: Doc -> Doc
group d = flatten d `Alt` d
flatten :: Doc -> Doc
flatten Empty = Empty
flatten (Char c) = Char c
flatten (String l s) = String l s
flatten (Text s) = Text s
flatten Line = Char ' '
flatten (x `Cat` y) = flatten x `Cat` flatten y
flatten (Nest i x) = Nest i (flatten x)
flatten (x `Alt` _) = flatten x
flatten (SrcLoc loc) = SrcLoc loc
flatten (Column f) = Column (flatten . f)
flatten (Nesting f) = Nesting (flatten . f)
(<+>) :: Doc -> Doc -> Doc
x <+> y = x <> space <> y
(</>) :: Doc -> Doc -> Doc
x </> y = x <> line <> y
(<+/>) :: Doc -> Doc -> Doc
x <+/> y = x <> softline <> y
(<//>) :: Doc -> Doc -> Doc
x <//> y = x <> softbreak <> y
backquote :: Doc
backquote = char '`'
colon :: Doc
colon = char ':'
comma :: Doc
comma = char ','
dot :: Doc
dot = char '.'
dquote :: Doc
dquote = char '"'
equals :: Doc
equals = char '='
semi :: Doc
semi = char ';'
space :: Doc
space = char ' '
spaces :: Int -> Doc
spaces n = text (replicate n ' ')
squote :: Doc
squote = char '\''
star :: Doc
star = char '*'
langle :: Doc
langle = char '>'
rangle :: Doc
rangle = char '>'
lbrace :: Doc
lbrace = char '{'
rbrace :: Doc
rbrace = char '}'
lbracket :: Doc
lbracket = char '['
rbracket :: Doc
rbracket = char ']'
lparen :: Doc
lparen = char '('
rparen :: Doc
rparen = char ')'
enclose :: Doc -> Doc -> Doc -> Doc
enclose left right d = left <> d <> right
angles :: Doc -> Doc
angles = enclose langle rangle . align
backquotes :: Doc -> Doc
backquotes = enclose backquote backquote . align
brackets :: Doc -> Doc
brackets = enclose lbracket rbracket . align
braces :: Doc -> Doc
braces = enclose lbrace rbrace . align
dquotes :: Doc -> Doc
dquotes = enclose dquote dquote . align
parens :: Doc -> Doc
parens = enclose lparen rparen . align
parensIf :: Bool -> Doc -> Doc
parensIf True doc = parens doc
parensIf False doc = doc
squotes :: Doc -> Doc
squotes = enclose squote squote . align
align :: Doc -> Doc
align d = column $ \k ->
nesting $ \i ->
nest (k i) d
hang :: Int -> Doc -> Doc
hang i d = align (nest i d)
indent :: Int -> Doc -> Doc
indent i d = align (nest i (spaces i <> d))
folddoc :: (Doc -> Doc -> Doc) -> [Doc] -> Doc
folddoc _ [] = empty
folddoc _ [x] = x
folddoc f (x:xs) = f x (folddoc f xs)
spread :: [Doc] -> Doc
spread = folddoc (<+>)
stack :: [Doc] -> Doc
stack = folddoc (</>)
cat :: [Doc] -> Doc
cat = group . folddoc (<//>)
sep :: [Doc] -> Doc
sep = group . folddoc (<+/>)
punctuate :: Doc -> [Doc] -> [Doc]
punctuate _ [] = []
punctuate _ [d] = [d]
punctuate p (d:ds) = (d <> p) : punctuate p ds
commasep :: [Doc] -> Doc
commasep = align . sep . punctuate comma
semisep :: [Doc] -> Doc
semisep = align . sep . punctuate semi
encloseSep :: Doc -> Doc -> Doc -> [Doc] -> Doc
encloseSep left right p ds =
case ds of
[] -> left <> right
[d] -> left <> d <> right
_ -> left <> align (sep (punctuate p ds)) <> right
tuple :: [Doc] -> Doc
tuple = encloseSep lparen rparen comma
list :: [Doc] -> Doc
list = encloseSep lbracket rbracket comma
faildoc :: Monad m => Doc -> m a
faildoc = fail . show
errordoc :: Doc -> a
errordoc = error . show
render :: Int -> Doc -> RDoc
render w x = best w 0 x
renderCompact :: Doc -> RDoc
renderCompact doc = scan 0 [doc]
where
scan :: Int -> [Doc] -> RDoc
scan !_ [] = REmpty
scan !k (d:ds) =
case d of
Empty -> scan k ds
Char c -> RChar c (scan (k+1) ds)
String l s -> RString l s (scan (k+l) ds)
Text s -> RText s (scan (k+T.length s) ds)
Line -> RLine 0 (scan 0 ds)
Nest _ x -> scan k (x:ds)
SrcLoc _ -> scan k ds
Cat x y -> scan k (x:y:ds)
Alt x _ -> scan k (x:ds)
Column f -> scan k (f k:ds)
Nesting f -> scan k (f 0:ds)
displayS :: RDoc -> ShowS
displayS = go
where
go :: RDoc -> ShowS
go REmpty = id
go (RChar c x) = showChar c `mappend` go x
go (RString _ s x) = showString s `mappend` go x
go (RText s x) = showString (T.unpack s) `mappend` go x
go (RPos _ x) = go x
go (RLine i x) = showString ('\n' : replicate i ' ') `mappend` go x
prettyS :: Int -> Doc -> ShowS
prettyS w x = displayS (render w x)
pretty :: Int -> Doc -> String
pretty w x = prettyS w x ""
displayPragmaS :: RDoc -> ShowS
displayPragmaS = go
where
go :: RDoc -> ShowS
go REmpty = id
go (RChar c x) = showChar c `mappend` go x
go (RString _ s x) = showString s `mappend` go x
go (RText s x) = showString (T.unpack s) `mappend` go x
go (RPos p x) = showChar '\n' `mappend`
showString "#line " `mappend`
shows (posLine p) `mappend`
showChar ' ' `mappend`
shows (posFile p) `mappend`
go x
go (RLine i x) = showString ('\n' : replicate i ' ') `mappend`
go x
prettyPragmaS :: Int -> Doc -> ShowS
prettyPragmaS w x = displayPragmaS (render w x)
prettyPragma :: Int -> Doc -> String
prettyPragma w x = prettyPragmaS w x ""
displayLazyText :: RDoc -> L.Text
displayLazyText = B.toLazyText . go
where
go :: RDoc -> B.Builder
go REmpty = mempty
go (RChar c x) = B.singleton c `mappend` go x
go (RString _ s x) = B.fromString s `mappend` go x
go (RText s x) = B.fromText s `mappend` go x
go (RPos _ x) = go x
go (RLine i x) = B.fromString ('\n':replicate i ' ') `mappend` go x
prettyLazyText :: Int -> Doc -> L.Text
prettyLazyText w x = displayLazyText (render w x)
displayPragmaLazyText :: RDoc -> L.Text
displayPragmaLazyText = B.toLazyText . go
where
go :: RDoc -> B.Builder
go REmpty = mempty
go (RChar c x) = B.singleton c `mappend` go x
go (RText s x) = B.fromText s `mappend` go x
go (RString _ s x) = B.fromString s `mappend` go x
go (RPos p x) = B.singleton '\n' `mappend`
B.fromString "#line " `mappend`
(go . renderCompact . ppr) (posLine p) `mappend`
B.singleton ' ' `mappend`
(go . renderCompact . ppr) (posFile p) `mappend`
go x
go (RLine i x) = B.fromString ('\n':replicate i ' ') `mappend`
go x
prettyPragmaLazyText :: Int -> Doc -> L.Text
prettyPragmaLazyText w x = displayPragmaLazyText (render w x)
merge :: Maybe Pos -> Loc -> Maybe Pos
merge Nothing NoLoc = Nothing
merge Nothing (Loc p _) = Just p
merge (Just p) NoLoc = Just p
merge (Just p1) (Loc p2 _) = let p = min p1 p2 in p `seq` Just p
lineloc :: Maybe Pos
-> Maybe Pos
-> (Maybe Pos, RDocS)
lineloc Nothing Nothing = (Nothing, id)
lineloc Nothing (Just p) = (Just p, RPos p)
lineloc (Just p1) (Just p2)
| posFile p2 == posFile p1 &&
posLine p2 == posLine p1 + 1 = (Just p2, id)
| otherwise = (Just p2, RPos p2)
lineloc (Just p1) Nothing
| posFile p2 == posFile p1 &&
posLine p2 == posLine p1 + 1 = (Just p2, id)
| otherwise = (Just p2, RPos p2)
where
p2 = advance p1
advance :: Pos -> Pos
advance (Pos f l c coff) = Pos f (l+1) c coff
data RDoc = REmpty
| RChar Char RDoc
| RString !Int String RDoc
| RText T.Text RDoc
| RPos Pos RDoc
| RLine !Int RDoc
type RDocS = RDoc -> RDoc
data Docs = Nil
| Cons !Int Doc Docs
best :: Int -> Int -> Doc -> RDoc
best !w k x = be Nothing Nothing k id (Cons 0 x Nil)
where
be :: Maybe Pos
-> Maybe Pos
-> Int
-> RDocS
-> Docs
-> RDoc
be _ _ !_ f Nil = f REmpty
be p p' !k f (Cons i d ds) =
case d of
Empty -> be p p' k f ds
Char c -> be p p' (k+1) (f . RChar c) ds
String l s -> be p p' (k+l) (f . RString l s) ds
Text s -> be p p' (k+T.length s) (f . RText s) ds
Line -> (f . pragma . RLine i) (be p'' Nothing i id ds)
x `Cat` y -> be p p' k f (Cons i x (Cons i y ds))
Nest j x -> be p p' k f (Cons (i+j) x ds)
x `Alt` y -> better k f (be p p' k id (Cons i x ds))
(be p p' k id (Cons i y ds))
SrcLoc loc -> be p (merge p' loc) k f ds
Column g -> be p p' k f (Cons i (g k) ds)
Nesting g -> be p p' k f (Cons i (g i) ds)
where
(p'', pragma) = lineloc p p'
better :: Int -> RDocS -> RDoc -> RDoc -> RDoc
better !k f x y | fits (w k) x = f x
| otherwise = f y
fits :: Int -> RDoc -> Bool
fits !w _ | w < 0 = False
fits !_ REmpty = True
fits !w (RChar _ x) = fits (w 1) x
fits !w (RString l _ x) = fits (w l) x
fits !w (RText s x) = fits (w T.length s) x
fits !w (RPos _ x) = fits w x
fits !_ (RLine _ _) = True
#if !MIN_VERSION_base(4,5,0)
infixr 6 <>
(<>) :: Doc -> Doc -> Doc
x <> y = x `Cat` y
#endif /* !MIN_VERSION_base(4,5,0) */
instance Monoid Doc where
mempty = empty
mappend = Cat
instance Show Doc where
showsPrec _ = prettyS 80
class Pretty a where
ppr :: a -> Doc
pprPrec :: Int -> a -> Doc
pprList :: [a] -> Doc
ppr = pprPrec 0
pprPrec _ = ppr
pprList xs = list (map ppr xs)
instance Pretty Int where
ppr = text . show
instance Pretty Integer where
ppr = text . show
instance Pretty Float where
ppr = text . show
instance Pretty Double where
ppr = text . show
ratioPrec, ratioPrec1 :: Int
ratioPrec = 7
ratioPrec1 = ratioPrec + 1
instance (Integral a, Pretty a) => Pretty (Ratio a) where
pprPrec p (x:%y) =
parensIf (p > ratioPrec) $
pprPrec ratioPrec1 x <+> char '%' <+> pprPrec ratioPrec1 y
instance Pretty Bool where
ppr = text . show
instance Pretty Char where
ppr = text . show
pprList = text . show
instance Pretty T.Text where
ppr = text . show
instance Pretty a => Pretty [a] where
ppr = pprList
instance (Pretty a, Pretty b)
=> Pretty (a, b) where
ppr (a, b) = tuple [ppr a, ppr b]
instance (Pretty a, Pretty b, Pretty c)
=> Pretty (a, b, c) where
ppr (a, b, c) = tuple [ppr a, ppr b, ppr c]
instance (Pretty a, Pretty b, Pretty c, Pretty d)
=> Pretty (a, b, c, d) where
ppr (a, b, c, d) = tuple [ppr a, ppr b, ppr c, ppr d]
instance Pretty a => Pretty (Maybe a) where
pprPrec _ Nothing = empty
pprPrec p (Just a) = pprPrec p a
instance Pretty Pos where
ppr p@(Pos _ l c _) =
text (posFile p) <> colon <> ppr l <> colon <> ppr c
instance Pretty Loc where
ppr NoLoc = text "<no location info>"
ppr (Loc p1@(Pos f1 l1 c1 _) p2@(Pos f2 l2 c2 _))
| f1 == f2 = text (posFile p1) <> colon <//> pprLineCol l1 c1 l2 c2
| otherwise = ppr p1 <> text "-" <> ppr p2
where
pprLineCol :: Int -> Int -> Int -> Int -> Doc
pprLineCol l1 c1 l2 c2
| l1 == l2 && c1 == c2 = ppr l1 <//> colon <//> ppr c1
| l1 == l2 && c1 /= c2 = ppr l1 <//> colon <//>
ppr c1 <> text "-" <> ppr c2
| otherwise = ppr l1 <//> colon <//> ppr c1
<> text "-" <>
ppr l2 <//> colon <//> ppr c2
instance Pretty x => Pretty (L x) where
pprPrec p (L _ x) = pprPrec p x
instance (Pretty k, Pretty v) => Pretty (Map.Map k v) where
ppr = pprList . Map.toList
instance Pretty a => Pretty (Set.Set a) where
ppr = pprList . Set.toList
instance Pretty Word8 where
ppr = text . show
instance Pretty Word16 where
ppr = text . show
instance Pretty Word32 where
ppr = text . show
instance Pretty Word64 where
ppr = text . show
instance Pretty Int8 where
ppr = text . show
instance Pretty Int16 where
ppr = text . show
instance Pretty Int32 where
ppr = text . show
instance Pretty Int64 where
ppr = text . show