Ppr.hs 30.6 KB
Newer Older
aavogt's avatar
aavogt committed
1
-- | contains a prettyprinter for the
2
3
4
5
6
7
8
-- Template Haskell datatypes

module Language.Haskell.TH.Ppr where
    -- All of the exports from this module should
    -- be "public" functions.  The main module TH
    -- re-exports them all.

dterei's avatar
dterei committed
9
import Text.PrettyPrint (render)
10
11
import Language.Haskell.TH.PprLib
import Language.Haskell.TH.Syntax
reinerp's avatar
reinerp committed
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
18
19
20
21

nestDepth :: Int
nestDepth = 4

type Precedence = Int
22
appPrec, unopPrec, opPrec, noPrec :: Precedence
23
24
25
26
appPrec  = 3    -- Argument of a function application
opPrec   = 2    -- Argument of an infix operator
unopPrec = 1    -- Argument of an unresolved infix operator
noPrec   = 0    -- Others
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46

parensIf :: Bool -> Doc -> Doc
parensIf True d = parens d
parensIf False d = d

------------------------------

pprint :: Ppr a => a -> String
pprint x = render $ to_HPJ_Doc $ ppr x

class Ppr a where
    ppr :: a -> Doc
    ppr_list :: [a] -> Doc
    ppr_list = vcat . map ppr

instance Ppr a => Ppr [a] where
    ppr x = ppr_list x

------------------------------
instance Ppr Name where
Ian Lynagh's avatar
Ian Lynagh committed
47
    ppr v = pprName v
48
49
50

------------------------------
instance Ppr Info where
51
52
53
    ppr (TyConI d)     = ppr d
    ppr (ClassI d is)  = ppr d $$ vcat (map ppr is)
    ppr (FamilyI d is) = ppr d $$ vcat (map ppr is)
54
    ppr (PrimTyConI name arity is_unlifted)
55
      = text "Primitive"
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
56
57
58
        <+> (if is_unlifted then text "unlifted" else empty)
        <+> text "type constructor" <+> quotes (ppr name)
        <+> parens (text "arity" <+> int arity)
Ryan Scott's avatar
Ryan Scott committed
59
60
61
62
    ppr (ClassOpI v ty cls)
      = text "Class op from" <+> ppr cls <> colon <+> ppr_sig v ty
    ppr (DataConI v ty tc)
      = text "Constructor from" <+> ppr tc <> colon <+> ppr_sig v ty
63
    ppr (PatSynI nm ty) = pprPatSynSig nm ty
64
65
    ppr (TyVarI v ty)
      = text "Type variable" <+> ppr v <+> equals <+> ppr ty
Ryan Scott's avatar
Ryan Scott committed
66
67
    ppr (VarI v ty mb_d)
      = vcat [ppr_sig v ty,
68
69
              case mb_d of { Nothing -> empty; Just d -> ppr d }]

Ian Lynagh's avatar
Ian Lynagh committed
70
ppr_sig :: Name -> Type -> Doc
71
ppr_sig v ty = pprName' Applied v <+> dcolon <+> ppr ty
72
73

pprFixity :: Name -> Fixity -> Doc
Ian Lynagh's avatar
Ian Lynagh committed
74
pprFixity _ f | f == defaultFixity = empty
75
76
77
78
79
pprFixity v (Fixity i d) = ppr_fix d <+> int i <+> ppr v
    where ppr_fix InfixR = text "infixr"
          ppr_fix InfixL = text "infixl"
          ppr_fix InfixN = text "infix"

80
81
82
83
84
85
86
87
-- | Pretty prints a pattern synonym type signature
pprPatSynSig :: Name -> PatSynType -> Doc
pprPatSynSig nm ty
  = text "pattern" <+> pprPrefixOcc nm <+> dcolon <+> pprPatSynType ty

