e4a6906996756f5c6f6c521b20b6a45b12537df4
[ghc.git] / compiler / hsSyn / HsBinds.hs
1 {-
2 (c) The University of Glasgow 2006
3 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4
5 \section[HsBinds]{Abstract syntax: top-level bindings and signatures}
6
7 Datatype for: @BindGroup@, @Bind@, @Sig@, @Bind@.
8 -}
9
10 {-# LANGUAGE DeriveDataTypeable #-}
11 {-# LANGUAGE StandaloneDeriving #-}
12 {-# LANGUAGE FlexibleContexts #-}
13 {-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
14 -- in module PlaceHolder
15 {-# LANGUAGE ConstraintKinds #-}
16 {-# LANGUAGE BangPatterns #-}
17 {-# LANGUAGE TypeFamilies #-}
18
19 module HsBinds where
20
21 import GhcPrelude
22
23 import {-# SOURCE #-} HsExpr ( pprExpr, LHsExpr,
24 MatchGroup, pprFunBind,
25 GRHSs, pprPatBind )
26 import {-# SOURCE #-} HsPat ( LPat )
27
28 import HsExtension
29 import HsTypes
30 import PprCore ()
31 import CoreSyn
32 import TcEvidence
33 import Type
34 import NameSet
35 import BasicTypes
36 import Outputable
37 import SrcLoc
38 import Var
39 import Bag
40 import FastString
41 import BooleanFormula (LBooleanFormula)
42 import DynFlags
43
44 import Data.Data hiding ( Fixity )
45 import Data.List hiding ( foldr )
46 import Data.Ord
47 import Data.Foldable ( Foldable(..) )
48
49 {-
50 ************************************************************************
51 * *
52 \subsection{Bindings: @BindGroup@}
53 * *
54 ************************************************************************
55
56 Global bindings (where clauses)
57 -}
58
59 -- During renaming, we need bindings where the left-hand sides
60 -- have been renamed but the right-hand sides have not.
61 -- the ...LR datatypes are parametrized by two id types,
62 -- one for the left and one for the right.
63 -- Other than during renaming, these will be the same.
64
65 -- | Haskell Local Bindings
66 type HsLocalBinds id = HsLocalBindsLR id id
67
68 -- | Located Haskell local bindings
69 type LHsLocalBinds id = Located (HsLocalBinds id)
70
71 -- | Haskell Local Bindings with separate Left and Right identifier types
72 --
73 -- Bindings in a 'let' expression
74 -- or a 'where' clause
75 data HsLocalBindsLR idL idR
76 = HsValBinds
77 (XHsValBinds idL idR)
78 (HsValBindsLR idL idR)
79 -- ^ Haskell Value Bindings
80
81 -- There should be no pattern synonyms in the HsValBindsLR
82 -- These are *local* (not top level) bindings
83 -- The parser accepts them, however, leaving the
84 -- renamer to report them
85
86 | HsIPBinds
87 (XHsIPBinds idL idR)
88 (HsIPBinds idR)
89 -- ^ Haskell Implicit Parameter Bindings
90
91 | EmptyLocalBinds (XEmptyLocalBinds idL idR)
92 -- ^ Empty Local Bindings
93
94 | XHsLocalBindsLR
95 (XXHsLocalBindsLR idL idR)
96
97 type instance XHsValBinds (GhcPass pL) (GhcPass pR) = NoExt
98 type instance XHsIPBinds (GhcPass pL) (GhcPass pR) = NoExt
99 type instance XEmptyLocalBinds (GhcPass pL) (GhcPass pR) = NoExt
100 type instance XXHsLocalBindsLR (GhcPass pL) (GhcPass pR) = NoExt
101
102 type LHsLocalBindsLR idL idR = Located (HsLocalBindsLR idL idR)
103
104
105 -- | Haskell Value Bindings
106 type HsValBinds id = HsValBindsLR id id
107
108 -- | Haskell Value bindings with separate Left and Right identifier types
109 -- (not implicit parameters)
110 -- Used for both top level and nested bindings
111 -- May contain pattern synonym bindings
112 data HsValBindsLR idL idR
113 = -- | Value Bindings In
114 --
115 -- Before renaming RHS; idR is always RdrName
116 -- Not dependency analysed
117 -- Recursive by default
118 ValBinds
119 (XValBinds idL idR)
120 (LHsBindsLR idL idR) [LSig idR]
121
122 -- | Value Bindings Out
123 --
124 -- After renaming RHS; idR can be Name or Id Dependency analysed,
125 -- later bindings in the list may depend on earlier ones.
126 | XValBindsLR
127 (XXValBindsLR idL idR)
128
129 -- ---------------------------------------------------------------------
130 -- Deal with ValBindsOut
131
132 -- TODO: make this the only type for ValBinds
133 data NHsValBindsLR idL
134 = NValBinds
135 [(RecFlag, LHsBinds idL)]
136 [LSig GhcRn]
137
138 type instance XValBinds (GhcPass pL) (GhcPass pR) = NoExt
139 type instance XXValBindsLR (GhcPass pL) (GhcPass pR)
140 = NHsValBindsLR (GhcPass pL)
141
142 -- ---------------------------------------------------------------------
143
144 -- | Located Haskell Binding
145 type LHsBind id = LHsBindLR id id
146
147 -- | Located Haskell Bindings
148 type LHsBinds id = LHsBindsLR id id
149
150 -- | Haskell Binding
151 type HsBind id = HsBindLR id id
152
153 -- | Located Haskell Bindings with separate Left and Right identifier types
154 type LHsBindsLR idL idR = Bag (LHsBindLR idL idR)
155
156 -- | Located Haskell Binding with separate Left and Right identifier types
157 type LHsBindLR idL idR = Located (HsBindLR idL idR)
158
159 {- Note [FunBind vs PatBind]
160 ~~~~~~~~~~~~~~~~~~~~~~~~~
161 The distinction between FunBind and PatBind is a bit subtle. FunBind covers
162 patterns which resemble function bindings and simple variable bindings.
163
164 f x = e
165 f !x = e
166 f = e
167 !x = e -- FunRhs has SrcStrict
168 x `f` y = e -- FunRhs has Infix
169
170 The actual patterns and RHSs of a FunBind are encoding in fun_matches.
171 The m_ctxt field of each Match in fun_matches will be FunRhs and carries
172 two bits of information about the match,
173
174 * The mc_fixity field on each Match describes the fixity of the
175 function binder in that match. E.g. this is legal:
176 f True False = e1
177 True `f` True = e2
178
179 * The mc_strictness field is used /only/ for nullary FunBinds: ones
180 with one Match, which has no pats. For these, it describes whether
181 the match is decorated with a bang (e.g. `!x = e`).
182
183 By contrast, PatBind represents data constructor patterns, as well as a few
184 other interesting cases. Namely,
185
186 Just x = e
187 (x) = e
188 x :: Ty = e
189 -}
190
191 -- | Haskell Binding with separate Left and Right id's
192 data HsBindLR idL idR
193 = -- | Function-like Binding
194 --
195 -- FunBind is used for both functions @f x = e@
196 -- and variables @f = \x -> e@
197 -- and strict variables @!x = x + 1@
198 --
199 -- Reason 1: Special case for type inference: see 'TcBinds.tcMonoBinds'.
200 --
201 -- Reason 2: Instance decls can only have FunBinds, which is convenient.
202 -- If you change this, you'll need to change e.g. rnMethodBinds
203 --
204 -- But note that the form @f :: a->a = ...@
205 -- parses as a pattern binding, just like
206 -- @(f :: a -> a) = ... @
207 --
208 -- Strict bindings have their strictness recorded in the 'SrcStrictness' of their
209 -- 'MatchContext'. See Note [FunBind vs PatBind] for
210 -- details about the relationship between FunBind and PatBind.
211 --
212 -- 'ApiAnnotation.AnnKeywordId's
213 --
214 -- - 'ApiAnnotation.AnnFunId', attached to each element of fun_matches
215 --
216 -- - 'ApiAnnotation.AnnEqual','ApiAnnotation.AnnWhere',
217 -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose',
218
219 -- For details on above see note [Api annotations] in ApiAnnotation
220 FunBind {
221
222 fun_ext :: XFunBind idL idR, -- ^ After the renamer, this contains
223 -- the locally-bound
224 -- free variables of this defn.
225 -- See Note [Bind free vars]
226
227 fun_id :: Located (IdP idL), -- Note [fun_id in Match] in HsExpr
228
229 fun_matches :: MatchGroup idR (LHsExpr idR), -- ^ The payload
230
231 fun_co_fn :: HsWrapper, -- ^ Coercion from the type of the MatchGroup to the type of
232 -- the Id. Example:
233 --
234 -- @
235 -- f :: Int -> forall a. a -> a
236 -- f x y = y
237 -- @
238 --
239 -- Then the MatchGroup will have type (Int -> a' -> a')
240 -- (with a free type variable a'). The coercion will take
241 -- a CoreExpr of this type and convert it to a CoreExpr of
242 -- type Int -> forall a'. a' -> a'
243 -- Notice that the coercion captures the free a'.
244
245 fun_tick :: [Tickish Id] -- ^ Ticks to put on the rhs, if any
246 }
247
248 -- | Pattern Binding
249 --
250 -- The pattern is never a simple variable;
251 -- That case is done by FunBind.
252 -- See Note [FunBind vs PatBind] for details about the
253 -- relationship between FunBind and PatBind.
254
255 --
256 -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnBang',
257 -- 'ApiAnnotation.AnnEqual','ApiAnnotation.AnnWhere',
258 -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose',
259
260 -- For details on above see note [Api annotations] in ApiAnnotation
261 | PatBind {
262 pat_ext :: XPatBind idL idR, -- ^ See Note [Bind free vars]
263 pat_lhs :: LPat idL,
264 pat_rhs :: GRHSs idR (LHsExpr idR),
265 pat_ticks :: ([Tickish Id], [[Tickish Id]])
266 -- ^ Ticks to put on the rhs, if any, and ticks to put on
267 -- the bound variables.
268 }
269
270 -- | Variable Binding
271 --
272 -- Dictionary binding and suchlike.
273 -- All VarBinds are introduced by the type checker
274 | VarBind {
275 var_ext :: XVarBind idL idR,
276 var_id :: IdP idL,
277 var_rhs :: LHsExpr idR, -- ^ Located only for consistency
278 var_inline :: Bool -- ^ True <=> inline this binding regardless
279 -- (used for implication constraints only)
280 }
281
282 -- | Abstraction Bindings
283 | AbsBinds { -- Binds abstraction; TRANSLATION
284 abs_ext :: XAbsBinds idL idR,
285 abs_tvs :: [TyVar],
286 abs_ev_vars :: [EvVar], -- ^ Includes equality constraints
287
288 -- | AbsBinds only gets used when idL = idR after renaming,
289 -- but these need to be idL's for the collect... code in HsUtil
290 -- to have the right type
291 abs_exports :: [ABExport idL],
292
293 -- | Evidence bindings
294 -- Why a list? See TcInstDcls
295 -- Note [Typechecking plan for instance declarations]
296 abs_ev_binds :: [TcEvBinds],
297
298 -- | Typechecked user bindings
299 abs_binds :: LHsBinds idL,
300
301 abs_sig :: Bool -- See Note [The abs_sig field of AbsBinds]
302 }
303
304 -- | Patterns Synonym Binding
305 | PatSynBind
306 (XPatSynBind idL idR)
307 (PatSynBind idL idR)
308 -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnPattern',
309 -- 'ApiAnnotation.AnnLarrow','ApiAnnotation.AnnEqual',
310 -- 'ApiAnnotation.AnnWhere'
311 -- 'ApiAnnotation.AnnOpen' @'{'@,'ApiAnnotation.AnnClose' @'}'@
312
313 -- For details on above see note [Api annotations] in ApiAnnotation
314
315 | XHsBindsLR (XXHsBindsLR idL idR)
316
317 data NPatBindTc = NPatBindTc {
318 pat_fvs :: NameSet, -- ^ Free variables
319 pat_rhs_ty :: Type -- ^ Type of the GRHSs
320 } deriving Data
321
322 type instance XFunBind (GhcPass pL) GhcPs = NoExt
323 type instance XFunBind (GhcPass pL) GhcRn = NameSet -- Free variables
324 type instance XFunBind (GhcPass pL) GhcTc = NameSet -- Free variables
325
326 type instance XPatBind GhcPs (GhcPass pR) = NoExt
327 type instance XPatBind GhcRn (GhcPass pR) = NameSet -- Free variables
328 type instance XPatBind GhcTc (GhcPass pR) = NPatBindTc
329
330 type instance XVarBind (GhcPass pL) (GhcPass pR) = NoExt
331 type instance XAbsBinds (GhcPass pL) (GhcPass pR) = NoExt
332 type instance XPatSynBind (GhcPass pL) (GhcPass pR) = NoExt
333 type instance XXHsBindsLR (GhcPass pL) (GhcPass pR) = NoExt
334
335
336 -- Consider (AbsBinds tvs ds [(ftvs, poly_f, mono_f) binds]
337 --
338 -- Creates bindings for (polymorphic, overloaded) poly_f
339 -- in terms of monomorphic, non-overloaded mono_f
340 --
341 -- Invariants:
342 -- 1. 'binds' binds mono_f
343 -- 2. ftvs is a subset of tvs
344 -- 3. ftvs includes all tyvars free in ds
345 --
346 -- See Note [AbsBinds]
347
348 -- | Abtraction Bindings Export
349 data ABExport p
350 = ABE { abe_ext :: XABE p
351 , abe_poly :: IdP p -- ^ Any INLINE pragma is attached to this Id
352 , abe_mono :: IdP p
353 , abe_wrap :: HsWrapper -- ^ See Note [ABExport wrapper]
354 -- Shape: (forall abs_tvs. abs_ev_vars => abe_mono) ~ abe_poly
355 , abe_prags :: TcSpecPrags -- ^ SPECIALISE pragmas
356 }
357 | XABExport (XXABExport p)
358
359 type instance XABE (GhcPass p) = NoExt
360 type instance XXABExport (GhcPass p) = NoExt
361
362
363 -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnPattern',
364 -- 'ApiAnnotation.AnnEqual','ApiAnnotation.AnnLarrow'
365 -- 'ApiAnnotation.AnnWhere','ApiAnnotation.AnnOpen' @'{'@,
366 -- 'ApiAnnotation.AnnClose' @'}'@,
367
368 -- For details on above see note [Api annotations] in ApiAnnotation
369
370 -- | Pattern Synonym binding
371 data PatSynBind idL idR
372 = PSB { psb_ext :: XPSB idL idR, -- ^ Post renaming, FVs.
373 -- See Note [Bind free vars]
374 psb_id :: Located (IdP idL), -- ^ Name of the pattern synonym
375 psb_args :: HsPatSynDetails (Located (IdP idR)),
376 -- ^ Formal parameter names
377 psb_def :: LPat idR, -- ^ Right-hand side
378 psb_dir :: HsPatSynDir idR -- ^ Directionality
379 }
380 | XPatSynBind (XXPatSynBind idL idR)
381
382 type instance XPSB (GhcPass idL) GhcPs = NoExt
383 type instance XPSB (GhcPass idL) GhcRn = NameSet
384 type instance XPSB (GhcPass idL) GhcTc = NameSet
385
386 type instance XXPatSynBind (GhcPass idL) (GhcPass idR) = NoExt
387
388 {-
389 Note [AbsBinds]
390 ~~~~~~~~~~~~~~~
391 The AbsBinds constructor is used in the output of the type checker, to
392 record *typechecked* and *generalised* bindings. Specifically
393
394 AbsBinds { abs_tvs = tvs
395 , abs_ev_vars = [d1,d2]
396 , abs_exports = [ABE { abe_poly = fp, abe_mono = fm
397 , abe_wrap = fwrap }
398 ABE { slly for g } ]
399 , abs_ev_binds = DBINDS
400 , abs_binds = BIND[fm,gm] }
401
402 where 'BIND' binds the monomorphic Ids 'fm' and 'gm', means
403
404 fp = fwrap [/\ tvs. \d1 d2. letrec { DBINDS ]
405 [ ; BIND[fm,gm] } ]
406 [ in fm ]
407
408 gp = ...same again, with gm instead of fm
409
410 The 'fwrap' is an impedence-matcher that typically does nothing; see
411 Note [ABExport wrapper].
412
413 This is a pretty bad translation, because it duplicates all the bindings.
414 So the desugarer tries to do a better job:
415
416 fp = /\ [a,b] -> \ [d1,d2] -> case tp [a,b] [d1,d2] of
417 (fm,gm) -> fm
418 ..ditto for gp..
419
420 tp = /\ [a,b] -> \ [d1,d2] -> letrec { DBINDS; BIND }
421 in (fm,gm)
422
423 In general:
424
425 * abs_tvs are the type variables over which the binding group is
426 generalised
427 * abs_ev_var are the evidence variables (usually dictionaries)
428 over which the binding group is generalised
429 * abs_binds are the monomorphic bindings
430 * abs_ex_binds are the evidence bindings that wrap the abs_binds
431 * abs_exports connects the monomorphic Ids bound by abs_binds
432 with the polymorphic Ids bound by the AbsBinds itself.
433
434 For example, consider a module M, with this top-level binding, where
435 there is no type signature for M.reverse,
436 M.reverse [] = []
437 M.reverse (x:xs) = M.reverse xs ++ [x]
438
439 In Hindley-Milner, a recursive binding is typechecked with the
440 *recursive* uses being *monomorphic*. So after typechecking *and*
441 desugaring we will get something like this
442
443 M.reverse :: forall a. [a] -> [a]
444 = /\a. letrec
445 reverse :: [a] -> [a] = \xs -> case xs of
446 [] -> []
447 (x:xs) -> reverse xs ++ [x]
448 in reverse
449
450 Notice that 'M.reverse' is polymorphic as expected, but there is a local
451 definition for plain 'reverse' which is *monomorphic*. The type variable
452 'a' scopes over the entire letrec.
453
454 That's after desugaring. What about after type checking but before
455 desugaring? That's where AbsBinds comes in. It looks like this:
456
457 AbsBinds { abs_tvs = [a]
458 , abs_ev_vars = []
459 , abs_exports = [ABE { abe_poly = M.reverse :: forall a. [a] -> [a],
460 , abe_mono = reverse :: [a] -> [a]}]
461 , abs_ev_binds = {}
462 , abs_binds = { reverse :: [a] -> [a]
463 = \xs -> case xs of
464 [] -> []
465 (x:xs) -> reverse xs ++ [x] } }
466
467 Here,
468
469 * abs_tvs says what type variables are abstracted over the binding
470 group, just 'a' in this case.
471 * abs_binds is the *monomorphic* bindings of the group
472 * abs_exports describes how to get the polymorphic Id 'M.reverse'
473 from the monomorphic one 'reverse'
474
475 Notice that the *original* function (the polymorphic one you thought
476 you were defining) appears in the abe_poly field of the
477 abs_exports. The bindings in abs_binds are for fresh, local, Ids with
478 a *monomorphic* Id.
479
480 If there is a group of mutually recursive (see Note [Polymorphic
481 recursion]) functions without type signatures, we get one AbsBinds
482 with the monomorphic versions of the bindings in abs_binds, and one
483 element of abe_exports for each variable bound in the mutually
484 recursive group. This is true even for pattern bindings. Example:
485 (f,g) = (\x -> x, f)
486 After type checking we get
487 AbsBinds { abs_tvs = [a]
488 , abs_exports = [ ABE { abe_poly = M.f :: forall a. a -> a
489 , abe_mono = f :: a -> a }
490 , ABE { abe_poly = M.g :: forall a. a -> a
491 , abe_mono = g :: a -> a }]
492 , abs_binds = { (f,g) = (\x -> x, f) }
493
494 Note [Polymorphic recursion]
495 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
496 Consider
497 Rec { f x = ...(g ef)...
498
499 ; g :: forall a. [a] -> [a]
500 ; g y = ...(f eg)... }
501
502 These bindings /are/ mutually recursive (f calls g, and g calls f).
503 But we can use the type signature for g to break the recursion,
504 like this:
505
506 1. Add g :: forall a. [a] -> [a] to the type environment
507
508 2. Typecheck the definition of f, all by itself,
509 including generalising it to find its most general
510 type, say f :: forall b. b -> b -> [b]
511
512 3. Extend the type environment with that type for f
513
514 4. Typecheck the definition of g, all by itself,
515 checking that it has the type claimed by its signature
516
517 Steps 2 and 4 each generate a separate AbsBinds, so we end
518 up with
519 Rec { AbsBinds { ...for f ... }
520 ; AbsBinds { ...for g ... } }
521
522 This approach allows both f and to call each other
523 polymorphically, even though only g has a signature.
524
525 We get an AbsBinds that encompasses multiple source-program
526 bindings only when
527 * Each binding in the group has at least one binder that
528 lacks a user type signature
529 * The group forms a strongly connected component
530
531
532 Note [The abs_sig field of AbsBinds]
533 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
534 The abs_sig field supports a couple of special cases for bindings.
535 Consider
536
537 x :: Num a => (# a, a #)
538 x = (# 3, 4 #)
539
540 The general desugaring for AbsBinds would give
541
542 x = /\a. \ ($dNum :: Num a) ->
543 letrec xm = (# fromInteger $dNum 3, fromInteger $dNum 4 #) in
544 xm
545
546 But that has an illegal let-binding for an unboxed tuple. In this
547 case we'd prefer to generate the (more direct)
548
549 x = /\ a. \ ($dNum :: Num a) ->
550 (# fromInteger $dNum 3, fromInteger $dNum 4 #)
551
552 A similar thing happens with representation-polymorphic defns
553 (Trac #11405):
554
555 undef :: forall (r :: RuntimeRep) (a :: TYPE r). HasCallStack => a
556 undef = error "undef"
557
558 Again, the vanilla desugaring gives a local let-binding for a
559 representation-polymorphic (undefm :: a), which is illegal. But
560 again we can desugar without a let:
561
562 undef = /\ a. \ (d:HasCallStack) -> error a d "undef"
563
564 The abs_sig field supports this direct desugaring, with no local
565 let-bining. When abs_sig = True
566
567 * the abs_binds is single FunBind
568
569 * the abs_exports is a singleton
570
571 * we have a complete type sig for binder
572 and hence the abs_binds is non-recursive
573 (it binds the mono_id but refers to the poly_id
574
575 These properties are exploited in DsBinds.dsAbsBinds to
576 generate code without a let-binding.
577
578 Note [ABExport wrapper]
579 ~~~~~~~~~~~~~~~~~~~~~~~
580 Consider
581 (f,g) = (\x.x, \y.y)
582 This ultimately desugars to something like this:
583 tup :: forall a b. (a->a, b->b)
584 tup = /\a b. (\x:a.x, \y:b.y)
585 f :: forall a. a -> a
586 f = /\a. case tup a Any of
587 (fm::a->a,gm:Any->Any) -> fm
588 ...similarly for g...
589
590 The abe_wrap field deals with impedance-matching between
591 (/\a b. case tup a b of { (f,g) -> f })
592 and the thing we really want, which may have fewer type
593 variables. The action happens in TcBinds.mkExport.
594
595 Note [Bind free vars]
596 ~~~~~~~~~~~~~~~~~~~~~
597 The bind_fvs field of FunBind and PatBind records the free variables
598 of the definition. It is used for the following purposes
599
600 a) Dependency analysis prior to type checking
601 (see TcBinds.tc_group)
602
603 b) Deciding whether we can do generalisation of the binding
604 (see TcBinds.decideGeneralisationPlan)
605
606 c) Deciding whether the binding can be used in static forms
607 (see TcExpr.checkClosedInStaticForm for the HsStatic case and
608 TcBinds.isClosedBndrGroup).
609
610 Specifically,
611
612 * bind_fvs includes all free vars that are defined in this module
613 (including top-level things and lexically scoped type variables)
614
615 * bind_fvs excludes imported vars; this is just to keep the set smaller
616
617 * Before renaming, and after typechecking, the field is unused;
618 it's just an error thunk
619 -}
620
621 instance (idL ~ GhcPass pl, idR ~ GhcPass pr,
622 OutputableBndrId idL, OutputableBndrId idR)
623 => Outputable (HsLocalBindsLR idL idR) where
624 ppr (HsValBinds _ bs) = ppr bs
625 ppr (HsIPBinds _ bs) = ppr bs
626 ppr (EmptyLocalBinds _) = empty
627 ppr (XHsLocalBindsLR x) = ppr x
628
629 instance (idL ~ GhcPass pl, idR ~ GhcPass pr,
630 OutputableBndrId idL, OutputableBndrId idR)
631 => Outputable (HsValBindsLR idL idR) where
632 ppr (ValBinds _ binds sigs)
633 = pprDeclList (pprLHsBindsForUser binds sigs)
634
635 ppr (XValBindsLR (NValBinds sccs sigs))
636 = getPprStyle $ \ sty ->
637 if debugStyle sty then -- Print with sccs showing
638 vcat (map ppr sigs) $$ vcat (map ppr_scc sccs)
639 else
640 pprDeclList (pprLHsBindsForUser (unionManyBags (map snd sccs)) sigs)
641 where
642 ppr_scc (rec_flag, binds) = pp_rec rec_flag <+> pprLHsBinds binds
643 pp_rec Recursive = text "rec"
644 pp_rec NonRecursive = text "nonrec"
645
646 pprLHsBinds :: (OutputableBndrId (GhcPass idL), OutputableBndrId (GhcPass idR))
647 => LHsBindsLR (GhcPass idL) (GhcPass idR) -> SDoc
648 pprLHsBinds binds
649 | isEmptyLHsBinds binds = empty
650 | otherwise = pprDeclList (map ppr (bagToList binds))
651
652 pprLHsBindsForUser :: (OutputableBndrId (GhcPass idL),
653 OutputableBndrId (GhcPass idR),
654 OutputableBndrId (GhcPass id2))
655 => LHsBindsLR (GhcPass idL) (GhcPass idR) -> [LSig (GhcPass id2)] -> [SDoc]
656 -- pprLHsBindsForUser is different to pprLHsBinds because
657 -- a) No braces: 'let' and 'where' include a list of HsBindGroups
658 -- and we don't want several groups of bindings each
659 -- with braces around
660 -- b) Sort by location before printing
661 -- c) Include signatures
662 pprLHsBindsForUser binds sigs
663 = map snd (sort_by_loc decls)
664 where
665
666 decls :: [(SrcSpan, SDoc)]
667 decls = [(loc, ppr sig) | L loc sig <- sigs] ++
668 [(loc, ppr bind) | L loc bind <- bagToList binds]
669
670 sort_by_loc decls = sortBy (comparing fst) decls
671
672 pprDeclList :: [SDoc] -> SDoc -- Braces with a space
673 -- Print a bunch of declarations
674 -- One could choose { d1; d2; ... }, using 'sep'
675 -- or d1
676 -- d2
677 -- ..
678 -- using vcat
679 -- At the moment we chose the latter
680 -- Also we do the 'pprDeeperList' thing.
681 pprDeclList ds = pprDeeperList vcat ds
682
683 ------------
684 emptyLocalBinds :: HsLocalBindsLR (GhcPass a) (GhcPass b)
685 emptyLocalBinds = EmptyLocalBinds noExt
686
687 -- AZ:These functions do not seem to be used at all?
688 isEmptyLocalBindsTc :: HsLocalBindsLR (GhcPass a) GhcTc -> Bool
689 isEmptyLocalBindsTc (HsValBinds _ ds) = isEmptyValBinds ds
690 isEmptyLocalBindsTc (HsIPBinds _ ds) = isEmptyIPBindsTc ds
691 isEmptyLocalBindsTc (EmptyLocalBinds _) = True
692 isEmptyLocalBindsTc (XHsLocalBindsLR _) = True
693
694 isEmptyLocalBindsPR :: HsLocalBindsLR (GhcPass a) (GhcPass b) -> Bool
695 isEmptyLocalBindsPR (HsValBinds _ ds) = isEmptyValBinds ds
696 isEmptyLocalBindsPR (HsIPBinds _ ds) = isEmptyIPBindsPR ds
697 isEmptyLocalBindsPR (EmptyLocalBinds _) = True
698 isEmptyLocalBindsPR (XHsLocalBindsLR _) = True
699
700 eqEmptyLocalBinds :: HsLocalBindsLR a b -> Bool
701 eqEmptyLocalBinds (EmptyLocalBinds _) = True
702 eqEmptyLocalBinds _ = False
703
704 isEmptyValBinds :: HsValBindsLR (GhcPass a) (GhcPass b) -> Bool
705 isEmptyValBinds (ValBinds _ ds sigs) = isEmptyLHsBinds ds && null sigs
706 isEmptyValBinds (XValBindsLR (NValBinds ds sigs)) = null ds && null sigs
707
708 emptyValBindsIn, emptyValBindsOut :: HsValBindsLR (GhcPass a) (GhcPass b)
709 emptyValBindsIn = ValBinds noExt emptyBag []
710 emptyValBindsOut = XValBindsLR (NValBinds [] [])
711
712 emptyLHsBinds :: LHsBindsLR idL idR
713 emptyLHsBinds = emptyBag
714
715 isEmptyLHsBinds :: LHsBindsLR idL idR -> Bool
716 isEmptyLHsBinds = isEmptyBag
717
718 ------------
719 plusHsValBinds :: HsValBinds (GhcPass a) -> HsValBinds (GhcPass a)
720 -> HsValBinds(GhcPass a)
721 plusHsValBinds (ValBinds _ ds1 sigs1) (ValBinds _ ds2 sigs2)
722 = ValBinds noExt (ds1 `unionBags` ds2) (sigs1 ++ sigs2)
723 plusHsValBinds (XValBindsLR (NValBinds ds1 sigs1))
724 (XValBindsLR (NValBinds ds2 sigs2))
725 = XValBindsLR (NValBinds (ds1 ++ ds2) (sigs1 ++ sigs2))
726 plusHsValBinds _ _
727 = panic "HsBinds.plusHsValBinds"
728
729 instance (idL ~ GhcPass pl, idR ~ GhcPass pr,
730 OutputableBndrId idL, OutputableBndrId idR)
731 => Outputable (HsBindLR idL idR) where
732 ppr mbind = ppr_monobind mbind
733
734 ppr_monobind :: (OutputableBndrId (GhcPass idL), OutputableBndrId (GhcPass idR))
735 => HsBindLR (GhcPass idL) (GhcPass idR) -> SDoc
736
737 ppr_monobind (PatBind { pat_lhs = pat, pat_rhs = grhss })
738 = pprPatBind pat grhss
739 ppr_monobind (VarBind { var_id = var, var_rhs = rhs })
740 = sep [pprBndr CasePatBind var, nest 2 $ equals <+> pprExpr (unLoc rhs)]
741 ppr_monobind (FunBind { fun_id = fun,
742 fun_co_fn = wrap,
743 fun_matches = matches,
744 fun_tick = ticks })
745 = pprTicks empty (if null ticks then empty
746 else text "-- ticks = " <> ppr ticks)
747 $$ whenPprDebug (pprBndr LetBind (unLoc fun))
748 $$ pprFunBind matches
749 $$ whenPprDebug (ppr wrap)
750 ppr_monobind (PatSynBind _ psb) = ppr psb
751 ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars
752 , abs_exports = exports, abs_binds = val_binds
753 , abs_ev_binds = ev_binds })
754 = sdocWithDynFlags $ \ dflags ->
755 if gopt Opt_PrintTypecheckerElaboration dflags then
756 -- Show extra information (bug number: #10662)
757 hang (text "AbsBinds" <+> brackets (interpp'SP tyvars)
758 <+> brackets (interpp'SP dictvars))
759 2 $ braces $ vcat
760 [ text "Exports:" <+>
761 brackets (sep (punctuate comma (map ppr exports)))
762 , text "Exported types:" <+>
763 vcat [pprBndr LetBind (abe_poly ex) | ex <- exports]
764 , text "Binds:" <+> pprLHsBinds val_binds
765 , text "Evidence:" <+> ppr ev_binds ]
766 else
767 pprLHsBinds val_binds
768 ppr_monobind (XHsBindsLR x) = ppr x
769
770 instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (ABExport p) where
771 ppr (ABE { abe_wrap = wrap, abe_poly = gbl, abe_mono = lcl, abe_prags = prags })
772 = vcat [ ppr gbl <+> text "<=" <+> ppr lcl
773 , nest 2 (pprTcSpecPrags prags)
774 , nest 2 (text "wrap:" <+> ppr wrap)]
775 ppr (XABExport x) = ppr x
776
777 instance (idR ~ GhcPass pr,OutputableBndrId idL, OutputableBndrId idR,
778 Outputable (XXPatSynBind idL idR))
779 => Outputable (PatSynBind idL idR) where
780 ppr (PSB{ psb_id = (L _ psyn), psb_args = details, psb_def = pat,
781 psb_dir = dir })
782 = ppr_lhs <+> ppr_rhs
783 where
784 ppr_lhs = text "pattern" <+> ppr_details
785 ppr_simple syntax = syntax <+> ppr pat
786
787 ppr_details = case details of
788 InfixCon v1 v2 -> hsep [ppr v1, pprInfixOcc psyn, ppr v2]
789 PrefixCon vs -> hsep (pprPrefixOcc psyn : map ppr vs)
790 RecCon vs -> pprPrefixOcc psyn
791 <> braces (sep (punctuate comma (map ppr vs)))
792
793 ppr_rhs = case dir of
794 Unidirectional -> ppr_simple (text "<-")
795 ImplicitBidirectional -> ppr_simple equals
796 ExplicitBidirectional mg -> ppr_simple (text "<-") <+> ptext (sLit "where") $$
797 (nest 2 $ pprFunBind mg)
798 ppr (XPatSynBind x) = ppr x
799
800 pprTicks :: SDoc -> SDoc -> SDoc
801 -- Print stuff about ticks only when -dppr-debug is on, to avoid
802 -- them appearing in error messages (from the desugarer); see Trac # 3263
803 -- Also print ticks in dumpStyle, so that -ddump-hpc actually does
804 -- something useful.
805 pprTicks pp_no_debug pp_when_debug
806 = getPprStyle (\ sty -> if debugStyle sty || dumpStyle sty
807 then pp_when_debug
808 else pp_no_debug)
809
810 {-
811 ************************************************************************
812 * *
813 Implicit parameter bindings
814 * *
815 ************************************************************************
816 -}
817
818 -- | Haskell Implicit Parameter Bindings
819 data HsIPBinds id
820 = IPBinds
821 (XIPBinds id)
822 [LIPBind id]
823 -- TcEvBinds -- Only in typechecker output; binds
824 -- -- uses of the implicit parameters
825 | XHsIPBinds (XXHsIPBinds id)
826
827 type instance XIPBinds GhcPs = NoExt
828 type instance XIPBinds GhcRn = NoExt
829 type instance XIPBinds GhcTc = TcEvBinds -- binds uses of the
830 -- implicit parameters
831
832
833 type instance XXHsIPBinds (GhcPass p) = NoExt
834
835 isEmptyIPBindsPR :: HsIPBinds (GhcPass p) -> Bool
836 isEmptyIPBindsPR (IPBinds _ is) = null is
837 isEmptyIPBindsPR (XHsIPBinds _) = True
838
839 isEmptyIPBindsTc :: HsIPBinds GhcTc -> Bool
840 isEmptyIPBindsTc (IPBinds ds is) = null is && isEmptyTcEvBinds ds
841 isEmptyIPBindsTc (XHsIPBinds _) = True
842
843 -- | Located Implicit Parameter Binding
844 type LIPBind id = Located (IPBind id)
845 -- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi' when in a
846 -- list
847
848 -- For details on above see note [Api annotations] in ApiAnnotation
849
850 -- | Implicit parameter bindings.
851 --
852 -- These bindings start off as (Left "x") in the parser and stay
853 -- that way until after type-checking when they are replaced with
854 -- (Right d), where "d" is the name of the dictionary holding the
855 -- evidence for the implicit parameter.
856 --
857 -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnEqual'
858
859 -- For details on above see note [Api annotations] in ApiAnnotation
860 data IPBind id
861 = IPBind
862 (XIPBind id)
863 (Either (Located HsIPName) (IdP id))
864 (LHsExpr id)
865 | XCIPBind (XXIPBind id)
866
867 type instance XIPBind (GhcPass p) = NoExt
868 type instance XXIPBind (GhcPass p) = NoExt
869
870 instance (p ~ GhcPass pass, OutputableBndrId p)
871 => Outputable (HsIPBinds p) where
872 ppr (IPBinds ds bs) = pprDeeperList vcat (map ppr bs)
873 $$ whenPprDebug (ppr ds)
874 ppr (XHsIPBinds x) = ppr x
875
876 instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (IPBind p) where
877 ppr (IPBind _ lr rhs) = name <+> equals <+> pprExpr (unLoc rhs)
878 where name = case lr of
879 Left (L _ ip) -> pprBndr LetBind ip
880 Right id -> pprBndr LetBind id
881 ppr (XCIPBind x) = ppr x
882
883 {-
884 ************************************************************************
885 * *
886 \subsection{@Sig@: type signatures and value-modifying user pragmas}
887 * *
888 ************************************************************************
889
890 It is convenient to lump ``value-modifying'' user-pragmas (e.g.,
891 ``specialise this function to these four types...'') in with type
892 signatures. Then all the machinery to move them into place, etc.,
893 serves for both.
894 -}
895
896 -- | Located Signature
897 type LSig pass = Located (Sig pass)
898
899 -- | Signatures and pragmas
900 data Sig pass
901 = -- | An ordinary type signature
902 --
903 -- > f :: Num a => a -> a
904 --
905 -- After renaming, this list of Names contains the named and unnamed
906 -- wildcards brought into scope by this signature. For a signature
907 -- @_ -> _a -> Bool@, the renamer will give the unnamed wildcard @_@
908 -- a freshly generated name, e.g. @_w@. @_w@ and the named wildcard @_a@
909 -- are then both replaced with fresh meta vars in the type. Their names
910 -- are stored in the type signature that brought them into scope, in
911 -- this third field to be more specific.
912 --
913 -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon',
914 -- 'ApiAnnotation.AnnComma'
915
916 -- For details on above see note [Api annotations] in ApiAnnotation
917 TypeSig
918 (XTypeSig pass)
919 [Located (IdP pass)] -- LHS of the signature; e.g. f,g,h :: blah
920 (LHsSigWcType pass) -- RHS of the signature; can have wildcards
921
922 -- | A pattern synonym type signature
923 --
924 -- > pattern Single :: () => (Show a) => a -> [a]
925 --
926 -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnPattern',
927 -- 'ApiAnnotation.AnnDcolon','ApiAnnotation.AnnForall'
928 -- 'ApiAnnotation.AnnDot','ApiAnnotation.AnnDarrow'
929
930 -- For details on above see note [Api annotations] in ApiAnnotation
931 | PatSynSig (XPatSynSig pass) [Located (IdP pass)] (LHsSigType pass)
932 -- P :: forall a b. Req => Prov => ty
933
934 -- | A signature for a class method
935 -- False: ordinary class-method signature
936 -- True: generic-default class method signature
937 -- e.g. class C a where
938 -- op :: a -> a -- Ordinary
939 -- default op :: Eq a => a -> a -- Generic default
940 -- No wildcards allowed here
941 --
942 -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDefault',
943 -- 'ApiAnnotation.AnnDcolon'
944 | ClassOpSig (XClassOpSig pass) Bool [Located (IdP pass)] (LHsSigType pass)
945
946 -- | A type signature in generated code, notably the code
947 -- generated for record selectors. We simply record
948 -- the desired Id itself, replete with its name, type
949 -- and IdDetails. Otherwise it's just like a type
950 -- signature: there should be an accompanying binding
951 | IdSig (XIdSig pass) Id
952
953 -- | An ordinary fixity declaration
954 --
955 -- > infixl 8 ***
956 --
957 --
958 -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnInfix',
959 -- 'ApiAnnotation.AnnVal'
960
961 -- For details on above see note [Api annotations] in ApiAnnotation
962 | FixSig (XFixSig pass) (FixitySig pass)
963
964 -- | An inline pragma
965 --
966 -- > {#- INLINE f #-}
967 --
968 -- - 'ApiAnnotation.AnnKeywordId' :
969 -- 'ApiAnnotation.AnnOpen' @'{-\# INLINE'@ and @'['@,
970 -- 'ApiAnnotation.AnnClose','ApiAnnotation.AnnOpen',
971 -- 'ApiAnnotation.AnnVal','ApiAnnotation.AnnTilde',
972 -- 'ApiAnnotation.AnnClose'
973
974 -- For details on above see note [Api annotations] in ApiAnnotation
975 | InlineSig (XInlineSig pass)
976 (Located (IdP pass)) -- Function name
977 InlinePragma -- Never defaultInlinePragma
978
979 -- | A specialisation pragma
980 --
981 -- > {-# SPECIALISE f :: Int -> Int #-}
982 --
983 -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
984 -- 'ApiAnnotation.AnnOpen' @'{-\# SPECIALISE'@ and @'['@,
985 -- 'ApiAnnotation.AnnTilde',
986 -- 'ApiAnnotation.AnnVal',
987 -- 'ApiAnnotation.AnnClose' @']'@ and @'\#-}'@,
988 -- 'ApiAnnotation.AnnDcolon'
989
990 -- For details on above see note [Api annotations] in ApiAnnotation
991 | SpecSig (XSpecSig pass)
992 (Located (IdP pass)) -- Specialise a function or datatype ...
993 [LHsSigType pass] -- ... to these types
994 InlinePragma -- The pragma on SPECIALISE_INLINE form.
995 -- If it's just defaultInlinePragma, then we said
996 -- SPECIALISE, not SPECIALISE_INLINE
997
998 -- | A specialisation pragma for instance declarations only
999 --
1000 -- > {-# SPECIALISE instance Eq [Int] #-}
1001 --
1002 -- (Class tys); should be a specialisation of the
1003 -- current instance declaration
1004 --
1005 -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
1006 -- 'ApiAnnotation.AnnInstance','ApiAnnotation.AnnClose'
1007
1008 -- For details on above see note [Api annotations] in ApiAnnotation
1009 | SpecInstSig (XSpecInstSig pass) SourceText (LHsSigType pass)
1010 -- Note [Pragma source text] in BasicTypes
1011
1012 -- | A minimal complete definition pragma
1013 --
1014 -- > {-# MINIMAL a | (b, c | (d | e)) #-}
1015 --
1016 -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
1017 -- 'ApiAnnotation.AnnVbar','ApiAnnotation.AnnComma',
1018 -- 'ApiAnnotation.AnnClose'
1019
1020 -- For details on above see note [Api annotations] in ApiAnnotation
1021 | MinimalSig (XMinimalSig pass)
1022 SourceText (LBooleanFormula (Located (IdP pass)))
1023 -- Note [Pragma source text] in BasicTypes
1024
1025 -- | A "set cost centre" pragma for declarations
1026 --
1027 -- > {-# SCC funName #-}
1028 --
1029 -- or
1030 --
1031 -- > {-# SCC funName "cost_centre_name" #-}
1032
1033 | SCCFunSig (XSCCFunSig pass)
1034 SourceText -- Note [Pragma source text] in BasicTypes
1035 (Located (IdP pass)) -- Function name
1036 (Maybe (Located StringLiteral))
1037 -- | A complete match pragma
1038 --
1039 -- > {-# COMPLETE C, D [:: T] #-}
1040 --
1041 -- Used to inform the pattern match checker about additional
1042 -- complete matchings which, for example, arise from pattern
1043 -- synonym definitions.
1044 | CompleteMatchSig (XCompleteMatchSig pass)
1045 SourceText
1046 (Located [Located (IdP pass)])
1047 (Maybe (Located (IdP pass)))
1048 | XSig (XXSig pass)
1049
1050 type instance XTypeSig (GhcPass p) = NoExt
1051 type instance XPatSynSig (GhcPass p) = NoExt
1052 type instance XClassOpSig (GhcPass p) = NoExt
1053 type instance XIdSig (GhcPass p) = NoExt
1054 type instance XFixSig (GhcPass p) = NoExt
1055 type instance XInlineSig (GhcPass p) = NoExt
1056 type instance XSpecSig (GhcPass p) = NoExt
1057 type instance XSpecInstSig (GhcPass p) = NoExt
1058 type instance XMinimalSig (GhcPass p) = NoExt
1059 type instance XSCCFunSig (GhcPass p) = NoExt
1060 type instance XCompleteMatchSig (GhcPass p) = NoExt
1061 type instance XXSig (GhcPass p) = NoExt
1062
1063 -- | Located Fixity Signature
1064 type LFixitySig pass = Located (FixitySig pass)
1065
1066 -- | Fixity Signature
1067 data FixitySig pass = FixitySig (XFixitySig pass) [Located (IdP pass)] Fixity
1068 | XFixitySig (XXFixitySig pass)
1069
1070 type instance XFixitySig (GhcPass p) = NoExt
1071 type instance XXFixitySig (GhcPass p) = NoExt
1072
1073 -- | Type checker Specialisation Pragmas
1074 --
1075 -- 'TcSpecPrags' conveys @SPECIALISE@ pragmas from the type checker to the desugarer
1076 data TcSpecPrags
1077 = IsDefaultMethod -- ^ Super-specialised: a default method should
1078 -- be macro-expanded at every call site
1079 | SpecPrags [LTcSpecPrag]
1080 deriving Data
1081
1082 -- | Located Type checker Specification Pragmas
1083 type LTcSpecPrag = Located TcSpecPrag
1084
1085 -- | Type checker Specification Pragma
1086 data TcSpecPrag
1087 = SpecPrag
1088 Id
1089 HsWrapper
1090 InlinePragma
1091 -- ^ The Id to be specialised, a wrapper that specialises the
1092 -- polymorphic function, and inlining spec for the specialised function
1093 deriving Data
1094
1095 noSpecPrags :: TcSpecPrags
1096 noSpecPrags = SpecPrags []
1097
1098 hasSpecPrags :: TcSpecPrags -> Bool
1099 hasSpecPrags (SpecPrags ps) = not (null ps)
1100 hasSpecPrags IsDefaultMethod = False
1101
1102 isDefaultMethod :: TcSpecPrags -> Bool
1103 isDefaultMethod IsDefaultMethod = True
1104 isDefaultMethod (SpecPrags {}) = False
1105
1106
1107 isFixityLSig :: LSig name -> Bool
1108 isFixityLSig (L _ (FixSig {})) = True
1109 isFixityLSig _ = False
1110
1111 isTypeLSig :: LSig name -> Bool -- Type signatures
1112 isTypeLSig (L _(TypeSig {})) = True
1113 isTypeLSig (L _(ClassOpSig {})) = True
1114 isTypeLSig (L _(IdSig {})) = True
1115 isTypeLSig _ = False
1116
1117 isSpecLSig :: LSig name -> Bool
1118 isSpecLSig (L _(SpecSig {})) = True
1119 isSpecLSig _ = False
1120
1121 isSpecInstLSig :: LSig name -> Bool
1122 isSpecInstLSig (L _ (SpecInstSig {})) = True
1123 isSpecInstLSig _ = False
1124
1125 isPragLSig :: LSig name -> Bool
1126 -- Identifies pragmas
1127 isPragLSig (L _ (SpecSig {})) = True
1128 isPragLSig (L _ (InlineSig {})) = True
1129 isPragLSig (L _ (SCCFunSig {})) = True
1130 isPragLSig (L _ (CompleteMatchSig {})) = True
1131 isPragLSig _ = False
1132
1133 isInlineLSig :: LSig name -> Bool
1134 -- Identifies inline pragmas
1135 isInlineLSig (L _ (InlineSig {})) = True
1136 isInlineLSig _ = False
1137
1138 isMinimalLSig :: LSig name -> Bool
1139 isMinimalLSig (L _ (MinimalSig {})) = True
1140 isMinimalLSig _ = False
1141
1142 isSCCFunSig :: LSig name -> Bool
1143 isSCCFunSig (L _ (SCCFunSig {})) = True
1144 isSCCFunSig _ = False
1145
1146 isCompleteMatchSig :: LSig name -> Bool
1147 isCompleteMatchSig (L _ (CompleteMatchSig {} )) = True
1148 isCompleteMatchSig _ = False
1149
1150 hsSigDoc :: Sig name -> SDoc
1151 hsSigDoc (TypeSig {}) = text "type signature"
1152 hsSigDoc (PatSynSig {}) = text "pattern synonym signature"
1153 hsSigDoc (ClassOpSig _ is_deflt _ _)
1154 | is_deflt = text "default type signature"
1155 | otherwise = text "class method signature"
1156 hsSigDoc (IdSig {}) = text "id signature"
1157 hsSigDoc (SpecSig {}) = text "SPECIALISE pragma"
1158 hsSigDoc (InlineSig _ _ prag) = ppr (inlinePragmaSpec prag) <+> text "pragma"
1159 hsSigDoc (SpecInstSig {}) = text "SPECIALISE instance pragma"
1160 hsSigDoc (FixSig {}) = text "fixity declaration"
1161 hsSigDoc (MinimalSig {}) = text "MINIMAL pragma"
1162 hsSigDoc (SCCFunSig {}) = text "SCC pragma"
1163 hsSigDoc (CompleteMatchSig {}) = text "COMPLETE pragma"
1164 hsSigDoc (XSig {}) = text "XSIG TTG extension"
1165
1166 {-
1167 Check if signatures overlap; this is used when checking for duplicate
1168 signatures. Since some of the signatures contain a list of names, testing for
1169 equality is not enough -- we have to check if they overlap.
1170 -}
1171
1172 instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (Sig p) where
1173 ppr sig = ppr_sig sig
1174
1175 ppr_sig :: (OutputableBndrId (GhcPass p)) => Sig (GhcPass p) -> SDoc
1176 ppr_sig (TypeSig _ vars ty) = pprVarSig (map unLoc vars) (ppr ty)
1177 ppr_sig (ClassOpSig _ is_deflt vars ty)
1178 | is_deflt = text "default" <+> pprVarSig (map unLoc vars) (ppr ty)
1179 | otherwise = pprVarSig (map unLoc vars) (ppr ty)
1180 ppr_sig (IdSig _ id) = pprVarSig [id] (ppr (varType id))
1181 ppr_sig (FixSig _ fix_sig) = ppr fix_sig
1182 ppr_sig (SpecSig _ var ty inl@(InlinePragma { inl_inline = spec }))
1183 = pragSrcBrackets (inl_src inl) pragmaSrc (pprSpec (unLoc var)
1184 (interpp'SP ty) inl)
1185 where
1186 pragmaSrc = case spec of
1187 NoUserInline -> "{-# SPECIALISE"
1188 _ -> "{-# SPECIALISE_INLINE"
1189 ppr_sig (InlineSig _ var inl)
1190 = pragSrcBrackets (inl_src inl) "{-# INLINE" (pprInline inl
1191 <+> pprPrefixOcc (unLoc var))
1192 ppr_sig (SpecInstSig _ src ty)
1193 = pragSrcBrackets src "{-# SPECIALISE" (text "instance" <+> ppr ty)
1194 ppr_sig (MinimalSig _ src bf)
1195 = pragSrcBrackets src "{-# MINIMAL" (pprMinimalSig bf)
1196 ppr_sig (PatSynSig _ names sig_ty)
1197 = text "pattern" <+> pprVarSig (map unLoc names) (ppr sig_ty)
1198 ppr_sig (SCCFunSig _ src fn mlabel)
1199 = pragSrcBrackets src "{-# SCC" (ppr fn <+> maybe empty ppr mlabel )
1200 ppr_sig (CompleteMatchSig _ src cs mty)
1201 = pragSrcBrackets src "{-# COMPLETE"
1202 ((hsep (punctuate comma (map ppr (unLoc cs))))
1203 <+> opt_sig)
1204 where
1205 opt_sig = maybe empty ((\t -> dcolon <+> ppr t) . unLoc) mty
1206 ppr_sig (XSig x) = ppr x
1207
1208 instance (p ~ GhcPass pass, OutputableBndrId p)
1209 => Outputable (FixitySig p) where
1210 ppr (FixitySig _ names fixity) = sep [ppr fixity, pprops]
1211 where
1212 pprops = hsep $ punctuate comma (map (pprInfixOcc . unLoc) names)
1213 ppr (XFixitySig x) = ppr x
1214
1215 pragBrackets :: SDoc -> SDoc
1216 pragBrackets doc = text "{-#" <+> doc <+> text "#-}"
1217
1218 -- | Using SourceText in case the pragma was spelled differently or used mixed
1219 -- case
1220 pragSrcBrackets :: SourceText -> String -> SDoc -> SDoc
1221 pragSrcBrackets (SourceText src) _ doc = text src <+> doc <+> text "#-}"
1222 pragSrcBrackets NoSourceText alt doc = text alt <+> doc <+> text "#-}"
1223
1224 pprVarSig :: (OutputableBndr id) => [id] -> SDoc -> SDoc
1225 pprVarSig vars pp_ty = sep [pprvars <+> dcolon, nest 2 pp_ty]
1226 where
1227 pprvars = hsep $ punctuate comma (map pprPrefixOcc vars)
1228
1229 pprSpec :: (OutputableBndr id) => id -> SDoc -> InlinePragma -> SDoc
1230 pprSpec var pp_ty inl = pp_inl <+> pprVarSig [var] pp_ty
1231 where
1232 pp_inl | isDefaultInlinePragma inl = empty
1233 | otherwise = pprInline inl
1234
1235 pprTcSpecPrags :: TcSpecPrags -> SDoc
1236 pprTcSpecPrags IsDefaultMethod = text "<default method>"
1237 pprTcSpecPrags (SpecPrags ps) = vcat (map (ppr . unLoc) ps)
1238
1239 instance Outputable TcSpecPrag where
1240 ppr (SpecPrag var _ inl)
1241 = text "SPECIALIZE" <+> pprSpec var (text "<type>") inl
1242
1243 pprMinimalSig :: (OutputableBndr name)
1244 => LBooleanFormula (Located name) -> SDoc
1245 pprMinimalSig (L _ bf) = ppr (fmap unLoc bf)
1246
1247 {-
1248 ************************************************************************
1249 * *
1250 \subsection[PatSynBind]{A pattern synonym definition}
1251 * *
1252 ************************************************************************
1253 -}
1254
1255 -- | Haskell Pattern Synonym Details
1256 type HsPatSynDetails arg = HsConDetails arg [RecordPatSynField arg]
1257
1258 -- See Note [Record PatSyn Fields]
1259 -- | Record Pattern Synonym Field
1260 data RecordPatSynField a
1261 = RecordPatSynField {
1262 recordPatSynSelectorId :: a -- Selector name visible in rest of the file
1263 , recordPatSynPatVar :: a
1264 -- Filled in by renamer, the name used internally
1265 -- by the pattern
1266 } deriving Data
1267
1268
1269
1270 {-
1271 Note [Record PatSyn Fields]
1272
1273 Consider the following two pattern synonyms.
1274
1275 pattern P x y = ([x,True], [y,'v'])
1276 pattern Q{ x, y } =([x,True], [y,'v'])
1277
1278 In P, we just have two local binders, x and y.
1279
1280 In Q, we have local binders but also top-level record selectors
1281 x :: ([Bool], [Char]) -> Bool and similarly for y.
1282
1283 It would make sense to support record-like syntax
1284
1285 pattern Q{ x=x1, y=y1 } = ([x1,True], [y1,'v'])
1286
1287 when we have a different name for the local and top-level binder
1288 the distinction between the two names clear
1289
1290 -}
1291 instance Functor RecordPatSynField where
1292 fmap f (RecordPatSynField { recordPatSynSelectorId = visible
1293 , recordPatSynPatVar = hidden })
1294 = RecordPatSynField { recordPatSynSelectorId = f visible
1295 , recordPatSynPatVar = f hidden }
1296
1297 instance Outputable a => Outputable (RecordPatSynField a) where
1298 ppr (RecordPatSynField { recordPatSynSelectorId = v }) = ppr v
1299
1300 instance Foldable RecordPatSynField where
1301 foldMap f (RecordPatSynField { recordPatSynSelectorId = visible
1302 , recordPatSynPatVar = hidden })
1303 = f visible `mappend` f hidden
1304
1305 instance Traversable RecordPatSynField where
1306 traverse f (RecordPatSynField { recordPatSynSelectorId =visible
1307 , recordPatSynPatVar = hidden })
1308 = (\ sel_id pat_var -> RecordPatSynField { recordPatSynSelectorId = sel_id
1309 , recordPatSynPatVar = pat_var })
1310 <$> f visible <*> f hidden
1311
1312
1313 -- | Haskell Pattern Synonym Direction
1314 data HsPatSynDir id
1315 = Unidirectional
1316 | ImplicitBidirectional
1317 | ExplicitBidirectional (MatchGroup id (LHsExpr id))