module Text.PrettyPrint.Mainland (
Doc,
empty, text, char, string, fromText, fromLazyText,
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,
putDoc, hPutDoc,
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.IO as TIO
import qualified Data.Text.Lazy as L
import qualified Data.Text.Lazy.Builder as B
import Data.Word
import GHC.Real (Ratio(..))
import System.IO (Handle)
infixr 5 </>, <+/>, <//>
infixr 6 <+>
data Doc = Empty
| Char Char
| String !Int String
| Text T.Text
| LazyText L.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
fromLazyText :: L.Text -> Doc
fromLazyText = LazyText
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 (LazyText s) = LazyText 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)
LazyText s -> RLazyText s (scan (k+fromIntegral (L.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 (RLazyText s x) = showString (L.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 (RLazyText s x) = showString (L.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 (RLazyText s x) = B.fromLazyText 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 (RLazyText s x) = B.fromLazyText 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
| RLazyText L.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
LazyText s -> be p p' (k+fromIntegral (L.length s)) (f . RLazyText 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 (RLazyText s x) = fits (w fromIntegral (L.length s)) x
fits !w (RPos _ x) = fits w x
fits !_ (RLine _ _) = True
putDoc :: Doc -> IO ()
putDoc = TIO.putStr . prettyLazyText 80
hPutDoc :: Handle -> Doc -> IO ()
hPutDoc h = TIO.hPutStr h . prettyLazyText 80
#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 L.Text where
ppr = text . show
instance Pretty a => Pretty [a] where
ppr = pprList
instance Pretty () where
ppr () =
tuple []
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 b, Pretty c, Pretty d, Pretty e)
=> Pretty (a, b, c, d, e) where
ppr (a, b, c, d, e) =
tuple [ppr a, ppr b, ppr c, ppr d, ppr e]
instance (Pretty a, Pretty b, Pretty c, Pretty d, Pretty e,
Pretty f)
=> Pretty (a, b, c, d, e, f) where
ppr (a, b, c, d, e, f) =
tuple [ppr a, ppr b, ppr c, ppr d, ppr e,
ppr f]
instance (Pretty a, Pretty b, Pretty c, Pretty d, Pretty e,
Pretty f, Pretty g)
=> Pretty (a, b, c, d, e, f, g) where
ppr (a, b, c, d, e, f, g) =
tuple [ppr a, ppr b, ppr c, ppr d, ppr e,
ppr f, ppr g]
instance (Pretty a, Pretty b, Pretty c, Pretty d, Pretty e,
Pretty f, Pretty g, Pretty h)
=> Pretty (a, b, c, d, e, f, g, h) where
ppr (a, b, c, d, e, f, g, h) =
tuple [ppr a, ppr b, ppr c, ppr d, ppr e,
ppr f, ppr g, ppr h]
instance (Pretty a, Pretty b, Pretty c, Pretty d, Pretty e,
Pretty f, Pretty g, Pretty h, Pretty i)
=> Pretty (a, b, c, d, e, f, g, h, i) where
ppr (a, b, c, d, e, f, g, h, i) =
tuple [ppr a, ppr b, ppr c, ppr d, ppr e,
ppr f, ppr g, ppr h, ppr i]
instance (Pretty a, Pretty b, Pretty c, Pretty d, Pretty e,
Pretty f, Pretty g, Pretty h, Pretty i, Pretty j)
=> Pretty (a, b, c, d, e, f, g, h, i, j) where
ppr (a, b, c, d, e, f, g, h, i, j) =
tuple [ppr a, ppr b, ppr c, ppr d, ppr e,
ppr f, ppr g, ppr h, ppr i, ppr j]
instance (Pretty a, Pretty b, Pretty c, Pretty d, Pretty e,
Pretty f, Pretty g, Pretty h, Pretty i, Pretty j,
Pretty k)
=> Pretty (a, b, c, d, e, f, g, h, i, j, k) where
ppr (a, b, c, d, e, f, g, h, i, j, k) =
tuple [ppr a, ppr b, ppr c, ppr d, ppr e,
ppr f, ppr g, ppr h, ppr i, ppr j,
ppr k]
instance (Pretty a, Pretty b, Pretty c, Pretty d, Pretty e,
Pretty f, Pretty g, Pretty h, Pretty i, Pretty j,
Pretty k, Pretty l)
=> Pretty (a, b, c, d, e, f, g, h, i, j, k, l) where
ppr (a, b, c, d, e, f, g, h, i, j, k, l) =
tuple [ppr a, ppr b, ppr c, ppr d, ppr e,
ppr f, ppr g, ppr h, ppr i, ppr j,
ppr k, ppr l]
instance (Pretty a, Pretty b, Pretty c, Pretty d, Pretty e,
Pretty f, Pretty g, Pretty h, Pretty i, Pretty j,
Pretty k, Pretty l, Pretty m)
=> Pretty (a, b, c, d, e, f, g, h, i, j, k, l, m) where
ppr (a, b, c, d, e, f, g, h, i, j, k, l, m) =
tuple [ppr a, ppr b, ppr c, ppr d, ppr e,
ppr f, ppr g, ppr h, ppr i, ppr j,
ppr k, ppr l, ppr m]
instance (Pretty a, Pretty b, Pretty c, Pretty d, Pretty e,
Pretty f, Pretty g, Pretty h, Pretty i, Pretty j,
Pretty k, Pretty l, Pretty m, Pretty n)
=> Pretty (a, b, c, d, e, f, g, h, i, j, k, l, m, n) where
ppr (a, b, c, d, e, f, g, h, i, j, k, l, m, n) =
tuple [ppr a, ppr b, ppr c, ppr d, ppr e,
ppr f, ppr g, ppr h, ppr i, ppr j,
ppr k, ppr l, ppr m, ppr n]
instance (Pretty a, Pretty b, Pretty c, Pretty d, Pretty e,
Pretty f, Pretty g, Pretty h, Pretty i, Pretty j,
Pretty k, Pretty l, Pretty m, Pretty n, Pretty o)
=> Pretty (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) where
ppr (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) =
tuple [ppr a, ppr b, ppr c, ppr d, ppr e,
ppr f, ppr g, ppr h, ppr i, ppr j,
ppr k, ppr l, ppr m, ppr n, ppr o]
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