-- | Pretty prints a pattern synonym's type; follows the usual
-- conventions to print a pattern synonym type compactly, yet
-- unambiguously. See the note on 'PatSynType' and the section on
Gabor Greif's avatar
Gabor Greif committed
88
-- pattern synonyms in the GHC user's guide for more information.
89
90
91
92
93
94
95
96
97
pprPatSynType :: PatSynType -> Doc
pprPatSynType ty@(ForallT uniTys reqs ty'@(ForallT exTys provs ty''))
  | null exTys,  null provs = ppr (ForallT uniTys reqs ty'')
  | null uniTys, null reqs  = noreqs <+> ppr ty'
  | null reqs               = forall uniTys <+> noreqs <+> ppr ty'
  | otherwise               = ppr ty
  where noreqs     = text "() =>"
        forall tvs = text "forall" <+> (hsep (map ppr tvs)) <+> text "."
pprPatSynType ty            = ppr ty
98

99
100
101
102
103
104
105
------------------------------
instance Ppr Module where
  ppr (Module pkg m) = text (pkgString pkg) <+> text (modString m)

instance Ppr ModuleInfo where
  ppr (ModuleInfo imps) = text "Module" <+> vcat (map ppr imps)

106
107
108
109
------------------------------
instance Ppr Exp where
    ppr = pprExp noPrec

110
111
112
113
114
115
pprPrefixOcc :: Name -> Doc
-- Print operators with parens around them
pprPrefixOcc n = parensIf (isSymOcc n) (ppr n)

isSymOcc :: Name -> Bool
isSymOcc n
116
  = case nameBase n of
117
      []    -> True  -- Empty name; weird
118
      (c:_) -> startsVarSym c
119
120
                   -- c.f. OccName.startsVarSym in GHC itself

121
pprInfixExp :: Exp -> Doc
Ian Lynagh's avatar
Ian Lynagh committed
122
123
pprInfixExp (VarE v) = pprName' Infix v
pprInfixExp (ConE v) = pprName' Infix v
124
pprInfixExp _        = text "<<Non-variable/constructor in infix context>>"
125

126
pprExp :: Precedence -> Exp -> Doc
Ian Lynagh's avatar
Ian Lynagh committed
127
128
pprExp _ (VarE v)     = pprName' Applied v
pprExp _ (ConE c)     = pprName' Applied c
129
130
131
pprExp i (LitE l)     = pprLit i l
pprExp i (AppE e1 e2) = parensIf (i >= appPrec) $ pprExp opPrec e1
                                              <+> pprExp appPrec e2
132
133
pprExp i (AppTypeE e t)
 = parensIf (i >= appPrec) $ pprExp opPrec e <+> char '@' <> pprParendType t
134
135
136
137
138
pprExp _ (ParensE e)  = parens (pprExp noPrec e)
pprExp i (UInfixE e1 op e2)
 = parensIf (i > unopPrec) $ pprExp unopPrec e1
                         <+> pprInfixExp op
                         <+> pprExp unopPrec e2
139
140
pprExp i (InfixE (Just e1) op (Just e2))
 = parensIf (i >= opPrec) $ pprExp opPrec e1
141
                        <+> pprInfixExp op
142
143
                        <+> pprExp opPrec e2
pprExp _ (InfixE me1 op me2) = parens $ pprMaybeExp noPrec me1
144
                                    <+> pprInfixExp op
145
                                    <+> pprMaybeExp noPrec me2
146
pprExp i (LamE [] e) = pprExp i e -- #13856
147
pprExp i (LamE ps e) = parensIf (i > noPrec) $ char '\\' <> hsep (map (pprPat appPrec) ps)
148
                                           <+> text "->" <+> ppr e
149
150
pprExp i (LamCaseE ms) = parensIf (i > noPrec)
                       $ text "\\case" $$ nest nestDepth (ppr ms)
151
152
pprExp _ (TupE es) = parens (commaSep es)
pprExp _ (UnboxedTupE es) = hashParens (commaSep es)
153
pprExp _ (UnboxedSumE e alt arity) = unboxedSumBars (ppr e) alt arity
Gabor Greif's avatar
Gabor Greif committed
154
-- Nesting in Cond is to avoid potential problems in do statements
155
156
157
158
pprExp i (CondE guard true false)
 = parensIf (i > noPrec) $ sep [text "if"   <+> ppr guard,
                       nest 1 $ text "then" <+> ppr true,
                       nest 1 $ text "else" <+> ppr false]
159
160
161
162
163
164
pprExp i (MultiIfE alts)
  = parensIf (i > noPrec) $ vcat $
      case alts of
        []            -> [text "if {}"]
        (alt : alts') -> text "if" <+> pprGuarded arrow alt
                         : map (nest 3 . pprGuarded arrow) alts'
165
166
167
168
169
pprExp i (LetE ds_ e) = parensIf (i > noPrec) $ text "let" <+> pprDecs ds_
                                             $$ text " in" <+> ppr e
  where
    pprDecs []  = empty
    pprDecs [d] = ppr d
170
    pprDecs ds  = braces (semiSep ds)
171

172
173
174
pprExp i (CaseE e ms)
 = parensIf (i > noPrec) $ text "case" <+> ppr e <+> text "of"
                        $$ nest nestDepth (ppr ms)
175
176
177
178
pprExp i (DoE ss_) = parensIf (i > noPrec) $ text "do" <+> pprStms ss_
  where
    pprStms []  = empty
    pprStms [s] = ppr s
179
    pprStms ss  = braces (semiSep ss)
180

181
pprExp _ (CompE []) = text "<<Empty CompExp>>"
182
-- This will probably break with fixity declarations - would need a ';'
183
184
185
186
187
188
189
190
191
192
193
pprExp _ (CompE ss) =
    if null ss'
       -- If there are no statements in a list comprehension besides the last
       -- one, we simply treat it like a normal list.
       then text "[" <> ppr s <> text "]"
       else text "[" <> ppr s
        <+> bar
        <+> commaSep ss'
         <> text "]"
  where s = last ss
        ss' = init ss
194
pprExp _ (ArithSeqE d) = ppr d
195
pprExp _ (ListE es) = brackets (commaSep es)
Jan Stolarek's avatar
Jan Stolarek committed
196
pprExp i (SigE e t) = parensIf (i > noPrec) $ ppr e <+> dcolon <+> ppr t
197
198
pprExp _ (RecConE nm fs) = ppr nm <> braces (pprFields fs)
pprExp _ (RecUpdE e fs) = pprExp appPrec e <> braces (pprFields fs)
Facundo Domínguez's avatar
Facundo Domínguez committed
199
200
pprExp i (StaticE e) = parensIf (i >= appPrec) $
                         text "static"<+> pprExp appPrec e
201
pprExp _ (UnboundVarE v) = pprName' Applied v
202
203
204
205
206
207
208
209
210
211
212

pprFields :: [(Name,Exp)] -> Doc
pprFields = sep . punctuate comma . map (\(s,e) -> ppr s <+> equals <+> ppr e)

pprMaybeExp :: Precedence -> Maybe Exp -> Doc
pprMaybeExp _ Nothing = empty
pprMaybeExp i (Just e) = pprExp i e

------------------------------
instance Ppr Stmt where
    ppr (BindS p e) = ppr p <+> text "<-" <+> ppr e
213
    ppr (LetS ds) = text "let" <+> (braces (semiSep ds))
214
    ppr (NoBindS e) = ppr e
215
    ppr (ParS sss) = sep $ punctuate bar
216
                         $ map commaSep sss
217
218
219
220
221
222

------------------------------
instance Ppr Match where
    ppr (Match p rhs ds) = ppr p <+> pprBody False rhs
                        $$ where_clause ds

223
224
225
------------------------------
pprGuarded :: Doc -> (Guard, Exp) -> Doc
pprGuarded eqDoc (guard, expr) = case guard of
226
227
  NormalG guardExpr -> bar <+> ppr guardExpr <+> eqDoc <+> ppr expr
  PatG    stmts     -> bar <+> vcat (punctuate comma $ map ppr stmts) $$
228
229
                         nest nestDepth (eqDoc <+> ppr expr)

230
231
------------------------------
pprBody :: Bool -> Body -> Doc
232
233
234
235
236
pprBody eq body = case body of
    GuardedB xs -> nest nestDepth $ vcat $ map (pprGuarded eqDoc) xs
    NormalB  e  -> eqDoc <+> ppr e
  where eqDoc | eq        = equals
              | otherwise = arrow
237
238

------------------------------
239
240
241
instance Ppr Lit where
  ppr = pprLit noPrec

242
243
244
pprLit :: Precedence -> Lit -> Doc
pprLit i (IntPrimL x)    = parensIf (i > noPrec && x < 0)
                                    (integer x <> char '#')
Ian Lynagh's avatar
Ian Lynagh committed
245
pprLit _ (WordPrimL x)    = integer x <> text "##"
246
247
248
249
250
251
pprLit i (FloatPrimL x)  = parensIf (i > noPrec && x < 0)
                                    (float (fromRational x) <> char '#')
pprLit i (DoublePrimL x) = parensIf (i > noPrec && x < 0)
                                    (double (fromRational x) <> text "##")
pprLit i (IntegerL x)    = parensIf (i > noPrec && x < 0) (integer x)
pprLit _ (CharL c)       = text (show c)
252
pprLit _ (CharPrimL c)   = text (show c) <> char '#'
253
pprLit _ (StringL s)     = pprString s
reinerp's avatar
reinerp committed
254
pprLit _ (StringPrimL s) = pprString (bytesToString s) <> char '#'
255
pprLit i (RationalL rat) = parensIf (i > noPrec) $
256
                           integer (numerator rat) <+> char '/'
257
                              <+> integer (denominator rat)
258

reinerp's avatar
reinerp committed
259
260
261
bytesToString :: [Word8] -> String
bytesToString = map (chr . fromIntegral)

262
pprString :: String -> Doc
263
-- Print newlines as newlines with Haskell string escape notation,
264
265
266
-- not as '\n'.  For other non-printables use regular escape notation.
pprString s = vcat (map text (showMultiLineString s))

267
268
269
270
271
272
------------------------------
instance Ppr Pat where
    ppr = pprPat noPrec

pprPat :: Precedence -> Pat -> Doc
pprPat i (LitP l)     = pprLit i l
Ian Lynagh's avatar
Ian Lynagh committed
273
pprPat _ (VarP v)     = pprName' Applied v
274
275
pprPat _ (TupP ps)    = parens (commaSep ps)
pprPat _ (UnboxedTupP ps) = hashParens (commaSep ps)
276
pprPat _ (UnboxedSumP p alt arity) = unboxedSumBars (ppr p) alt arity
277
278
pprPat i (ConP s ps)  = parensIf (i >= appPrec) $ pprName' Applied s
                                              <+> sep (map (pprPat appPrec) ps)
279
280
281
282
283
pprPat _ (ParensP p)  = parens $ pprPat noPrec p
pprPat i (UInfixP p1 n p2)
                      = parensIf (i > unopPrec) (pprPat unopPrec p1 <+>
                                                 pprName' Infix n   <+>
                                                 pprPat unopPrec p2)
284
pprPat i (InfixP p1 n p2)
285
286
287
                      = parensIf (i >= opPrec) (pprPat opPrec p1 <+>
                                                pprName' Infix n <+>
                                                pprPat opPrec p2)
Stefan O'Rear's avatar
Stefan O'Rear committed
288
pprPat i (TildeP p)   = parensIf (i > noPrec) $ char '~' <> pprPat appPrec p
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
289
pprPat i (BangP p)    = parensIf (i > noPrec) $ char '!' <> pprPat appPrec p
290
291
292
293
294
295
296
pprPat i (AsP v p)    = parensIf (i > noPrec) $ ppr v <> text "@"
                                                      <> pprPat appPrec p
pprPat _ WildP        = text "_"
pprPat _ (RecP nm fs)
 = parens $     ppr nm
            <+> braces (sep $ punctuate comma $
                        map (\(s,p) -> ppr s <+> equals <+> ppr p) fs)
297
pprPat _ (ListP ps) = brackets (commaSep ps)
Jan Stolarek's avatar
Jan Stolarek committed
298
pprPat i (SigP p t) = parensIf (i > noPrec) $ ppr p <+> dcolon <+> ppr t
reinerp's avatar
reinerp committed
299
pprPat _ (ViewP e p) = parens $ pprExp noPrec e <+> text "->" <+> pprPat noPrec p
300
301
302

------------------------------
instance Ppr Dec where
303
304
305
    ppr = ppr_dec True

ppr_dec :: Bool     -- declaration on the toplevel?
306
        -> Dec
307
        -> Doc
308
ppr_dec _ (FunD f cs)   = vcat $ map (\c -> pprPrefixOcc f <+> ppr c) cs
309
310
ppr_dec _ (ValD p r ds) = ppr p <+> pprBody True r
                          $$ where_clause ds
311
ppr_dec _ (TySynD t xs rhs)
312
  = ppr_tySyn empty t (hsep (map ppr xs)) rhs
313
314
315
316
ppr_dec _ (DataD ctxt t xs ksig cs decs)
  = ppr_data empty ctxt t (hsep (map ppr xs)) ksig cs decs
ppr_dec _ (NewtypeD ctxt t xs ksig c decs)
  = ppr_newtype empty ctxt t (sep (map ppr xs)) ksig c decs
317
ppr_dec _  (ClassD ctxt c xs fds ds)
318
319
  = text "class" <+> pprCxt ctxt <+> ppr c <+> hsep (map ppr xs) <+> ppr fds
    $$ where_clause ds
320
321
ppr_dec _ (InstanceD o ctxt i ds) =
        text "instance" <+> maybe empty ppr_overlap o <+> pprCxt ctxt <+> ppr i
322
                                  $$ where_clause ds
Jan Stolarek's avatar
Jan Stolarek committed
323
ppr_dec _ (SigD f t)    = pprPrefixOcc f <+> dcolon <+> ppr t
324
325
326
ppr_dec _ (ForeignD f)  = ppr f
ppr_dec _ (InfixD fx n) = pprFixity n fx
ppr_dec _ (PragmaD p)   = ppr p
Jan Stolarek's avatar
Jan Stolarek committed
327
328
ppr_dec isTop (DataFamilyD tc tvs kind)
  = text "data" <+> maybeFamily <+> ppr tc <+> hsep (map ppr tvs) <+> maybeKind
329
330
331
  where
    maybeFamily | isTop     = text "family"
                | otherwise = empty
Jan Stolarek's avatar
Jan Stolarek committed
332
333
    maybeKind | (Just k') <- kind = dcolon <+> ppr k'
              | otherwise = empty
334
335
ppr_dec isTop (DataInstD ctxt tc tys ksig cs decs)
  = ppr_data maybeInst ctxt tc (sep (map pprParendType tys)) ksig cs decs
336
337
338
  where
    maybeInst | isTop     = text "instance"
              | otherwise = empty
339
340
ppr_dec isTop (NewtypeInstD ctxt tc tys ksig c decs)
  = ppr_newtype maybeInst ctxt tc (sep (map pprParendType tys)) ksig c decs
341
342
343
  where
    maybeInst | isTop     = text "instance"
              | otherwise = empty
344
ppr_dec isTop (TySynInstD tc (TySynEqn tys rhs))
345
346
347
348
  = ppr_tySyn maybeInst tc (sep (map pprParendType tys)) rhs
  where
    maybeInst | isTop     = text "instance"
              | otherwise = empty
349
350
ppr_dec isTop (OpenTypeFamilyD tfhead)
  = text "type" <+> maybeFamily <+> ppr_tf_head tfhead
Jan Stolarek's avatar
Jan Stolarek committed
351
352
353
  where
    maybeFamily | isTop     = text "family"
                | otherwise = empty
354
355
ppr_dec _ (ClosedTypeFamilyD tfhead@(TypeFamilyHead tc _ _ _) eqns)
  = hang (text "type family" <+> ppr_tf_head tfhead <+> text "where")
356
357
      nestDepth (vcat (map ppr_eqn eqns))
  where
358
359
    ppr_eqn (TySynEqn lhs rhs)
      = ppr tc <+> sep (map pprParendType lhs) <+> text "=" <+> ppr rhs
360
361
ppr_dec _ (RoleAnnotD name roles)
  = hsep [ text "type role", ppr name ] <+> hsep (map ppr roles)
Ryan Scott's avatar
Ryan Scott committed
362
363
364
365
366
367
ppr_dec _ (StandaloneDerivD ds cxt ty)
  = hsep [ text "deriving"
         , maybe empty ppr_deriv_strategy ds
         , text "instance"
         , pprCxt cxt
         , ppr ty ]
368
ppr_dec _ (DefaultSigD n ty)
Jan Stolarek's avatar
Jan Stolarek committed
369
  = hsep [ text "default", pprPrefixOcc n, dcolon, ppr ty ]
370
371
372
373
374
375
376
377
378
379
ppr_dec _ (PatSynD name args dir pat)
  = text "pattern" <+> pprNameArgs <+> ppr dir <+> pprPatRHS
  where
    pprNameArgs | InfixPatSyn a1 a2 <- args = ppr a1 <+> ppr name <+> ppr a2
                | otherwise                 = ppr name <+> ppr args
    pprPatRHS   | ExplBidir cls <- dir = hang (ppr pat <+> text "where")
                                           nestDepth (ppr name <+> ppr cls)
                | otherwise            = ppr pat
ppr_dec _ (PatSynSigD name ty)
  = pprPatSynSig name ty
380

Ryan Scott's avatar
Ryan Scott committed
381
382
383
ppr_deriv_strategy :: DerivStrategy -> Doc
ppr_deriv_strategy ds = text $
  case ds of
384
385
386
    StockStrategy    -> "stock"
    AnyclassStrategy -> "anyclass"
    NewtypeStrategy  -> "newtype"
387
388
389
390
391
392
393
394
395

ppr_overlap :: Overlap -> Doc
ppr_overlap o = text $
  case o of
    Overlaps      -> "{-# OVERLAPS #-}"
    Overlappable  -> "{-# OVERLAPPABLE #-}"
    Overlapping   -> "{-# OVERLAPPING #-}"
    Incoherent    -> "{-# INCOHERENT #-}"

Ryan Scott's avatar
Ryan Scott committed
396
397
ppr_data :: Doc -> Cxt -> Name -> Doc -> Maybe Kind -> [Con] -> [DerivClause]
         -> Doc
398
ppr_data maybeInst ctxt t argsDoc ksig cs decs
399
  = sep [text "data" <+> maybeInst
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
400
            <+> pprCxt ctxt
401
            <+> ppr t <+> argsDoc <+> ksigDoc <+> maybeWhere,
402
403
404
405
         nest nestDepth (sep (pref $ map ppr cs)),
         if null decs
           then empty
           else nest nestDepth
Ryan Scott's avatar
Ryan Scott committed
406
              $ vcat $ map ppr_deriv_clause decs]
407
  where
408
    pref :: [Doc] -> [Doc]
409
410
    pref xs | isGadtDecl = xs
    pref []              = []      -- No constructors; can't happen in H98
411
    pref (d:ds)          = (char '=' <+> d):map (bar <+>) ds
412
413
414
415
416
417
418

    maybeWhere :: Doc
    maybeWhere | isGadtDecl = text "where"
               | otherwise  = empty

    isGadtDecl :: Bool
    isGadtDecl = not (null cs) && all isGadtCon cs
419
420
421
422
        where isGadtCon (GadtC _ _ _   ) = True
              isGadtCon (RecGadtC _ _ _) = True
              isGadtCon (ForallC _ _ x ) = isGadtCon x
              isGadtCon  _               = False
423
424
425
426
427

    ksigDoc = case ksig of
                Nothing -> empty
                Just k  -> dcolon <+> ppr k

Ryan Scott's avatar
Ryan Scott committed
428
429
ppr_newtype :: Doc -> Cxt -> Name -> Doc -> Maybe Kind -> Con -> [DerivClause]
            -> Doc
430
ppr_newtype maybeInst ctxt t argsDoc ksig c decs
431
  = sep [text "newtype" <+> maybeInst
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
432
            <+> pprCxt ctxt
433
            <+> ppr t <+> argsDoc <+> ksigDoc,
434
435
         nest 2 (char '=' <+> ppr c),
         if null decs
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
436
437
           then empty
           else nest nestDepth
Ryan Scott's avatar
Ryan Scott committed
438
                $ vcat $ map ppr_deriv_clause decs]
439
440
441
442
  where
    ksigDoc = case ksig of
                Nothing -> empty
                Just k  -> dcolon <+> ppr k
443

Ryan Scott's avatar
Ryan Scott committed
444
445
446
447
448
ppr_deriv_clause :: DerivClause -> Doc
ppr_deriv_clause (DerivClause ds ctxt)
  = text "deriving" <+> maybe empty ppr_deriv_strategy ds
                    <+> ppr_cxt_preds ctxt

449
450
451
ppr_tySyn :: Doc -> Name -> Doc -> Type -> Doc
ppr_tySyn maybeInst t argsDoc rhs
  = text "type" <+> maybeInst <+> ppr t <+> argsDoc <+> text "=" <+> ppr rhs
452

453
454
455
456
457
458
459
ppr_tf_head :: TypeFamilyHead -> Doc
ppr_tf_head (TypeFamilyHead tc tvs res inj)
  = ppr tc <+> hsep (map ppr tvs) <+> ppr res <+> maybeInj
  where
    maybeInj | (Just inj') <- inj = ppr inj'
             | otherwise          = empty

460
461
462
------------------------------
instance Ppr FunDep where
    ppr (FunDep xs ys) = hsep (map ppr xs) <+> text "->" <+> hsep (map ppr ys)
463
    ppr_list [] = empty
464
    ppr_list xs = bar <+> commaSep xs
465

466
467
468
469
470
------------------------------
instance Ppr FamFlavour where
    ppr DataFam = text "data"
    ppr TypeFam = text "type"

Jan Stolarek's avatar
Jan Stolarek committed
471
472
473
474
475
476
477
478
479
------------------------------
instance Ppr FamilyResultSig where
    ppr NoSig           = empty
    ppr (KindSig k)     = dcolon <+> ppr k
    ppr (TyVarSig bndr) = text "=" <+> ppr bndr

------------------------------
instance Ppr InjectivityAnn where
    ppr (InjectivityAnn lhs rhs) =
480
        bar <+> ppr lhs <+> text "->" <+> hsep (map ppr rhs)
Jan Stolarek's avatar
Jan Stolarek committed
481

482
483
484
485
486
487
488
489
------------------------------
instance Ppr Foreign where
    ppr (ImportF callconv safety impent as typ)
       = text "foreign import"
     <+> showtextl callconv
     <+> showtextl safety
     <+> text (show impent)
     <+> ppr as
Jan Stolarek's avatar
Jan Stolarek committed
490
     <+> dcolon <+> ppr typ
491
492
493
494
495
    ppr (ExportF callconv expent as typ)
        = text "foreign export"
      <+> showtextl callconv
      <+> text (show expent)
      <+> ppr as
Jan Stolarek's avatar
Jan Stolarek committed
496
      <+> dcolon <+> ppr typ
497

498
499
------------------------------
instance Ppr Pragma where
500
    ppr (InlineP n inline rm phases)
501
       = text "{-#"
502
     <+> ppr inline
503
504
     <+> ppr rm
     <+> ppr phases
505
506
     <+> ppr n
     <+> text "#-}"
507
508
509
510
    ppr (SpecialiseP n ty inline phases)
       =   text "{-# SPECIALISE"
       <+> maybe empty ppr inline
       <+> ppr phases
Jan Stolarek's avatar
Jan Stolarek committed
511
       <+> sep [ ppr n <+> dcolon
512
513
514
515
516
517
518
519
520
521
522
523
               , nest 2 $ ppr ty ]
       <+> text "#-}"
    ppr (SpecialiseInstP inst)
       = text "{-# SPECIALISE instance" <+> ppr inst <+> text "#-}"
    ppr (RuleP n bndrs lhs rhs phases)
       = sep [ text "{-# RULES" <+> pprString n <+> ppr phases
             , nest 4 $ ppr_forall <+> ppr lhs
             , nest 4 $ char '=' <+> ppr rhs <+> text "#-}" ]
      where ppr_forall | null bndrs =   empty
                       | otherwise  =   text "forall"
                                    <+> fsep (map ppr bndrs)
                                    <+> char '.'
524
525
526
527
528
    ppr (AnnP tgt expr)
       = text "{-# ANN" <+> target1 tgt <+> ppr expr <+> text "#-}"
      where target1 ModuleAnnotation    = text "module"
            target1 (TypeAnnotation t)  = text "type" <+> ppr t
            target1 (ValueAnnotation v) = ppr v
529
530
    ppr (LineP line file)
       = text "{-# LINE" <+> int line <+> text (show file) <+> text "#-}"
531
532
533
    ppr (CompleteP cls mty)
       = text "{-# COMPLETE" <+> (fsep $ punctuate comma $ map ppr cls)
                <+> maybe empty (\ty -> dcolon <+> ppr ty) mty
534

535
536
537
538
539
540
------------------------------
instance Ppr Inline where
    ppr NoInline  = text "NOINLINE"
    ppr Inline    = text "INLINE"
    ppr Inlinable = text "INLINABLE"

541
542
543
544
545
546
547
548
549
550
551
552
553
554
------------------------------
instance Ppr RuleMatch where
    ppr ConLike = text "CONLIKE"
    ppr FunLike = empty

------------------------------
instance Ppr Phases where
    ppr AllPhases       = empty
    ppr (FromPhase i)   = brackets $ int i
    ppr (BeforePhase i) = brackets $ char '~' <> int i

------------------------------
instance Ppr RuleBndr where
    ppr (RuleVar n)         = ppr n
Jan Stolarek's avatar
Jan Stolarek committed
555
    ppr (TypedRuleVar n ty) = parens $ ppr n <+> dcolon <+> ppr ty
556

557
558
------------------------------
instance Ppr Clause where
559
560
    ppr (Clause ps rhs ds) = hsep (map (pprPat appPrec) ps) <+> pprBody True rhs
                             $$ where_clause ds
561
562
563

------------------------------
instance Ppr Con where
564
    ppr (NormalC c sts) = ppr c <+> sep (map pprBangType sts)
565

566
    ppr (RecC c vsts)
567
        = ppr c <+> braces (sep (punctuate comma $ map pprVarBangType vsts))
568

569
    ppr (InfixC st1 c st2) = pprBangType st1
Ian Lynagh's avatar
Ian Lynagh committed
570
                         <+> pprName' Infix c
571
                         <+> pprBangType st2
572

573
    ppr (ForallC ns ctxt (GadtC c sts ty))
574
575
        = commaSepApplied c <+> dcolon <+> pprForall ns ctxt
      <+> pprGadtRHS sts ty
576

577
    ppr (ForallC ns ctxt (RecGadtC c vsts ty))
578
        = commaSepApplied c <+> dcolon <+> pprForall ns ctxt
579
      <+> pprRecFields vsts ty
580
581
582
583

    ppr (ForallC ns ctxt con)
        = pprForall ns ctxt <+> ppr con

584
    ppr (GadtC c sts ty)
585
        = commaSepApplied c <+> dcolon <+> pprGadtRHS sts ty
586

587
    ppr (RecGadtC c vsts ty)
588
589
        = commaSepApplied c <+> dcolon <+> pprRecFields vsts ty

590
591
592
593
594
595
596
597
598
599
600
601
instance Ppr PatSynDir where
  ppr Unidir        = text "<-"
  ppr ImplBidir     = text "="
  ppr (ExplBidir _) = text "<-"
    -- the ExplBidir's clauses are pretty printed together with the
    -- entire pattern synonym; so only print the direction here.

instance Ppr PatSynArgs where
  ppr (PrefixPatSyn args) = sep $ map ppr args
  ppr (InfixPatSyn a1 a2) = ppr a1 <+> ppr a2
  ppr (RecordPatSyn sels) = braces $ sep (punctuate comma (map ppr sels))

602
603
commaSepApplied :: [Name] -> Doc
commaSepApplied = commaSepWith (pprName' Applied)
604
605

pprForall :: [TyVarBndr] -> Cxt -> Doc
606
607
608
609
610
611
pprForall tvs cxt
  -- even in the case without any tvs, there could be a non-empty
  -- context cxt (e.g., in the case of pattern synonyms, where there
  -- are multiple forall binders and contexts).
  | [] <- tvs = pprCxt cxt
  | otherwise = text "forall" <+> hsep (map ppr tvs) <+> char '.' <+> pprCxt cxt
612

613
614
pprRecFields :: [(Name, Strict, Type)] -> Type -> Doc
pprRecFields vsts ty
615
    = braces (sep (punctuate comma $ map pprVarBangType vsts))
616
  <+> arrow <+> ppr ty
617

618
619
620
621
pprGadtRHS :: [(Strict, Type)] -> Type -> Doc
pprGadtRHS [] ty
    = ppr ty
pprGadtRHS sts ty
622
    = sep (punctuate (space <> arrow) (map pprBangType sts))
623
  <+> arrow <+> ppr ty
624
625

------------------------------
626
pprVarBangType :: VarBangType -> Doc
627
-- Slight infelicity: with print non-atomic type with parens
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
pprVarBangType (v, bang, t) = ppr v <+> dcolon <+> pprBangType (bang, t)

------------------------------
pprBangType :: BangType -> Doc
-- Make sure we print
--
-- Con {-# UNPACK #-} a
--
-- rather than
--
-- Con {-# UNPACK #-}a
--
-- when there's no strictness annotation. If there is a strictness annotation,
-- it's okay to not put a space between it and the type.
pprBangType (bt@(Bang _ NoSourceStrictness), t) = ppr bt <+> pprParendType t
pprBangType (bt, t) = ppr bt <> pprParendType t

------------------------------
instance Ppr Bang where
    ppr (Bang su ss) = ppr su <+> ppr ss

------------------------------
instance Ppr SourceUnpackedness where
    ppr NoSourceUnpackedness = empty
    ppr SourceNoUnpack       = text "{-# NOUNPACK #-}"
    ppr SourceUnpack         = text "{-# UNPACK #-}"

------------------------------
instance Ppr SourceStrictness where
    ppr NoSourceStrictness = empty
    ppr SourceLazy         = char '~'
    ppr SourceStrict       = char '!'

------------------------------
instance Ppr DecidedStrictness where
    ppr DecidedLazy   = empty
    ppr DecidedStrict = char '!'
    ppr DecidedUnpack = text "{-# UNPACK #-} !"

------------------------------
{-# DEPRECATED pprVarStrictType
               "As of @template-haskell-2.11.0.0@, 'VarStrictType' has been replaced by 'VarBangType'. Please use 'pprVarBangType' instead." #-}
pprVarStrictType :: (Name, Strict, Type) -> Doc
pprVarStrictType = pprVarBangType
672
673

------------------------------
674
675
{-# DEPRECATED pprStrictType
               "As of @template-haskell-2.11.0.0@, 'StrictType' has been replaced by 'BangType'. Please use 'pprBangType' instead." #-}
676
pprStrictType :: (Strict, Type) -> Doc
677
pprStrictType = pprBangType
678
679
680

------------------------------
pprParendType :: Type -> Doc
681
682
683
684
685
pprParendType (VarT v)            = ppr v
pprParendType (ConT c)            = ppr c
pprParendType (TupleT 0)          = text "()"
pprParendType (TupleT n)          = parens (hcat (replicate (n-1) comma))
pprParendType (UnboxedTupleT n)   = hashParens $ hcat $ replicate (n-1) comma
686
pprParendType (UnboxedSumT arity) = hashParens $ hcat $ replicate (arity-1) bar
687
688
689
690
691
692
693
694
695
696
pprParendType ArrowT              = parens (text "->")
pprParendType ListT               = text "[]"
pprParendType (LitT l)            = pprTyLit l
pprParendType (PromotedT c)       = text "'" <> ppr c
pprParendType (PromotedTupleT 0)  = text "'()"
pprParendType (PromotedTupleT n)  = quoteParens (hcat (replicate (n-1) comma))
pprParendType PromotedNilT        = text "'[]"
pprParendType PromotedConsT       = text "(':)"
pprParendType StarT               = char '*'
pprParendType ConstraintT         = text "Constraint"
697
pprParendType (SigT ty k)         = parens (ppr ty <+> text "::" <+> ppr k)
698
pprParendType WildCardT           = char '_'
699
700
701
pprParendType (InfixT x n y)      = parens (ppr x <+> pprName' Infix n <+> ppr y)
pprParendType t@(UInfixT {})      = parens (pprUInfixT t)
pprParendType (ParensT t)         = ppr t
702
703
704
pprParendType tuple | (TupleT n, args) <- split tuple
                    , length args == n
                    = parens (commaSep args)
705
pprParendType other               = parens (ppr other)
706

707
708
709
710
pprUInfixT :: Type -> Doc
pprUInfixT (UInfixT x n y) = pprUInfixT x <+> pprName' Infix n <+> pprUInfixT y
pprUInfixT t               = ppr t

711
instance Ppr Type where
712
    ppr (ForallT tvars ctxt ty) = sep [pprForall tvars ctxt, ppr ty]
713
714
715
716
717
718
719
720
721
722
723
724
    ppr ty = pprTyApp (split ty)
       -- Works, in a degnerate way, for SigT, and puts parens round (ty :: kind)
       -- See Note [Pretty-printing kind signatures]

{- Note [Pretty-printing kind signatures]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
GHC's parser only recognises a kind signature in a type when there are
parens around it.  E.g. the parens are required here:
   f :: (Int :: *)
   type instance F Int = (Bool :: *)
So we always print a SigT with parens (see Trac #10050). -}

725
pprTyApp :: (Type, [Type]) -> Doc
726
pprTyApp (ArrowT, [arg1,arg2]) = sep [pprFunArgType arg1 <+> text "->", ppr arg2]
727
728
pprTyApp (EqualityT, [arg1, arg2]) =
    sep [pprFunArgType arg1 <+> text "~", ppr arg2]
729
730
pprTyApp (ListT, [arg]) = brackets (ppr arg)
pprTyApp (TupleT n, args)
731
 | length args == n = parens (commaSep args)
732
pprTyApp (PromotedTupleT n, args)
733
 | length args == n = quoteParens (commaSep args)
734
735
pprTyApp (fun, args) = pprParendType fun <+> sep (map pprParendType args)

eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
736
pprFunArgType :: Type -> Doc    -- Should really use a precedence argument
737
738
739
-- Everything except forall and (->) binds more tightly than (->)
pprFunArgType ty@(ForallT {})                 = parens (ppr ty)
pprFunArgType ty@((ArrowT `AppT` _) `AppT` _) = parens (ppr ty)
740
pprFunArgType ty@(SigT _ _)                   = parens (ppr ty)
741
742
pprFunArgType ty                              = ppr ty

743
744
745
746
747
split :: Type -> (Type, [Type])    -- Split into function and args
split t = go t []
    where go (AppT t1 t2) args = go t1 (t2:args)
          go ty           args = (ty, args)

Iavor S. Diatchki's avatar
Iavor S. Diatchki committed
748
pprTyLit :: TyLit -> Doc
749
750
pprTyLit (NumTyLit n) = integer n
pprTyLit (StrTyLit s) = text (show s)
Iavor S. Diatchki's avatar
Iavor S. Diatchki committed
751
752
753
754

instance Ppr TyLit where
  ppr = pprTyLit

755
756
757
------------------------------
instance Ppr TyVarBndr where
    ppr (PlainTV nm)    = ppr nm
Jan Stolarek's avatar
Jan Stolarek committed
758
    ppr (KindedTV nm k) = parens (ppr nm <+> dcolon <+> ppr k)
759
760

instance Ppr Role where
761
762
763
764
    ppr NominalR          = text "nominal"
    ppr RepresentationalR = text "representational"
    ppr PhantomR          = text "phantom"
    ppr InferR            = text "_"
765

766
767
768
------------------------------
pprCxt :: Cxt -> Doc
pprCxt [] = empty
769
770
771
772
773
pprCxt ts = ppr_cxt_preds ts <+> text "=>"

ppr_cxt_preds :: Cxt -> Doc
ppr_cxt_preds [] = empty
ppr_cxt_preds [t] = ppr t
774
ppr_cxt_preds ts = parens (commaSep ts)
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790

------------------------------
instance Ppr Range where
    ppr = brackets . pprRange
        where pprRange :: Range -> Doc
              pprRange (FromR e) = ppr e <> text ".."
              pprRange (FromThenR e1 e2) = ppr e1 <> text ","
                                        <> ppr e2 <> text ".."
              pprRange (FromToR e1 e2) = ppr e1 <> text ".." <> ppr e2
              pprRange (FromThenToR e1 e2 e3) = ppr e1 <> text ","
                                             <> ppr e2 <> text ".."
                                             <> ppr e3

------------------------------
where_clause :: [Dec] -> Doc
where_clause [] = empty
791
where_clause ds = nest nestDepth $ text "where" <+> vcat (map (ppr_dec False) ds)
792
793
794
795

showtextl :: Show a => a -> Doc
showtextl = text . map toLower . show

796
797
798
hashParens :: Doc -> Doc
hashParens d = text "(# " <> d <> text " #)"

799
800
quoteParens :: Doc -> Doc
quoteParens d = text "'(" <> d <> text ")"
801
802
803
804
805
806
807
808
809
810
811

-----------------------------
instance Ppr Loc where
  ppr (Loc { loc_module = md
           , loc_package = pkg
           , loc_start = (start_ln, start_col)
           , loc_end = (end_ln, end_col) })
    = hcat [ text pkg, colon, text md, colon
           , parens $ int start_ln <> comma <> int start_col
           , text "-"
           , parens $ int end_ln <> comma <> int end_col ]
812
813
814
815

-- Takes a list of printable things and prints them separated by commas followed
-- by space.
commaSep :: Ppr a => [a] -> Doc
816
817
818
819
820
821
commaSep = commaSepWith ppr

-- Takes a list of things and prints them with the given pretty-printing
-- function, separated by commas followed by space.
commaSepWith :: (a -> Doc) -> [a] -> Doc
commaSepWith pprFun = sep . punctuate comma . map pprFun
822
823
824
825
826

-- Takes a list of printable things and prints them separated by semicolons
-- followed by space.
semiSep :: Ppr a => [a] -> Doc
semiSep = sep . punctuate semi . map ppr
827
828
829
830
831
832
833
834
835
836
837
838

-- Prints out the series of vertical bars that wraps an expression or pattern
-- used in an unboxed sum.
unboxedSumBars :: Doc -> SumAlt -> SumArity -> Doc
unboxedSumBars d alt arity = hashParens $
    bars (alt-1) <> d <> bars (arity - alt)
  where
    bars i = hsep (replicate i bar)

-- Text containing the vertical bar character.
bar :: Doc
bar = char '|'