Reexport Semigroup's <> operator from Prelude (#14191)
[ghc.git] / libraries / template-haskell / Language / Haskell / TH / Ppr.hs
1 -- | contains a prettyprinter for the
2 -- Template Haskell datatypes
3
4 module Language.Haskell.TH.Ppr where
5 -- All of the exports from this module should
6 -- be "public" functions. The main module TH
7 -- re-exports them all.
8
9 import Text.PrettyPrint (render)
10 import Language.Haskell.TH.PprLib
11 import Language.Haskell.TH.Syntax
12 import Data.Word ( Word8 )
13 import Data.Char ( toLower, chr)
14 import GHC.Show ( showMultiLineString )
15 import GHC.Lexeme( startsVarSym )
16 import Data.Ratio ( numerator, denominator )
17 import Prelude hiding ((<>))
18
19 nestDepth :: Int
20 nestDepth = 4
21
22 type Precedence = Int
23 appPrec, unopPrec, opPrec, noPrec :: Precedence
24 appPrec = 3 -- Argument of a function application
25 opPrec = 2 -- Argument of an infix operator
26 unopPrec = 1 -- Argument of an unresolved infix operator
27 noPrec = 0 -- Others
28
29 parensIf :: Bool -> Doc -> Doc
30 parensIf True d = parens d
31 parensIf False d = d
32
33 ------------------------------
34
35 pprint :: Ppr a => a -> String
36 pprint x = render $ to_HPJ_Doc $ ppr x
37
38 class Ppr a where
39 ppr :: a -> Doc
40 ppr_list :: [a] -> Doc
41 ppr_list = vcat . map ppr
42
43 instance Ppr a => Ppr [a] where
44 ppr x = ppr_list x
45
46 ------------------------------
47 instance Ppr Name where
48 ppr v = pprName v
49
50 ------------------------------
51 instance Ppr Info where
52 ppr (TyConI d) = ppr d
53 ppr (ClassI d is) = ppr d $$ vcat (map ppr is)
54 ppr (FamilyI d is) = ppr d $$ vcat (map ppr is)
55 ppr (PrimTyConI name arity is_unlifted)
56 = text "Primitive"
57 <+> (if is_unlifted then text "unlifted" else empty)
58 <+> text "type constructor" <+> quotes (ppr name)
59 <+> parens (text "arity" <+> int arity)
60 ppr (ClassOpI v ty cls)
61 = text "Class op from" <+> ppr cls <> colon <+> ppr_sig v ty
62 ppr (DataConI v ty tc)
63 = text "Constructor from" <+> ppr tc <> colon <+> ppr_sig v ty
64 ppr (PatSynI nm ty) = pprPatSynSig nm ty
65 ppr (TyVarI v ty)
66 = text "Type variable" <+> ppr v <+> equals <+> ppr ty
67 ppr (VarI v ty mb_d)
68 = vcat [ppr_sig v ty,
69 case mb_d of { Nothing -> empty; Just d -> ppr d }]
70
71 ppr_sig :: Name -> Type -> Doc
72 ppr_sig v ty = pprName' Applied v <+> dcolon <+> ppr ty
73
74 pprFixity :: Name -> Fixity -> Doc
75 pprFixity _ f | f == defaultFixity = empty
76 pprFixity v (Fixity i d) = ppr_fix d <+> int i <+> ppr v
77 where ppr_fix InfixR = text "infixr"
78 ppr_fix InfixL = text "infixl"
79 ppr_fix InfixN = text "infix"
80
81 -- | Pretty prints a pattern synonym type signature
82 pprPatSynSig :: Name -> PatSynType -> Doc
83 pprPatSynSig nm ty
84 = text "pattern" <+> pprPrefixOcc nm <+> dcolon <+> pprPatSynType ty
85
86 -- | Pretty prints a pattern synonym's type; follows the usual
87 -- conventions to print a pattern synonym type compactly, yet
88 -- unambiguously. See the note on 'PatSynType' and the section on
89 -- pattern synonyms in the GHC user's guide for more information.
90 pprPatSynType :: PatSynType -> Doc
91 pprPatSynType ty@(ForallT uniTys reqs ty'@(ForallT exTys provs ty''))
92 | null exTys, null provs = ppr (ForallT uniTys reqs ty'')
93 | null uniTys, null reqs = noreqs <+> ppr ty'
94 | null reqs = forall uniTys <+> noreqs <+> ppr ty'
95 | otherwise = ppr ty
96 where noreqs = text "() =>"
97 forall tvs = text "forall" <+> (hsep (map ppr tvs)) <+> text "."
98 pprPatSynType ty = ppr ty
99
100 ------------------------------
101 instance Ppr Module where
102 ppr (Module pkg m) = text (pkgString pkg) <+> text (modString m)
103
104 instance Ppr ModuleInfo where
105 ppr (ModuleInfo imps) = text "Module" <+> vcat (map ppr imps)
106
107 ------------------------------
108 instance Ppr Exp where
109 ppr = pprExp noPrec
110
111 pprPrefixOcc :: Name -> Doc
112 -- Print operators with parens around them
113 pprPrefixOcc n = parensIf (isSymOcc n) (ppr n)
114
115 isSymOcc :: Name -> Bool
116 isSymOcc n
117 = case nameBase n of
118 [] -> True -- Empty name; weird
119 (c:_) -> startsVarSym c
120 -- c.f. OccName.startsVarSym in GHC itself
121
122 pprInfixExp :: Exp -> Doc
123 pprInfixExp (VarE v) = pprName' Infix v
124 pprInfixExp (ConE v) = pprName' Infix v
125 pprInfixExp _ = text "<<Non-variable/constructor in infix context>>"
126
127 pprExp :: Precedence -> Exp -> Doc
128 pprExp _ (VarE v) = pprName' Applied v
129 pprExp _ (ConE c) = pprName' Applied c
130 pprExp i (LitE l) = pprLit i l
131 pprExp i (AppE e1 e2) = parensIf (i >= appPrec) $ pprExp opPrec e1
132 <+> pprExp appPrec e2
133 pprExp i (AppTypeE e t)
134 = parensIf (i >= appPrec) $ pprExp opPrec e <+> char '@' <> pprParendType t
135 pprExp _ (ParensE e) = parens (pprExp noPrec e)
136 pprExp i (UInfixE e1 op e2)
137 = parensIf (i > unopPrec) $ pprExp unopPrec e1
138 <+> pprInfixExp op
139 <+> pprExp unopPrec e2
140 pprExp i (InfixE (Just e1) op (Just e2))
141 = parensIf (i >= opPrec) $ pprExp opPrec e1
142 <+> pprInfixExp op
143 <+> pprExp opPrec e2
144 pprExp _ (InfixE me1 op me2) = parens $ pprMaybeExp noPrec me1
145 <+> pprInfixExp op
146 <+> pprMaybeExp noPrec me2
147 pprExp i (LamE [] e) = pprExp i e -- #13856
148 pprExp i (LamE ps e) = parensIf (i > noPrec) $ char '\\' <> hsep (map (pprPat appPrec) ps)
149 <+> text "->" <+> ppr e
150 pprExp i (LamCaseE ms) = parensIf (i > noPrec)
151 $ text "\\case" $$ nest nestDepth (ppr ms)
152 pprExp _ (TupE es) = parens (commaSep es)
153 pprExp _ (UnboxedTupE es) = hashParens (commaSep es)
154 pprExp _ (UnboxedSumE e alt arity) = unboxedSumBars (ppr e) alt arity
155 -- Nesting in Cond is to avoid potential problems in do statements
156 pprExp i (CondE guard true false)
157 = parensIf (i > noPrec) $ sep [text "if" <+> ppr guard,
158 nest 1 $ text "then" <+> ppr true,
159 nest 1 $ text "else" <+> ppr false]
160 pprExp i (MultiIfE alts)
161 = parensIf (i > noPrec) $ vcat $
162 case alts of
163 [] -> [text "if {}"]
164 (alt : alts') -> text "if" <+> pprGuarded arrow alt
165 : map (nest 3 . pprGuarded arrow) alts'
166 pprExp i (LetE ds_ e) = parensIf (i > noPrec) $ text "let" <+> pprDecs ds_
167 $$ text " in" <+> ppr e
168 where
169 pprDecs [] = empty
170 pprDecs [d] = ppr d
171 pprDecs ds = braces (semiSep ds)
172
173 pprExp i (CaseE e ms)
174 = parensIf (i > noPrec) $ text "case" <+> ppr e <+> text "of"
175 $$ nest nestDepth (ppr ms)
176 pprExp i (DoE ss_) = parensIf (i > noPrec) $ text "do" <+> pprStms ss_
177 where
178 pprStms [] = empty
179 pprStms [s] = ppr s
180 pprStms ss = braces (semiSep ss)
181
182 pprExp _ (CompE []) = text "<<Empty CompExp>>"
183 -- This will probably break with fixity declarations - would need a ';'
184 pprExp _ (CompE ss) =
185 if null ss'
186 -- If there are no statements in a list comprehension besides the last
187 -- one, we simply treat it like a normal list.
188 then text "[" <> ppr s <> text "]"
189 else text "[" <> ppr s
190 <+> bar
191 <+> commaSep ss'
192 <> text "]"
193 where s = last ss
194 ss' = init ss
195 pprExp _ (ArithSeqE d) = ppr d
196 pprExp _ (ListE es) = brackets (commaSep es)
197 pprExp i (SigE e t) = parensIf (i > noPrec) $ ppr e <+> dcolon <+> ppr t
198 pprExp _ (RecConE nm fs) = ppr nm <> braces (pprFields fs)
199 pprExp _ (RecUpdE e fs) = pprExp appPrec e <> braces (pprFields fs)
200 pprExp i (StaticE e) = parensIf (i >= appPrec) $
201 text "static"<+> pprExp appPrec e
202 pprExp _ (UnboundVarE v) = pprName' Applied v
203 pprExp _ (LabelE s) = text "#" <> text s
204
205 pprFields :: [(Name,Exp)] -> Doc
206 pprFields = sep . punctuate comma . map (\(s,e) -> ppr s <+> equals <+> ppr e)
207
208 pprMaybeExp :: Precedence -> Maybe Exp -> Doc
209 pprMaybeExp _ Nothing = empty
210 pprMaybeExp i (Just e) = pprExp i e
211
212 ------------------------------
213 instance Ppr Stmt where
214 ppr (BindS p e) = ppr p <+> text "<-" <+> ppr e
215 ppr (LetS ds) = text "let" <+> (braces (semiSep ds))
216 ppr (NoBindS e) = ppr e
217 ppr (ParS sss) = sep $ punctuate bar
218 $ map commaSep sss
219
220 ------------------------------
221 instance Ppr Match where
222 ppr (Match p rhs ds) = ppr p <+> pprBody False rhs
223 $$ where_clause ds
224
225 ------------------------------
226 pprGuarded :: Doc -> (Guard, Exp) -> Doc
227 pprGuarded eqDoc (guard, expr) = case guard of
228 NormalG guardExpr -> bar <+> ppr guardExpr <+> eqDoc <+> ppr expr
229 PatG stmts -> bar <+> vcat (punctuate comma $ map ppr stmts) $$
230 nest nestDepth (eqDoc <+> ppr expr)
231
232 ------------------------------
233 pprBody :: Bool -> Body -> Doc
234 pprBody eq body = case body of
235 GuardedB xs -> nest nestDepth $ vcat $ map (pprGuarded eqDoc) xs
236 NormalB e -> eqDoc <+> ppr e
237 where eqDoc | eq = equals
238 | otherwise = arrow
239
240 ------------------------------
241 instance Ppr Lit where
242 ppr = pprLit noPrec
243
244 pprLit :: Precedence -> Lit -> Doc
245 pprLit i (IntPrimL x) = parensIf (i > noPrec && x < 0)
246 (integer x <> char '#')
247 pprLit _ (WordPrimL x) = integer x <> text "##"
248 pprLit i (FloatPrimL x) = parensIf (i > noPrec && x < 0)
249 (float (fromRational x) <> char '#')
250 pprLit i (DoublePrimL x) = parensIf (i > noPrec && x < 0)
251 (double (fromRational x) <> text "##")
252 pprLit i (IntegerL x) = parensIf (i > noPrec && x < 0) (integer x)
253 pprLit _ (CharL c) = text (show c)
254 pprLit _ (CharPrimL c) = text (show c) <> char '#'
255 pprLit _ (StringL s) = pprString s
256 pprLit _ (StringPrimL s) = pprString (bytesToString s) <> char '#'
257 pprLit i (RationalL rat) = parensIf (i > noPrec) $
258 integer (numerator rat) <+> char '/'
259 <+> integer (denominator rat)
260
261 bytesToString :: [Word8] -> String
262 bytesToString = map (chr . fromIntegral)
263
264 pprString :: String -> Doc
265 -- Print newlines as newlines with Haskell string escape notation,
266 -- not as '\n'. For other non-printables use regular escape notation.
267 pprString s = vcat (map text (showMultiLineString s))
268
269 ------------------------------
270 instance Ppr Pat where
271 ppr = pprPat noPrec
272
273 pprPat :: Precedence -> Pat -> Doc
274 pprPat i (LitP l) = pprLit i l
275 pprPat _ (VarP v) = pprName' Applied v
276 pprPat _ (TupP ps) = parens (commaSep ps)
277 pprPat _ (UnboxedTupP ps) = hashParens (commaSep ps)
278 pprPat _ (UnboxedSumP p alt arity) = unboxedSumBars (ppr p) alt arity
279 pprPat i (ConP s ps) = parensIf (i >= appPrec) $ pprName' Applied s
280 <+> sep (map (pprPat appPrec) ps)
281 pprPat _ (ParensP p) = parens $ pprPat noPrec p
282 pprPat i (UInfixP p1 n p2)
283 = parensIf (i > unopPrec) (pprPat unopPrec p1 <+>
284 pprName' Infix n <+>
285 pprPat unopPrec p2)
286 pprPat i (InfixP p1 n p2)
287 = parensIf (i >= opPrec) (pprPat opPrec p1 <+>
288 pprName' Infix n <+>
289 pprPat opPrec p2)
290 pprPat i (TildeP p) = parensIf (i > noPrec) $ char '~' <> pprPat appPrec p
291 pprPat i (BangP p) = parensIf (i > noPrec) $ char '!' <> pprPat appPrec p
292 pprPat i (AsP v p) = parensIf (i > noPrec) $ ppr v <> text "@"
293 <> pprPat appPrec p
294 pprPat _ WildP = text "_"
295 pprPat _ (RecP nm fs)
296 = parens $ ppr nm
297 <+> braces (sep $ punctuate comma $
298 map (\(s,p) -> ppr s <+> equals <+> ppr p) fs)
299 pprPat _ (ListP ps) = brackets (commaSep ps)
300 pprPat i (SigP p t) = parensIf (i > noPrec) $ ppr p <+> dcolon <+> ppr t
301 pprPat _ (ViewP e p) = parens $ pprExp noPrec e <+> text "->" <+> pprPat noPrec p
302
303 ------------------------------
304 instance Ppr Dec where
305 ppr = ppr_dec True
306
307 ppr_dec :: Bool -- declaration on the toplevel?
308 -> Dec
309 -> Doc
310 ppr_dec _ (FunD f cs) = vcat $ map (\c -> pprPrefixOcc f <+> ppr c) cs
311 ppr_dec _ (ValD p r ds) = ppr p <+> pprBody True r
312 $$ where_clause ds
313 ppr_dec _ (TySynD t xs rhs)
314 = ppr_tySyn empty t (hsep (map ppr xs)) rhs
315 ppr_dec _ (DataD ctxt t xs ksig cs decs)
316 = ppr_data empty ctxt t (hsep (map ppr xs)) ksig cs decs
317 ppr_dec _ (NewtypeD ctxt t xs ksig c decs)
318 = ppr_newtype empty ctxt t (sep (map ppr xs)) ksig c decs
319 ppr_dec _ (ClassD ctxt c xs fds ds)
320 = text "class" <+> pprCxt ctxt <+> ppr c <+> hsep (map ppr xs) <+> ppr fds
321 $$ where_clause ds
322 ppr_dec _ (InstanceD o ctxt i ds) =
323 text "instance" <+> maybe empty ppr_overlap o <+> pprCxt ctxt <+> ppr i
324 $$ where_clause ds
325 ppr_dec _ (SigD f t) = pprPrefixOcc f <+> dcolon <+> ppr t
326 ppr_dec _ (ForeignD f) = ppr f
327 ppr_dec _ (InfixD fx n) = pprFixity n fx
328 ppr_dec _ (PragmaD p) = ppr p
329 ppr_dec isTop (DataFamilyD tc tvs kind)
330 = text "data" <+> maybeFamily <+> ppr tc <+> hsep (map ppr tvs) <+> maybeKind
331 where
332 maybeFamily | isTop = text "family"
333 | otherwise = empty
334 maybeKind | (Just k') <- kind = dcolon <+> ppr k'
335 | otherwise = empty
336 ppr_dec isTop (DataInstD ctxt tc tys ksig cs decs)
337 = ppr_data maybeInst ctxt tc (sep (map pprParendType tys)) ksig cs decs
338 where
339 maybeInst | isTop = text "instance"
340 | otherwise = empty
341 ppr_dec isTop (NewtypeInstD ctxt tc tys ksig c decs)
342 = ppr_newtype maybeInst ctxt tc (sep (map pprParendType tys)) ksig c decs
343 where
344 maybeInst | isTop = text "instance"
345 | otherwise = empty
346 ppr_dec isTop (TySynInstD tc (TySynEqn tys rhs))
347 = ppr_tySyn maybeInst tc (sep (map pprParendType tys)) rhs
348 where
349 maybeInst | isTop = text "instance"
350 | otherwise = empty
351 ppr_dec isTop (OpenTypeFamilyD tfhead)
352 = text "type" <+> maybeFamily <+> ppr_tf_head tfhead
353 where
354 maybeFamily | isTop = text "family"
355 | otherwise = empty
356 ppr_dec _ (ClosedTypeFamilyD tfhead@(TypeFamilyHead tc _ _ _) eqns)
357 = hang (text "type family" <+> ppr_tf_head tfhead <+> text "where")
358 nestDepth (vcat (map ppr_eqn eqns))
359 where
360 ppr_eqn (TySynEqn lhs rhs)
361 = ppr tc <+> sep (map pprParendType lhs) <+> text "=" <+> ppr rhs
362 ppr_dec _ (RoleAnnotD name roles)
363 = hsep [ text "type role", ppr name ] <+> hsep (map ppr roles)
364 ppr_dec _ (StandaloneDerivD ds cxt ty)
365 = hsep [ text "deriving"
366 , maybe empty ppr_deriv_strategy ds
367 , text "instance"
368 , pprCxt cxt
369 , ppr ty ]
370 ppr_dec _ (DefaultSigD n ty)
371 = hsep [ text "default", pprPrefixOcc n, dcolon, ppr ty ]
372 ppr_dec _ (PatSynD name args dir pat)
373 = text "pattern" <+> pprNameArgs <+> ppr dir <+> pprPatRHS
374 where
375 pprNameArgs | InfixPatSyn a1 a2 <- args = ppr a1 <+> ppr name <+> ppr a2
376 | otherwise = ppr name <+> ppr args
377 pprPatRHS | ExplBidir cls <- dir = hang (ppr pat <+> text "where")
378 nestDepth (ppr name <+> ppr cls)
379 | otherwise = ppr pat
380 ppr_dec _ (PatSynSigD name ty)
381 = pprPatSynSig name ty
382
383 ppr_deriv_strategy :: DerivStrategy -> Doc
384 ppr_deriv_strategy ds = text $
385 case ds of
386 StockStrategy -> "stock"
387 AnyclassStrategy -> "anyclass"
388 NewtypeStrategy -> "newtype"
389
390 ppr_overlap :: Overlap -> Doc
391 ppr_overlap o = text $
392 case o of
393 Overlaps -> "{-# OVERLAPS #-}"
394 Overlappable -> "{-# OVERLAPPABLE #-}"
395 Overlapping -> "{-# OVERLAPPING #-}"
396 Incoherent -> "{-# INCOHERENT #-}"
397
398 ppr_data :: Doc -> Cxt -> Name -> Doc -> Maybe Kind -> [Con] -> [DerivClause]
399 -> Doc
400 ppr_data maybeInst ctxt t argsDoc ksig cs decs
401 = sep [text "data" <+> maybeInst
402 <+> pprCxt ctxt
403 <+> pprName' Applied t <+> argsDoc <+> ksigDoc <+> maybeWhere,
404 nest nestDepth (sep (pref $ map ppr cs)),
405 if null decs
406 then empty
407 else nest nestDepth
408 $ vcat $ map ppr_deriv_clause decs]
409 where
410 pref :: [Doc] -> [Doc]
411 pref xs | isGadtDecl = xs
412 pref [] = [] -- No constructors; can't happen in H98
413 pref (d:ds) = (char '=' <+> d):map (bar <+>) ds
414
415 maybeWhere :: Doc
416 maybeWhere | isGadtDecl = text "where"
417 | otherwise = empty
418
419 isGadtDecl :: Bool
420 isGadtDecl = not (null cs) && all isGadtCon cs
421 where isGadtCon (GadtC _ _ _ ) = True
422 isGadtCon (RecGadtC _ _ _) = True
423 isGadtCon (ForallC _ _ x ) = isGadtCon x
424 isGadtCon _ = False
425
426 ksigDoc = case ksig of
427 Nothing -> empty
428 Just k -> dcolon <+> ppr k
429
430 ppr_newtype :: Doc -> Cxt -> Name -> Doc -> Maybe Kind -> Con -> [DerivClause]
431 -> Doc
432 ppr_newtype maybeInst ctxt t argsDoc ksig c decs
433 = sep [text "newtype" <+> maybeInst
434 <+> pprCxt ctxt
435 <+> ppr t <+> argsDoc <+> ksigDoc,
436 nest 2 (char '=' <+> ppr c),
437 if null decs
438 then empty
439 else nest nestDepth
440 $ vcat $ map ppr_deriv_clause decs]
441 where
442 ksigDoc = case ksig of
443 Nothing -> empty
444 Just k -> dcolon <+> ppr k
445
446 ppr_deriv_clause :: DerivClause -> Doc
447 ppr_deriv_clause (DerivClause ds ctxt)
448 = text "deriving" <+> maybe empty ppr_deriv_strategy ds
449 <+> ppr_cxt_preds ctxt
450
451 ppr_tySyn :: Doc -> Name -> Doc -> Type -> Doc
452 ppr_tySyn maybeInst t argsDoc rhs
453 = text "type" <+> maybeInst <+> ppr t <+> argsDoc <+> text "=" <+> ppr rhs
454
455 ppr_tf_head :: TypeFamilyHead -> Doc
456 ppr_tf_head (TypeFamilyHead tc tvs res inj)
457 = ppr tc <+> hsep (map ppr tvs) <+> ppr res <+> maybeInj
458 where
459 maybeInj | (Just inj') <- inj = ppr inj'
460 | otherwise = empty
461
462 ------------------------------
463 instance Ppr FunDep where
464 ppr (FunDep xs ys) = hsep (map ppr xs) <+> text "->" <+> hsep (map ppr ys)
465 ppr_list [] = empty
466 ppr_list xs = bar <+> commaSep xs
467
468 ------------------------------
469 instance Ppr FamFlavour where
470 ppr DataFam = text "data"
471 ppr TypeFam = text "type"
472
473 ------------------------------
474 instance Ppr FamilyResultSig where
475 ppr NoSig = empty
476 ppr (KindSig k) = dcolon <+> ppr k
477 ppr (TyVarSig bndr) = text "=" <+> ppr bndr
478
479 ------------------------------
480 instance Ppr InjectivityAnn where
481 ppr (InjectivityAnn lhs rhs) =
482 bar <+> ppr lhs <+> text "->" <+> hsep (map ppr rhs)
483
484 ------------------------------
485 instance Ppr Foreign where
486 ppr (ImportF callconv safety impent as typ)
487 = text "foreign import"
488 <+> showtextl callconv
489 <+> showtextl safety
490 <+> text (show impent)
491 <+> ppr as
492 <+> dcolon <+> ppr typ
493 ppr (ExportF callconv expent as typ)
494 = text "foreign export"
495 <+> showtextl callconv
496 <+> text (show expent)
497 <+> ppr as
498 <+> dcolon <+> ppr typ
499
500 ------------------------------
501 instance Ppr Pragma where
502 ppr (InlineP n inline rm phases)
503 = text "{-#"
504 <+> ppr inline
505 <+> ppr rm
506 <+> ppr phases
507 <+> ppr n
508 <+> text "#-}"
509 ppr (SpecialiseP n ty inline phases)
510 = text "{-# SPECIALISE"
511 <+> maybe empty ppr inline
512 <+> ppr phases
513 <+> sep [ ppr n <+> dcolon
514 , nest 2 $ ppr ty ]
515 <+> text "#-}"
516 ppr (SpecialiseInstP inst)
517 = text "{-# SPECIALISE instance" <+> ppr inst <+> text "#-}"
518 ppr (RuleP n bndrs lhs rhs phases)
519 = sep [ text "{-# RULES" <+> pprString n <+> ppr phases
520 , nest 4 $ ppr_forall <+> ppr lhs
521 , nest 4 $ char '=' <+> ppr rhs <+> text "#-}" ]
522 where ppr_forall | null bndrs = empty
523 | otherwise = text "forall"
524 <+> fsep (map ppr bndrs)
525 <+> char '.'
526 ppr (AnnP tgt expr)
527 = text "{-# ANN" <+> target1 tgt <+> ppr expr <+> text "#-}"
528 where target1 ModuleAnnotation = text "module"
529 target1 (TypeAnnotation t) = text "type" <+> ppr t
530 target1 (ValueAnnotation v) = ppr v
531 ppr (LineP line file)
532 = text "{-# LINE" <+> int line <+> text (show file) <+> text "#-}"
533 ppr (CompleteP cls mty)
534 = text "{-# COMPLETE" <+> (fsep $ punctuate comma $ map ppr cls)
535 <+> maybe empty (\ty -> dcolon <+> ppr ty) mty
536
537 ------------------------------
538 instance Ppr Inline where
539 ppr NoInline = text "NOINLINE"
540 ppr Inline = text "INLINE"
541 ppr Inlinable = text "INLINABLE"
542
543 ------------------------------
544 instance Ppr RuleMatch where
545 ppr ConLike = text "CONLIKE"
546 ppr FunLike = empty
547
548 ------------------------------
549 instance Ppr Phases where
550 ppr AllPhases = empty
551 ppr (FromPhase i) = brackets $ int i
552 ppr (BeforePhase i) = brackets $ char '~' <> int i
553
554 ------------------------------
555 instance Ppr RuleBndr where
556 ppr (RuleVar n) = ppr n
557 ppr (TypedRuleVar n ty) = parens $ ppr n <+> dcolon <+> ppr ty
558
559 ------------------------------
560 instance Ppr Clause where
561 ppr (Clause ps rhs ds) = hsep (map (pprPat appPrec) ps) <+> pprBody True rhs
562 $$ where_clause ds
563
564 ------------------------------
565 instance Ppr Con where
566 ppr (NormalC c sts) = ppr c <+> sep (map pprBangType sts)
567
568 ppr (RecC c vsts)
569 = ppr c <+> braces (sep (punctuate comma $ map pprVarBangType vsts))
570
571 ppr (InfixC st1 c st2) = pprBangType st1
572 <+> pprName' Infix c
573 <+> pprBangType st2
574
575 ppr (ForallC ns ctxt (GadtC c sts ty))
576 = commaSepApplied c <+> dcolon <+> pprForall ns ctxt
577 <+> pprGadtRHS sts ty
578
579 ppr (ForallC ns ctxt (RecGadtC c vsts ty))
580 = commaSepApplied c <+> dcolon <+> pprForall ns ctxt
581 <+> pprRecFields vsts ty
582
583 ppr (ForallC ns ctxt con)
584 = pprForall ns ctxt <+> ppr con
585
586 ppr (GadtC c sts ty)
587 = commaSepApplied c <+> dcolon <+> pprGadtRHS sts ty
588
589 ppr (RecGadtC c vsts ty)
590 = commaSepApplied c <+> dcolon <+> pprRecFields vsts ty
591
592 instance Ppr PatSynDir where
593 ppr Unidir = text "<-"
594 ppr ImplBidir = text "="
595 ppr (ExplBidir _) = text "<-"
596 -- the ExplBidir's clauses are pretty printed together with the
597 -- entire pattern synonym; so only print the direction here.
598
599 instance Ppr PatSynArgs where
600 ppr (PrefixPatSyn args) = sep $ map ppr args
601 ppr (InfixPatSyn a1 a2) = ppr a1 <+> ppr a2
602 ppr (RecordPatSyn sels) = braces $ sep (punctuate comma (map ppr sels))
603
604 commaSepApplied :: [Name] -> Doc
605 commaSepApplied = commaSepWith (pprName' Applied)
606
607 pprForall :: [TyVarBndr] -> Cxt -> Doc
608 pprForall tvs cxt
609 -- even in the case without any tvs, there could be a non-empty
610 -- context cxt (e.g., in the case of pattern synonyms, where there
611 -- are multiple forall binders and contexts).
612 | [] <- tvs = pprCxt cxt
613 | otherwise = text "forall" <+> hsep (map ppr tvs) <+> char '.' <+> pprCxt cxt
614
615 pprRecFields :: [(Name, Strict, Type)] -> Type -> Doc
616 pprRecFields vsts ty
617 = braces (sep (punctuate comma $ map pprVarBangType vsts))
618 <+> arrow <+> ppr ty
619
620 pprGadtRHS :: [(Strict, Type)] -> Type -> Doc
621 pprGadtRHS [] ty
622 = ppr ty
623 pprGadtRHS sts ty
624 = sep (punctuate (space <> arrow) (map pprBangType sts))
625 <+> arrow <+> ppr ty
626
627 ------------------------------
628 pprVarBangType :: VarBangType -> Doc
629 -- Slight infelicity: with print non-atomic type with parens
630 pprVarBangType (v, bang, t) = ppr v <+> dcolon <+> pprBangType (bang, t)
631
632 ------------------------------
633 pprBangType :: BangType -> Doc
634 -- Make sure we print
635 --
636 -- Con {-# UNPACK #-} a
637 --
638 -- rather than
639 --
640 -- Con {-# UNPACK #-}a
641 --
642 -- when there's no strictness annotation. If there is a strictness annotation,
643 -- it's okay to not put a space between it and the type.
644 pprBangType (bt@(Bang _ NoSourceStrictness), t) = ppr bt <+> pprParendType t
645 pprBangType (bt, t) = ppr bt <> pprParendType t
646
647 ------------------------------
648 instance Ppr Bang where
649 ppr (Bang su ss) = ppr su <+> ppr ss
650
651 ------------------------------
652 instance Ppr SourceUnpackedness where
653 ppr NoSourceUnpackedness = empty
654 ppr SourceNoUnpack = text "{-# NOUNPACK #-}"
655 ppr SourceUnpack = text "{-# UNPACK #-}"
656
657 ------------------------------
658 instance Ppr SourceStrictness where
659 ppr NoSourceStrictness = empty
660 ppr SourceLazy = char '~'
661 ppr SourceStrict = char '!'
662
663 ------------------------------
664 instance Ppr DecidedStrictness where
665 ppr DecidedLazy = empty
666 ppr DecidedStrict = char '!'
667 ppr DecidedUnpack = text "{-# UNPACK #-} !"
668
669 ------------------------------
670 {-# DEPRECATED pprVarStrictType
671 "As of @template-haskell-2.11.0.0@, 'VarStrictType' has been replaced by 'VarBangType'. Please use 'pprVarBangType' instead." #-}
672 pprVarStrictType :: (Name, Strict, Type) -> Doc
673 pprVarStrictType = pprVarBangType
674
675 ------------------------------
676 {-# DEPRECATED pprStrictType
677 "As of @template-haskell-2.11.0.0@, 'StrictType' has been replaced by 'BangType'. Please use 'pprBangType' instead." #-}
678 pprStrictType :: (Strict, Type) -> Doc
679 pprStrictType = pprBangType
680
681 ------------------------------
682 pprParendType :: Type -> Doc
683 pprParendType (VarT v) = pprName' Applied v
684 -- `Applied` is used here instead of `ppr` because of infix names (#13887)
685 pprParendType (ConT c) = pprName' Applied c
686 pprParendType (TupleT 0) = text "()"
687 pprParendType (TupleT n) = parens (hcat (replicate (n-1) comma))
688 pprParendType (UnboxedTupleT n) = hashParens $ hcat $ replicate (n-1) comma
689 pprParendType (UnboxedSumT arity) = hashParens $ hcat $ replicate (arity-1) bar
690 pprParendType ArrowT = parens (text "->")
691 pprParendType ListT = text "[]"
692 pprParendType (LitT l) = pprTyLit l
693 pprParendType (PromotedT c) = text "'" <> pprName' Applied c
694 pprParendType (PromotedTupleT 0) = text "'()"
695 pprParendType (PromotedTupleT n) = quoteParens (hcat (replicate (n-1) comma))
696 pprParendType PromotedNilT = text "'[]"
697 pprParendType PromotedConsT = text "'(:)"
698 pprParendType StarT = char '*'
699 pprParendType ConstraintT = text "Constraint"
700 pprParendType (SigT ty k) = parens (ppr ty <+> text "::" <+> ppr k)
701 pprParendType WildCardT = char '_'
702 pprParendType (InfixT x n y) = parens (ppr x <+> pprName' Infix n <+> ppr y)
703 pprParendType t@(UInfixT {}) = parens (pprUInfixT t)
704 pprParendType (ParensT t) = ppr t
705 pprParendType tuple | (TupleT n, args) <- split tuple
706 , length args == n
707 = parens (commaSep args)
708 pprParendType other = parens (ppr other)
709
710 pprUInfixT :: Type -> Doc
711 pprUInfixT (UInfixT x n y) = pprUInfixT x <+> pprName' Infix n <+> pprUInfixT y
712 pprUInfixT t = ppr t
713
714 instance Ppr Type where
715 ppr (ForallT tvars ctxt ty) = sep [pprForall tvars ctxt, ppr ty]
716 ppr ty = pprTyApp (split ty)
717 -- Works, in a degnerate way, for SigT, and puts parens round (ty :: kind)
718 -- See Note [Pretty-printing kind signatures]
719
720 {- Note [Pretty-printing kind signatures]
721 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
722 GHC's parser only recognises a kind signature in a type when there are
723 parens around it. E.g. the parens are required here:
724 f :: (Int :: *)
725 type instance F Int = (Bool :: *)
726 So we always print a SigT with parens (see Trac #10050). -}
727
728 pprTyApp :: (Type, [Type]) -> Doc
729 pprTyApp (ArrowT, [arg1,arg2]) = sep [pprFunArgType arg1 <+> text "->", ppr arg2]
730 pprTyApp (EqualityT, [arg1, arg2]) =
731 sep [pprFunArgType arg1 <+> text "~", ppr arg2]
732 pprTyApp (ListT, [arg]) = brackets (ppr arg)
733 pprTyApp (TupleT n, args)
734 | length args == n = parens (commaSep args)
735 pprTyApp (PromotedTupleT n, args)
736 | length args == n = quoteParens (commaSep args)
737 pprTyApp (fun, args) = pprParendType fun <+> sep (map pprParendType args)
738
739 pprFunArgType :: Type -> Doc -- Should really use a precedence argument
740 -- Everything except forall and (->) binds more tightly than (->)
741 pprFunArgType ty@(ForallT {}) = parens (ppr ty)
742 pprFunArgType ty@((ArrowT `AppT` _) `AppT` _) = parens (ppr ty)
743 pprFunArgType ty@(SigT _ _) = parens (ppr ty)
744 pprFunArgType ty = ppr ty
745
746 split :: Type -> (Type, [Type]) -- Split into function and args
747 split t = go t []
748 where go (AppT t1 t2) args = go t1 (t2:args)
749 go ty args = (ty, args)
750
751 pprTyLit :: TyLit -> Doc
752 pprTyLit (NumTyLit n) = integer n
753 pprTyLit (StrTyLit s) = text (show s)
754
755 instance Ppr TyLit where
756 ppr = pprTyLit
757
758 ------------------------------
759 instance Ppr TyVarBndr where
760 ppr (PlainTV nm) = ppr nm
761 ppr (KindedTV nm k) = parens (ppr nm <+> dcolon <+> ppr k)
762
763 instance Ppr Role where
764 ppr NominalR = text "nominal"
765 ppr RepresentationalR = text "representational"
766 ppr PhantomR = text "phantom"
767 ppr InferR = text "_"
768
769 ------------------------------
770 pprCxt :: Cxt -> Doc
771 pprCxt [] = empty
772 pprCxt ts = ppr_cxt_preds ts <+> text "=>"
773
774 ppr_cxt_preds :: Cxt -> Doc
775 ppr_cxt_preds [] = empty
776 ppr_cxt_preds [t] = ppr t
777 ppr_cxt_preds ts = parens (commaSep ts)
778
779 ------------------------------
780 instance Ppr Range where
781 ppr = brackets . pprRange
782 where pprRange :: Range -> Doc
783 pprRange (FromR e) = ppr e <> text ".."
784 pprRange (FromThenR e1 e2) = ppr e1 <> text ","
785 <> ppr e2 <> text ".."
786 pprRange (FromToR e1 e2) = ppr e1 <> text ".." <> ppr e2
787 pprRange (FromThenToR e1 e2 e3) = ppr e1 <> text ","
788 <> ppr e2 <> text ".."
789 <> ppr e3
790
791 ------------------------------
792 where_clause :: [Dec] -> Doc
793 where_clause [] = empty
794 where_clause ds = nest nestDepth $ text "where" <+> vcat (map (ppr_dec False) ds)
795
796 showtextl :: Show a => a -> Doc
797 showtextl = text . map toLower . show
798
799 hashParens :: Doc -> Doc
800 hashParens d = text "(# " <> d <> text " #)"
801
802 quoteParens :: Doc -> Doc
803 quoteParens d = text "'(" <> d <> text ")"
804
805 -----------------------------
806 instance Ppr Loc where
807 ppr (Loc { loc_module = md
808 , loc_package = pkg
809 , loc_start = (start_ln, start_col)
810 , loc_end = (end_ln, end_col) })
811 = hcat [ text pkg, colon, text md, colon
812 , parens $ int start_ln <> comma <> int start_col
813 , text "-"
814 , parens $ int end_ln <> comma <> int end_col ]
815
816 -- Takes a list of printable things and prints them separated by commas followed
817 -- by space.
818 commaSep :: Ppr a => [a] -> Doc
819 commaSep = commaSepWith ppr
820
821 -- Takes a list of things and prints them with the given pretty-printing
822 -- function, separated by commas followed by space.
823 commaSepWith :: (a -> Doc) -> [a] -> Doc
824 commaSepWith pprFun = sep . punctuate comma . map pprFun
825
826 -- Takes a list of printable things and prints them separated by semicolons
827 -- followed by space.
828 semiSep :: Ppr a => [a] -> Doc
829 semiSep = sep . punctuate semi . map ppr
830
831 -- Prints out the series of vertical bars that wraps an expression or pattern
832 -- used in an unboxed sum.
833 unboxedSumBars :: Doc -> SumAlt -> SumArity -> Doc
834 unboxedSumBars d alt arity = hashParens $
835 bars (alt-1) <> d <> bars (arity - alt)
836 where
837 bars i = hsep (replicate i bar)
838
839 -- Text containing the vertical bar character.
840 bar :: Doc
841 bar = char '|'