never executed always true always false
1 {-# LANGUAGE ConstraintKinds #-}
2 {-# LANGUAGE DeriveDataTypeable #-}
3 {-# LANGUAGE FlexibleContexts #-}
4 {-# LANGUAGE FlexibleInstances #-}
5 {-# LANGUAGE LambdaCase #-}
6 {-# LANGUAGE ScopedTypeVariables #-}
7 {-# LANGUAGE TypeApplications #-}
8 {-# LANGUAGE TypeFamilies #-}
9 {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]
10 -- in module Language.Haskell.Syntax.Extension
11
12 {-# OPTIONS_GHC -Wno-orphans #-} -- Outputable
13
14 {-
15 (c) The University of Glasgow 2006
16 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
17
18 \section[HsBinds]{Abstract syntax: top-level bindings and signatures}
19
20 Datatype for: @BindGroup@, @Bind@, @Sig@, @Bind@.
21 -}
22
23 module GHC.Hs.Binds
24 ( module Language.Haskell.Syntax.Binds
25 , module GHC.Hs.Binds
26 ) where
27
28 import GHC.Prelude
29
30 import Language.Haskell.Syntax.Binds
31
32 import {-# SOURCE #-} GHC.Hs.Expr ( pprExpr, pprFunBind, pprPatBind )
33 import {-# SOURCE #-} GHC.Hs.Pat (pprLPat )
34
35 import Language.Haskell.Syntax.Extension
36 import GHC.Hs.Extension
37 import GHC.Parser.Annotation
38 import GHC.Hs.Type
39 import GHC.Tc.Types.Evidence
40 import GHC.Core.Type
41 import GHC.Types.Name.Set
42 import GHC.Types.Basic
43 import GHC.Types.SourceText
44 import GHC.Types.SrcLoc as SrcLoc
45 import GHC.Data.Bag
46 import GHC.Data.BooleanFormula (LBooleanFormula)
47 import GHC.Types.Name.Reader
48 import GHC.Types.Name
49 import GHC.Types.Id
50
51 import GHC.Utils.Outputable
52 import GHC.Utils.Panic
53
54 import Data.List (sortBy)
55 import Data.Function
56 import Data.Data (Data)
57
58 {-
59 ************************************************************************
60 * *
61 \subsection{Bindings: @BindGroup@}
62 * *
63 ************************************************************************
64
65 Global bindings (where clauses)
66 -}
67
68 -- the ...LR datatypes are parametrized by two id types,
69 -- one for the left and one for the right.
70
71 type instance XHsValBinds (GhcPass pL) (GhcPass pR) = EpAnn AnnList
72 type instance XHsIPBinds (GhcPass pL) (GhcPass pR) = EpAnn AnnList
73 type instance XEmptyLocalBinds (GhcPass pL) (GhcPass pR) = NoExtField
74 type instance XXHsLocalBindsLR (GhcPass pL) (GhcPass pR) = NoExtCon
75
76 -- ---------------------------------------------------------------------
77 -- Deal with ValBindsOut
78
79 -- TODO: make this the only type for ValBinds
80 data NHsValBindsLR idL
81 = NValBinds
82 [(RecFlag, LHsBinds idL)]
83 [LSig GhcRn]
84
85 type instance XValBinds (GhcPass pL) (GhcPass pR) = AnnSortKey
86 type instance XXValBindsLR (GhcPass pL) (GhcPass pR)
87 = NHsValBindsLR (GhcPass pL)
88
89 -- ---------------------------------------------------------------------
90
91 type instance XFunBind (GhcPass pL) GhcPs = NoExtField
92 type instance XFunBind (GhcPass pL) GhcRn = NameSet -- Free variables
93 type instance XFunBind (GhcPass pL) GhcTc = HsWrapper -- See comments on FunBind.fun_ext
94
95 type instance XPatBind GhcPs (GhcPass pR) = EpAnn [AddEpAnn]
96 type instance XPatBind GhcRn (GhcPass pR) = NameSet -- Free variables
97 type instance XPatBind GhcTc (GhcPass pR) = Type -- Type of the GRHSs
98
99 type instance XVarBind (GhcPass pL) (GhcPass pR) = NoExtField
100 type instance XAbsBinds (GhcPass pL) (GhcPass pR) = NoExtField
101 type instance XPatSynBind (GhcPass pL) (GhcPass pR) = NoExtField
102 type instance XXHsBindsLR (GhcPass pL) (GhcPass pR) = NoExtCon
103
104 type instance XABE (GhcPass p) = NoExtField
105 type instance XXABExport (GhcPass p) = NoExtCon
106
107 type instance XPSB (GhcPass idL) GhcPs = EpAnn [AddEpAnn]
108 type instance XPSB (GhcPass idL) GhcRn = NameSet
109 type instance XPSB (GhcPass idL) GhcTc = NameSet
110
111 type instance XXPatSynBind (GhcPass idL) (GhcPass idR) = NoExtCon
112
113 {-
114 Note [AbsBinds]
115 ~~~~~~~~~~~~~~~
116 The AbsBinds constructor is used in the output of the type checker, to
117 record *typechecked* and *generalised* bindings. Specifically
118
119 AbsBinds { abs_tvs = tvs
120 , abs_ev_vars = [d1,d2]
121 , abs_exports = [ABE { abe_poly = fp, abe_mono = fm
122 , abe_wrap = fwrap }
123 ABE { slly for g } ]
124 , abs_ev_binds = DBINDS
125 , abs_binds = BIND[fm,gm] }
126
127 where 'BIND' binds the monomorphic Ids 'fm' and 'gm', means
128
129 fp = fwrap [/\ tvs. \d1 d2. letrec { DBINDS ]
130 [ ; BIND[fm,gm] } ]
131 [ in fm ]
132
133 gp = ...same again, with gm instead of fm
134
135 The 'fwrap' is an impedance-matcher that typically does nothing; see
136 Note [ABExport wrapper].
137
138 This is a pretty bad translation, because it duplicates all the bindings.
139 So the desugarer tries to do a better job:
140
141 fp = /\ [a,b] -> \ [d1,d2] -> case tp [a,b] [d1,d2] of
142 (fm,gm) -> fm
143 ..ditto for gp..
144
145 tp = /\ [a,b] -> \ [d1,d2] -> letrec { DBINDS; BIND }
146 in (fm,gm)
147
148 In general:
149
150 * abs_tvs are the type variables over which the binding group is
151 generalised
152 * abs_ev_var are the evidence variables (usually dictionaries)
153 over which the binding group is generalised
154 * abs_binds are the monomorphic bindings
155 * abs_ex_binds are the evidence bindings that wrap the abs_binds
156 * abs_exports connects the monomorphic Ids bound by abs_binds
157 with the polymorphic Ids bound by the AbsBinds itself.
158
159 For example, consider a module M, with this top-level binding, where
160 there is no type signature for M.reverse,
161 M.reverse [] = []
162 M.reverse (x:xs) = M.reverse xs ++ [x]
163
164 In Hindley-Milner, a recursive binding is typechecked with the
165 *recursive* uses being *monomorphic*. So after typechecking *and*
166 desugaring we will get something like this
167
168 M.reverse :: forall a. [a] -> [a]
169 = /\a. letrec
170 reverse :: [a] -> [a] = \xs -> case xs of
171 [] -> []
172 (x:xs) -> reverse xs ++ [x]
173 in reverse
174
175 Notice that 'M.reverse' is polymorphic as expected, but there is a local
176 definition for plain 'reverse' which is *monomorphic*. The type variable
177 'a' scopes over the entire letrec.
178
179 That's after desugaring. What about after type checking but before
180 desugaring? That's where AbsBinds comes in. It looks like this:
181
182 AbsBinds { abs_tvs = [a]
183 , abs_ev_vars = []
184 , abs_exports = [ABE { abe_poly = M.reverse :: forall a. [a] -> [a],
185 , abe_mono = reverse :: [a] -> [a]}]
186 , abs_ev_binds = {}
187 , abs_binds = { reverse :: [a] -> [a]
188 = \xs -> case xs of
189 [] -> []
190 (x:xs) -> reverse xs ++ [x] } }
191
192 Here,
193
194 * abs_tvs says what type variables are abstracted over the binding
195 group, just 'a' in this case.
196 * abs_binds is the *monomorphic* bindings of the group
197 * abs_exports describes how to get the polymorphic Id 'M.reverse'
198 from the monomorphic one 'reverse'
199
200 Notice that the *original* function (the polymorphic one you thought
201 you were defining) appears in the abe_poly field of the
202 abs_exports. The bindings in abs_binds are for fresh, local, Ids with
203 a *monomorphic* Id.
204
205 If there is a group of mutually recursive (see Note [Polymorphic
206 recursion]) functions without type signatures, we get one AbsBinds
207 with the monomorphic versions of the bindings in abs_binds, and one
208 element of abe_exports for each variable bound in the mutually
209 recursive group. This is true even for pattern bindings. Example:
210 (f,g) = (\x -> x, f)
211 After type checking we get
212 AbsBinds { abs_tvs = [a]
213 , abs_exports = [ ABE { abe_poly = M.f :: forall a. a -> a
214 , abe_mono = f :: a -> a }
215 , ABE { abe_poly = M.g :: forall a. a -> a
216 , abe_mono = g :: a -> a }]
217 , abs_binds = { (f,g) = (\x -> x, f) }
218
219 Note [Polymorphic recursion]
220 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
221 Consider
222 Rec { f x = ...(g ef)...
223
224 ; g :: forall a. [a] -> [a]
225 ; g y = ...(f eg)... }
226
227 These bindings /are/ mutually recursive (f calls g, and g calls f).
228 But we can use the type signature for g to break the recursion,
229 like this:
230
231 1. Add g :: forall a. [a] -> [a] to the type environment
232
233 2. Typecheck the definition of f, all by itself,
234 including generalising it to find its most general
235 type, say f :: forall b. b -> b -> [b]
236
237 3. Extend the type environment with that type for f
238
239 4. Typecheck the definition of g, all by itself,
240 checking that it has the type claimed by its signature
241
242 Steps 2 and 4 each generate a separate AbsBinds, so we end
243 up with
244 Rec { AbsBinds { ...for f ... }
245 ; AbsBinds { ...for g ... } }
246
247 This approach allows both f and to call each other
248 polymorphically, even though only g has a signature.
249
250 We get an AbsBinds that encompasses multiple source-program
251 bindings only when
252 * Each binding in the group has at least one binder that
253 lacks a user type signature
254 * The group forms a strongly connected component
255
256
257 Note [The abs_sig field of AbsBinds]
258 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
259 The abs_sig field supports a couple of special cases for bindings.
260 Consider
261
262 x :: Num a => (# a, a #)
263 x = (# 3, 4 #)
264
265 The general desugaring for AbsBinds would give
266
267 x = /\a. \ ($dNum :: Num a) ->
268 letrec xm = (# fromInteger $dNum 3, fromInteger $dNum 4 #) in
269 xm
270
271 But that has an illegal let-binding for an unboxed tuple. In this
272 case we'd prefer to generate the (more direct)
273
274 x = /\ a. \ ($dNum :: Num a) ->
275 (# fromInteger $dNum 3, fromInteger $dNum 4 #)
276
277 A similar thing happens with representation-polymorphic defns
278 (#11405):
279
280 undef :: forall (r :: RuntimeRep) (a :: TYPE r). HasCallStack => a
281 undef = error "undef"
282
283 Again, the vanilla desugaring gives a local let-binding for a
284 representation-polymorphic (undefm :: a), which is illegal. But
285 again we can desugar without a let:
286
287 undef = /\ a. \ (d:HasCallStack) -> error a d "undef"
288
289 The abs_sig field supports this direct desugaring, with no local
290 let-binding. When abs_sig = True
291
292 * the abs_binds is single FunBind
293
294 * the abs_exports is a singleton
295
296 * we have a complete type sig for binder
297 and hence the abs_binds is non-recursive
298 (it binds the mono_id but refers to the poly_id
299
300 These properties are exploited in GHC.HsToCore.Binds.dsAbsBinds to
301 generate code without a let-binding.
302
303 Note [ABExport wrapper]
304 ~~~~~~~~~~~~~~~~~~~~~~~
305 Consider
306 (f,g) = (\x.x, \y.y)
307 This ultimately desugars to something like this:
308 tup :: forall a b. (a->a, b->b)
309 tup = /\a b. (\x:a.x, \y:b.y)
310 f :: forall a. a -> a
311 f = /\a. case tup a Any of
312 (fm::a->a,gm:Any->Any) -> fm
313 ...similarly for g...
314
315 The abe_wrap field deals with impedance-matching between
316 (/\a b. case tup a b of { (f,g) -> f })
317 and the thing we really want, which may have fewer type
318 variables. The action happens in GHC.Tc.Gen.Bind.mkExport.
319
320 Note [Bind free vars]
321 ~~~~~~~~~~~~~~~~~~~~~
322 The bind_fvs field of FunBind and PatBind records the free variables
323 of the definition. It is used for the following purposes
324
325 a) Dependency analysis prior to type checking
326 (see GHC.Tc.Gen.Bind.tc_group)
327
328 b) Deciding whether we can do generalisation of the binding
329 (see GHC.Tc.Gen.Bind.decideGeneralisationPlan)
330
331 c) Deciding whether the binding can be used in static forms
332 (see GHC.Tc.Gen.Expr.checkClosedInStaticForm for the HsStatic case and
333 GHC.Tc.Gen.Bind.isClosedBndrGroup).
334
335 Specifically,
336
337 * bind_fvs includes all free vars that are defined in this module
338 (including top-level things and lexically scoped type variables)
339
340 * bind_fvs excludes imported vars; this is just to keep the set smaller
341
342 * Before renaming, and after typechecking, the field is unused;
343 it's just an error thunk
344 -}
345
346 instance (OutputableBndrId pl, OutputableBndrId pr)
347 => Outputable (HsLocalBindsLR (GhcPass pl) (GhcPass pr)) where
348 ppr (HsValBinds _ bs) = ppr bs
349 ppr (HsIPBinds _ bs) = ppr bs
350 ppr (EmptyLocalBinds _) = empty
351
352 instance (OutputableBndrId pl, OutputableBndrId pr)
353 => Outputable (HsValBindsLR (GhcPass pl) (GhcPass pr)) where
354 ppr (ValBinds _ binds sigs)
355 = pprDeclList (pprLHsBindsForUser binds sigs)
356
357 ppr (XValBindsLR (NValBinds sccs sigs))
358 = getPprDebug $ \case
359 -- Print with sccs showing
360 True -> vcat (map ppr sigs) $$ vcat (map ppr_scc sccs)
361 False -> pprDeclList (pprLHsBindsForUser (unionManyBags (map snd sccs)) sigs)
362 where
363 ppr_scc (rec_flag, binds) = pp_rec rec_flag <+> pprLHsBinds binds
364 pp_rec Recursive = text "rec"
365 pp_rec NonRecursive = text "nonrec"
366
367 pprLHsBinds :: (OutputableBndrId idL, OutputableBndrId idR)
368 => LHsBindsLR (GhcPass idL) (GhcPass idR) -> SDoc
369 pprLHsBinds binds
370 | isEmptyLHsBinds binds = empty
371 | otherwise = pprDeclList (map ppr (bagToList binds))
372
373 pprLHsBindsForUser :: (OutputableBndrId idL,
374 OutputableBndrId idR,
375 OutputableBndrId id2)
376 => LHsBindsLR (GhcPass idL) (GhcPass idR) -> [LSig (GhcPass id2)] -> [SDoc]
377 -- pprLHsBindsForUser is different to pprLHsBinds because
378 -- a) No braces: 'let' and 'where' include a list of HsBindGroups
379 -- and we don't want several groups of bindings each
380 -- with braces around
381 -- b) Sort by location before printing
382 -- c) Include signatures
383 pprLHsBindsForUser binds sigs
384 = map snd (sort_by_loc decls)
385 where
386
387 decls :: [(SrcSpan, SDoc)]
388 decls = [(locA loc, ppr sig) | L loc sig <- sigs] ++
389 [(locA loc, ppr bind) | L loc bind <- bagToList binds]
390
391 sort_by_loc decls = sortBy (SrcLoc.leftmost_smallest `on` fst) decls
392
393 pprDeclList :: [SDoc] -> SDoc -- Braces with a space
394 -- Print a bunch of declarations
395 -- One could choose { d1; d2; ... }, using 'sep'
396 -- or d1
397 -- d2
398 -- ..
399 -- using vcat
400 -- At the moment we chose the latter
401 -- Also we do the 'pprDeeperList' thing.
402 pprDeclList ds = pprDeeperList vcat ds
403
404 ------------
405 emptyLocalBinds :: HsLocalBindsLR (GhcPass a) (GhcPass b)
406 emptyLocalBinds = EmptyLocalBinds noExtField
407
408 eqEmptyLocalBinds :: HsLocalBindsLR a b -> Bool
409 eqEmptyLocalBinds (EmptyLocalBinds _) = True
410 eqEmptyLocalBinds _ = False
411
412 isEmptyValBinds :: HsValBindsLR (GhcPass a) (GhcPass b) -> Bool
413 isEmptyValBinds (ValBinds _ ds sigs) = isEmptyLHsBinds ds && null sigs
414 isEmptyValBinds (XValBindsLR (NValBinds ds sigs)) = null ds && null sigs
415
416 emptyValBindsIn, emptyValBindsOut :: HsValBindsLR (GhcPass a) (GhcPass b)
417 emptyValBindsIn = ValBinds NoAnnSortKey emptyBag []
418 emptyValBindsOut = XValBindsLR (NValBinds [] [])
419
420 emptyLHsBinds :: LHsBindsLR (GhcPass idL) idR
421 emptyLHsBinds = emptyBag
422
423 isEmptyLHsBinds :: LHsBindsLR (GhcPass idL) idR -> Bool
424 isEmptyLHsBinds = isEmptyBag
425
426 ------------
427 plusHsValBinds :: HsValBinds (GhcPass a) -> HsValBinds (GhcPass a)
428 -> HsValBinds(GhcPass a)
429 plusHsValBinds (ValBinds _ ds1 sigs1) (ValBinds _ ds2 sigs2)
430 = ValBinds NoAnnSortKey (ds1 `unionBags` ds2) (sigs1 ++ sigs2)
431 plusHsValBinds (XValBindsLR (NValBinds ds1 sigs1))
432 (XValBindsLR (NValBinds ds2 sigs2))
433 = XValBindsLR (NValBinds (ds1 ++ ds2) (sigs1 ++ sigs2))
434 plusHsValBinds _ _
435 = panic "HsBinds.plusHsValBinds"
436
437 instance (OutputableBndrId pl, OutputableBndrId pr)
438 => Outputable (HsBindLR (GhcPass pl) (GhcPass pr)) where
439 ppr mbind = ppr_monobind mbind
440
441 ppr_monobind :: forall idL idR.
442 (OutputableBndrId idL, OutputableBndrId idR)
443 => HsBindLR (GhcPass idL) (GhcPass idR) -> SDoc
444
445 ppr_monobind (PatBind { pat_lhs = pat, pat_rhs = grhss })
446 = pprPatBind pat grhss
447 ppr_monobind (VarBind { var_id = var, var_rhs = rhs })
448 = sep [pprBndr CasePatBind var, nest 2 $ equals <+> pprExpr (unLoc rhs)]
449 ppr_monobind (FunBind { fun_id = fun,
450 fun_matches = matches,
451 fun_tick = ticks,
452 fun_ext = wrap })
453 = pprTicks empty (if null ticks then empty
454 else text "-- ticks = " <> ppr ticks)
455 $$ whenPprDebug (pprBndr LetBind (unLoc fun))
456 $$ pprFunBind matches
457 $$ whenPprDebug (pprIfTc @idR $ ppr wrap)
458
459 ppr_monobind (PatSynBind _ psb) = ppr psb
460 ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars
461 , abs_exports = exports, abs_binds = val_binds
462 , abs_ev_binds = ev_binds })
463 = sdocOption sdocPrintTypecheckerElaboration $ \case
464 False -> pprLHsBinds val_binds
465 True -> -- Show extra information (bug number: #10662)
466 hang (text "AbsBinds"
467 <+> sep [ brackets (interpp'SP tyvars)
468 , brackets (interpp'SP dictvars) ])
469 2 $ braces $ vcat
470 [ text "Exports:" <+>
471 brackets (sep (punctuate comma (map ppr exports)))
472 , text "Exported types:" <+>
473 vcat [pprBndr LetBind (abe_poly ex) | ex <- exports]
474 , text "Binds:" <+> pprLHsBinds val_binds
475 , pprIfTc @idR (text "Evidence:" <+> ppr ev_binds)
476 ]
477
478 instance OutputableBndrId p => Outputable (ABExport (GhcPass p)) where
479 ppr (ABE { abe_wrap = wrap, abe_poly = gbl, abe_mono = lcl, abe_prags = prags })
480 = vcat [ sep [ ppr gbl, nest 2 (text "<=" <+> ppr lcl) ]
481 , nest 2 (pprTcSpecPrags prags)
482 , pprIfTc @p $ nest 2 (text "wrap:" <+> ppr wrap) ]
483
484 instance (OutputableBndrId l, OutputableBndrId r)
485 => Outputable (PatSynBind (GhcPass l) (GhcPass r)) where
486 ppr (PSB{ psb_id = (L _ psyn), psb_args = details, psb_def = pat,
487 psb_dir = dir })
488 = ppr_lhs <+> ppr_rhs
489 where
490 ppr_lhs = text "pattern" <+> ppr_details
491 ppr_simple syntax = syntax <+> pprLPat pat
492
493 ppr_details = case details of
494 InfixCon v1 v2 -> hsep [ppr_v v1, pprInfixOcc psyn, ppr_v v2]
495 where
496 ppr_v v = case ghcPass @r of
497 GhcPs -> ppr v
498 GhcRn -> ppr v
499 GhcTc -> ppr v
500 PrefixCon _ vs -> hsep (pprPrefixOcc psyn : map ppr_v vs)
501 where
502 ppr_v v = case ghcPass @r of
503 GhcPs -> ppr v
504 GhcRn -> ppr v
505 GhcTc -> ppr v
506 RecCon vs -> pprPrefixOcc psyn
507 <> braces (sep (punctuate comma (map ppr_v vs)))
508 where
509 ppr_v v = case ghcPass @r of
510 GhcPs -> ppr v
511 GhcRn -> ppr v
512 GhcTc -> ppr v
513
514 ppr_rhs = case dir of
515 Unidirectional -> ppr_simple (text "<-")
516 ImplicitBidirectional -> ppr_simple equals
517 ExplicitBidirectional mg -> ppr_simple (text "<-") <+> text "where" $$
518 (nest 2 $ pprFunBind mg)
519
520 pprTicks :: SDoc -> SDoc -> SDoc
521 -- Print stuff about ticks only when -dppr-debug is on, to avoid
522 -- them appearing in error messages (from the desugarer); see # 3263
523 -- Also print ticks in dumpStyle, so that -ddump-hpc actually does
524 -- something useful.
525 pprTicks pp_no_debug pp_when_debug
526 = getPprStyle $ \sty ->
527 getPprDebug $ \debug ->
528 if debug || dumpStyle sty
529 then pp_when_debug
530 else pp_no_debug
531
532 {-
533 ************************************************************************
534 * *
535 Implicit parameter bindings
536 * *
537 ************************************************************************
538 -}
539
540 type instance XIPBinds GhcPs = NoExtField
541 type instance XIPBinds GhcRn = NoExtField
542 type instance XIPBinds GhcTc = TcEvBinds -- binds uses of the
543 -- implicit parameters
544
545
546 type instance XXHsIPBinds (GhcPass p) = NoExtCon
547
548 isEmptyIPBindsPR :: HsIPBinds (GhcPass p) -> Bool
549 isEmptyIPBindsPR (IPBinds _ is) = null is
550
551 isEmptyIPBindsTc :: HsIPBinds GhcTc -> Bool
552 isEmptyIPBindsTc (IPBinds ds is) = null is && isEmptyTcEvBinds ds
553
554 type instance XCIPBind (GhcPass p) = EpAnn [AddEpAnn]
555 type instance XXIPBind (GhcPass p) = NoExtCon
556
557 instance OutputableBndrId p
558 => Outputable (HsIPBinds (GhcPass p)) where
559 ppr (IPBinds ds bs) = pprDeeperList vcat (map ppr bs)
560 $$ whenPprDebug (pprIfTc @p $ ppr ds)
561
562 instance OutputableBndrId p => Outputable (IPBind (GhcPass p)) where
563 ppr (IPBind _ lr rhs) = name <+> equals <+> pprExpr (unLoc rhs)
564 where name = case lr of
565 Left (L _ ip) -> pprBndr LetBind ip
566 Right id -> pprBndr LetBind id
567
568 {-
569 ************************************************************************
570 * *
571 \subsection{@Sig@: type signatures and value-modifying user pragmas}
572 * *
573 ************************************************************************
574 -}
575
576 type instance XTypeSig (GhcPass p) = EpAnn AnnSig
577 type instance XPatSynSig (GhcPass p) = EpAnn AnnSig
578 type instance XClassOpSig (GhcPass p) = EpAnn AnnSig
579 type instance XIdSig (GhcPass p) = NoExtField -- No anns, generated
580 type instance XFixSig (GhcPass p) = EpAnn [AddEpAnn]
581 type instance XInlineSig (GhcPass p) = EpAnn [AddEpAnn]
582 type instance XSpecSig (GhcPass p) = EpAnn [AddEpAnn]
583 type instance XSpecInstSig (GhcPass p) = EpAnn [AddEpAnn]
584 type instance XMinimalSig (GhcPass p) = EpAnn [AddEpAnn]
585 type instance XSCCFunSig (GhcPass p) = EpAnn [AddEpAnn]
586 type instance XCompleteMatchSig (GhcPass p) = EpAnn [AddEpAnn]
587
588 type instance XXSig (GhcPass p) = NoExtCon
589
590 type instance XFixitySig (GhcPass p) = NoExtField
591 type instance XXFixitySig (GhcPass p) = NoExtCon
592
593 data AnnSig
594 = AnnSig {
595 asDcolon :: AddEpAnn, -- Not an EpaAnchor to capture unicode option
596 asRest :: [AddEpAnn]
597 } deriving Data
598
599
600 instance OutputableBndrId p => Outputable (Sig (GhcPass p)) where
601 ppr sig = ppr_sig sig
602
603 ppr_sig :: forall p. OutputableBndrId p
604 => Sig (GhcPass p) -> SDoc
605 ppr_sig (TypeSig _ vars ty) = pprVarSig (map unLoc vars) (ppr ty)
606 ppr_sig (ClassOpSig _ is_deflt vars ty)
607 | is_deflt = text "default" <+> pprVarSig (map unLoc vars) (ppr ty)
608 | otherwise = pprVarSig (map unLoc vars) (ppr ty)
609 ppr_sig (IdSig _ id) = pprVarSig [id] (ppr (varType id))
610 ppr_sig (FixSig _ fix_sig) = ppr fix_sig
611 ppr_sig (SpecSig _ var ty inl@(InlinePragma { inl_inline = spec }))
612 = pragSrcBrackets (inlinePragmaSource inl) pragmaSrc (pprSpec (unLoc var)
613 (interpp'SP ty) inl)
614 where
615 pragmaSrc = case spec of
616 NoUserInlinePrag -> "{-# " ++ extractSpecPragName (inl_src inl)
617 _ -> "{-# " ++ extractSpecPragName (inl_src inl) ++ "_INLINE"
618 ppr_sig (InlineSig _ var inl)
619 = pragSrcBrackets (inlinePragmaSource inl) "{-# INLINE" (pprInline inl
620 <+> pprPrefixOcc (unLoc var))
621 ppr_sig (SpecInstSig _ src ty)
622 = pragSrcBrackets src "{-# pragma" (text "instance" <+> ppr ty)
623 ppr_sig (MinimalSig _ src bf)
624 = pragSrcBrackets src "{-# MINIMAL" (pprMinimalSig bf)
625 ppr_sig (PatSynSig _ names sig_ty)
626 = text "pattern" <+> pprVarSig (map unLoc names) (ppr sig_ty)
627 ppr_sig (SCCFunSig _ src fn mlabel)
628 = pragSrcBrackets src "{-# SCC" (ppr_fn <+> maybe empty ppr mlabel )
629 where
630 ppr_fn = case ghcPass @p of
631 GhcPs -> ppr fn
632 GhcRn -> ppr fn
633 GhcTc -> ppr fn
634 ppr_sig (CompleteMatchSig _ src cs mty)
635 = pragSrcBrackets src "{-# COMPLETE"
636 ((hsep (punctuate comma (map ppr_n (unLoc cs))))
637 <+> opt_sig)
638 where
639 opt_sig = maybe empty ((\t -> dcolon <+> ppr t) . unLoc) mty
640 ppr_n n = case ghcPass @p of
641 GhcPs -> ppr n
642 GhcRn -> ppr n
643 GhcTc -> ppr n
644
645 instance OutputableBndrId p
646 => Outputable (FixitySig (GhcPass p)) where
647 ppr (FixitySig _ names fixity) = sep [ppr fixity, pprops]
648 where
649 pprops = hsep $ punctuate comma (map (pprInfixOcc . unLoc) names)
650
651 pragBrackets :: SDoc -> SDoc
652 pragBrackets doc = text "{-#" <+> doc <+> text "#-}"
653
654 -- | Using SourceText in case the pragma was spelled differently or used mixed
655 -- case
656 pragSrcBrackets :: SourceText -> String -> SDoc -> SDoc
657 pragSrcBrackets (SourceText src) _ doc = text src <+> doc <+> text "#-}"
658 pragSrcBrackets NoSourceText alt doc = text alt <+> doc <+> text "#-}"
659
660 pprVarSig :: (OutputableBndr id) => [id] -> SDoc -> SDoc
661 pprVarSig vars pp_ty = sep [pprvars <+> dcolon, nest 2 pp_ty]
662 where
663 pprvars = hsep $ punctuate comma (map pprPrefixOcc vars)
664
665 pprSpec :: (OutputableBndr id) => id -> SDoc -> InlinePragma -> SDoc
666 pprSpec var pp_ty inl = pp_inl <+> pprVarSig [var] pp_ty
667 where
668 pp_inl | isDefaultInlinePragma inl = empty
669 | otherwise = pprInline inl
670
671 pprTcSpecPrags :: TcSpecPrags -> SDoc
672 pprTcSpecPrags IsDefaultMethod = text "<default method>"
673 pprTcSpecPrags (SpecPrags ps) = vcat (map (ppr . unLoc) ps)
674
675 instance Outputable TcSpecPrag where
676 ppr (SpecPrag var _ inl)
677 = ppr (extractSpecPragName $ inl_src inl) <+> pprSpec var (text "<type>") inl
678
679 pprMinimalSig :: (OutputableBndr name)
680 => LBooleanFormula (GenLocated l name) -> SDoc
681 pprMinimalSig (L _ bf) = ppr (fmap unLoc bf)
682
683 {-
684 ************************************************************************
685 * *
686 \subsection{Anno instances}
687 * *
688 ************************************************************************
689 -}
690
691 type instance Anno (HsBindLR (GhcPass idL) (GhcPass idR)) = SrcSpanAnnA
692 type instance Anno (IPBind (GhcPass p)) = SrcSpanAnnA
693 type instance Anno (Sig (GhcPass p)) = SrcSpanAnnA
694
695 -- For CompleteMatchSig
696 type instance Anno [LocatedN RdrName] = SrcSpan
697 type instance Anno [LocatedN Name] = SrcSpan
698 type instance Anno [LocatedN Id] = SrcSpan
699
700 type instance Anno (FixitySig (GhcPass p)) = SrcSpanAnnA
701
702 type instance Anno StringLiteral = SrcAnn NoEpAnns
703 type instance Anno (LocatedN RdrName) = SrcSpan
704 type instance Anno (LocatedN Name) = SrcSpan
705 type instance Anno (LocatedN Id) = SrcSpan