978d36349ade15446578d51fb59d2fd2a48cc934
[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 CPP #-}
17 {-# LANGUAGE BangPatterns #-}
18
19 module HsBinds where
20
21 import {-# SOURCE #-} HsExpr ( pprExpr, LHsExpr,
22 MatchGroup, pprFunBind,
23 GRHSs, pprPatBind )
24 import {-# SOURCE #-} HsPat ( LPat )
25
26 import PlaceHolder ( PostTc,PostRn,DataId )
27 import HsTypes
28 import PprCore ()
29 import CoreSyn
30 import TcEvidence
31 import Type
32 import Name
33 import NameSet
34 import BasicTypes
35 import Outputable
36 import SrcLoc
37 import Var
38 import Bag
39 import FastString
40 import BooleanFormula (LBooleanFormula)
41
42 import Data.Data hiding ( Fixity )
43 import Data.List
44 import Data.Ord
45 import Data.Foldable ( Foldable(..) )
46 #if __GLASGOW_HASKELL__ < 709
47 import Data.Traversable ( Traversable(..) )
48 import Data.Monoid ( mappend )
49 import Control.Applicative hiding (empty)
50 #endif
51
52 {-
53 ************************************************************************
54 * *
55 \subsection{Bindings: @BindGroup@}
56 * *
57 ************************************************************************
58
59 Global bindings (where clauses)
60 -}
61
62 -- During renaming, we need bindings where the left-hand sides
63 -- have been renamed but the the right-hand sides have not.
64 -- the ...LR datatypes are parametrized by two id types,
65 -- one for the left and one for the right.
66 -- Other than during renaming, these will be the same.
67
68 type HsLocalBinds id = HsLocalBindsLR id id
69
70 -- | Bindings in a 'let' expression
71 -- or a 'where' clause
72 data HsLocalBindsLR idL idR
73 = HsValBinds (HsValBindsLR idL idR)
74 -- There should be no pattern synonyms in the HsValBindsLR
75 -- These are *local* (not top level) bindings
76 -- The parser accepts them, however, leaving the the
77 -- renamer to report them
78
79 | HsIPBinds (HsIPBinds idR)
80
81 | EmptyLocalBinds
82 deriving (Typeable)
83
84 deriving instance (DataId idL, DataId idR)
85 => Data (HsLocalBindsLR idL idR)
86
87 type HsValBinds id = HsValBindsLR id id
88
89 -- | Value bindings (not implicit parameters)
90 -- Used for both top level and nested bindings
91 -- May contain pattern synonym bindings
92 data HsValBindsLR idL idR
93 = -- | Before renaming RHS; idR is always RdrName
94 -- Not dependency analysed
95 -- Recursive by default
96 ValBindsIn
97 (LHsBindsLR idL idR) [LSig idR]
98
99 -- | After renaming RHS; idR can be Name or Id
100 -- Dependency analysed,
101 -- later bindings in the list may depend on earlier
102 -- ones.
103 | ValBindsOut
104 [(RecFlag, LHsBinds idL)]
105 [LSig Name]
106 deriving (Typeable)
107
108 deriving instance (DataId idL, DataId idR)
109 => Data (HsValBindsLR idL idR)
110
111 type LHsBind id = LHsBindLR id id
112 type LHsBinds id = LHsBindsLR id id
113 type HsBind id = HsBindLR id id
114
115 type LHsBindsLR idL idR = Bag (LHsBindLR idL idR)
116 type LHsBindLR idL idR = Located (HsBindLR idL idR)
117
118 data HsBindLR idL idR
119 = -- | FunBind is used for both functions @f x = e@
120 -- and variables @f = \x -> e@
121 --
122 -- Reason 1: Special case for type inference: see 'TcBinds.tcMonoBinds'.
123 --
124 -- Reason 2: Instance decls can only have FunBinds, which is convenient.
125 -- If you change this, you'll need to change e.g. rnMethodBinds
126 --
127 -- But note that the form @f :: a->a = ...@
128 -- parses as a pattern binding, just like
129 -- @(f :: a -> a) = ... @
130 --
131 -- 'ApiAnnotation.AnnKeywordId's
132 --
133 -- - 'ApiAnnotation.AnnFunId', attached to each element of fun_matches
134 --
135 -- - 'ApiAnnotation.AnnEqual','ApiAnnotation.AnnWhere',
136 -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose',
137
138 -- For details on above see note [Api annotations] in ApiAnnotation
139 FunBind {
140
141 fun_id :: Located idL, -- Note [fun_id in Match] in HsExpr
142
143 fun_matches :: MatchGroup idR (LHsExpr idR), -- ^ The payload
144
145 fun_co_fn :: HsWrapper, -- ^ Coercion from the type of the MatchGroup to the type of
146 -- the Id. Example:
147 --
148 -- @
149 -- f :: Int -> forall a. a -> a
150 -- f x y = y
151 -- @
152 --
153 -- Then the MatchGroup will have type (Int -> a' -> a')
154 -- (with a free type variable a'). The coercion will take
155 -- a CoreExpr of this type and convert it to a CoreExpr of
156 -- type Int -> forall a'. a' -> a'
157 -- Notice that the coercion captures the free a'.
158
159 bind_fvs :: PostRn idL NameSet, -- ^ After the renamer, this contains
160 -- the locally-bound
161 -- free variables of this defn.
162 -- See Note [Bind free vars]
163
164
165 fun_tick :: [Tickish Id] -- ^ Ticks to put on the rhs, if any
166 }
167
168 -- | The pattern is never a simple variable;
169 -- That case is done by FunBind
170 --
171 -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnBang',
172 -- 'ApiAnnotation.AnnEqual','ApiAnnotation.AnnWhere',
173 -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose',
174
175 -- For details on above see note [Api annotations] in ApiAnnotation
176 | PatBind {
177 pat_lhs :: LPat idL,
178 pat_rhs :: GRHSs idR (LHsExpr idR),
179 pat_rhs_ty :: PostTc idR Type, -- ^ Type of the GRHSs
180 bind_fvs :: PostRn idL NameSet, -- ^ See Note [Bind free vars]
181 pat_ticks :: ([Tickish Id], [[Tickish Id]])
182 -- ^ Ticks to put on the rhs, if any, and ticks to put on
183 -- the bound variables.
184 }
185
186 -- | Dictionary binding and suchlike.
187 -- All VarBinds are introduced by the type checker
188 | VarBind {
189 var_id :: idL,
190 var_rhs :: LHsExpr idR, -- ^ Located only for consistency
191 var_inline :: Bool -- ^ True <=> inline this binding regardless
192 -- (used for implication constraints only)
193 }
194
195 | AbsBinds { -- Binds abstraction; TRANSLATION
196 abs_tvs :: [TyVar],
197 abs_ev_vars :: [EvVar], -- ^ Includes equality constraints
198
199 -- | AbsBinds only gets used when idL = idR after renaming,
200 -- but these need to be idL's for the collect... code in HsUtil
201 -- to have the right type
202 abs_exports :: [ABExport idL],
203
204 -- | Evidence bindings
205 -- Why a list? See TcInstDcls
206 -- Note [Typechecking plan for instance declarations]
207 abs_ev_binds :: [TcEvBinds],
208
209 -- | Typechecked user bindings
210 abs_binds :: LHsBinds idL
211 }
212
213 | PatSynBind (PatSynBind idL idR)
214 -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnPattern',
215 -- 'ApiAnnotation.AnnLarrow','ApiAnnotation.AnnEqual',
216 -- 'ApiAnnotation.AnnWhere'
217 -- 'ApiAnnotation.AnnOpen' @'{'@,'ApiAnnotation.AnnClose' @'}'@
218
219 -- For details on above see note [Api annotations] in ApiAnnotation
220
221 deriving (Typeable)
222 deriving instance (DataId idL, DataId idR)
223 => Data (HsBindLR idL idR)
224
225 -- Consider (AbsBinds tvs ds [(ftvs, poly_f, mono_f) binds]
226 --
227 -- Creates bindings for (polymorphic, overloaded) poly_f
228 -- in terms of monomorphic, non-overloaded mono_f
229 --
230 -- Invariants:
231 -- 1. 'binds' binds mono_f
232 -- 2. ftvs is a subset of tvs
233 -- 3. ftvs includes all tyvars free in ds
234 --
235 -- See Note [AbsBinds]
236
237 data ABExport id
238 = ABE { abe_poly :: id -- ^ Any INLINE pragmas is attached to this Id
239 , abe_mono :: id
240 , abe_wrap :: HsWrapper -- ^ See Note [AbsBinds wrappers]
241 -- Shape: (forall abs_tvs. abs_ev_vars => abe_mono) ~ abe_poly
242 , abe_prags :: TcSpecPrags -- ^ SPECIALISE pragmas
243 } deriving (Data, Typeable)
244
245 -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnPattern',
246 -- 'ApiAnnotation.AnnEqual','ApiAnnotation.AnnLarrow'
247 -- 'ApiAnnotation.AnnWhere','ApiAnnotation.AnnOpen' @'{'@,
248 -- 'ApiAnnotation.AnnClose' @'}'@,
249
250 -- For details on above see note [Api annotations] in ApiAnnotation
251 data PatSynBind idL idR
252 = PSB { psb_id :: Located idL, -- ^ Name of the pattern synonym
253 psb_fvs :: PostRn idR NameSet, -- ^ See Note [Bind free vars]
254 psb_args :: HsPatSynDetails (Located idR), -- ^ Formal parameter names
255 psb_def :: LPat idR, -- ^ Right-hand side
256 psb_dir :: HsPatSynDir idR -- ^ Directionality
257 } deriving (Typeable)
258 deriving instance (DataId idL, DataId idR)
259 => Data (PatSynBind idL idR)
260
261 {-
262 Note [AbsBinds]
263 ~~~~~~~~~~~~~~~
264 The AbsBinds constructor is used in the output of the type checker, to record
265 *typechecked* and *generalised* bindings. Consider a module M, with this
266 top-level binding
267 M.reverse [] = []
268 M.reverse (x:xs) = M.reverse xs ++ [x]
269
270 In Hindley-Milner, a recursive binding is typechecked with the *recursive* uses
271 being *monomorphic*. So after typechecking *and* desugaring we will get something
272 like this
273
274 M.reverse :: forall a. [a] -> [a]
275 = /\a. letrec
276 reverse :: [a] -> [a] = \xs -> case xs of
277 [] -> []
278 (x:xs) -> reverse xs ++ [x]
279 in reverse
280
281 Notice that 'M.reverse' is polymorphic as expected, but there is a local
282 definition for plain 'reverse' which is *monomorphic*. The type variable
283 'a' scopes over the entire letrec.
284
285 That's after desugaring. What about after type checking but before desugaring?
286 That's where AbsBinds comes in. It looks like this:
287
288 AbsBinds { abs_tvs = [a]
289 , abs_exports = [ABE { abe_poly = M.reverse :: forall a. [a] -> [a],
290 , abe_mono = reverse :: [a] -> [a]}]
291 , abs_binds = { reverse :: [a] -> [a]
292 = \xs -> case xs of
293 [] -> []
294 (x:xs) -> reverse xs ++ [x] } }
295
296 Here,
297 * abs_tvs says what type variables are abstracted over the binding group,
298 just 'a' in this case.
299 * abs_binds is the *monomorphic* bindings of the group
300 * abs_exports describes how to get the polymorphic Id 'M.reverse' from the
301 monomorphic one 'reverse'
302
303 Notice that the *original* function (the polymorphic one you thought
304 you were defining) appears in the abe_poly field of the
305 abs_exports. The bindings in abs_binds are for fresh, local, Ids with
306 a *monomorphic* Id.
307
308 If there is a group of mutually recursive functions without type
309 signatures, we get one AbsBinds with the monomorphic versions of the
310 bindings in abs_binds, and one element of abe_exports for each
311 variable bound in the mutually recursive group. This is true even for
312 pattern bindings. Example:
313 (f,g) = (\x -> x, f)
314 After type checking we get
315 AbsBinds { abs_tvs = [a]
316 , abs_exports = [ ABE { abe_poly = M.f :: forall a. a -> a
317 , abe_mono = f :: a -> a }
318 , ABE { abe_poly = M.g :: forall a. a -> a
319 , abe_mono = g :: a -> a }]
320 , abs_binds = { (f,g) = (\x -> x, f) }
321
322 Note [AbsBinds wrappers]
323 ~~~~~~~~~~~~~~~~~~~~~~~~
324 Consider
325 (f,g) = (\x.x, \y.y)
326 This ultimately desugars to something like this:
327 tup :: forall a b. (a->a, b->b)
328 tup = /\a b. (\x:a.x, \y:b.y)
329 f :: forall a. a -> a
330 f = /\a. case tup a Any of
331 (fm::a->a,gm:Any->Any) -> fm
332 ...similarly for g...
333
334 The abe_wrap field deals with impedance-matching between
335 (/\a b. case tup a b of { (f,g) -> f })
336 and the thing we really want, which may have fewer type
337 variables. The action happens in TcBinds.mkExport.
338
339 Note [Bind free vars]
340 ~~~~~~~~~~~~~~~~~~~~~
341 The bind_fvs field of FunBind and PatBind records the free variables
342 of the definition. It is used for two purposes
343
344 a) Dependency analysis prior to type checking
345 (see TcBinds.tc_group)
346
347 b) Deciding whether we can do generalisation of the binding
348 (see TcBinds.decideGeneralisationPlan)
349
350 Specifically,
351
352 * bind_fvs includes all free vars that are defined in this module
353 (including top-level things and lexically scoped type variables)
354
355 * bind_fvs excludes imported vars; this is just to keep the set smaller
356
357 * Before renaming, and after typechecking, the field is unused;
358 it's just an error thunk
359 -}
360
361 instance (OutputableBndr idL, OutputableBndr idR) => Outputable (HsLocalBindsLR idL idR) where
362 ppr (HsValBinds bs) = ppr bs
363 ppr (HsIPBinds bs) = ppr bs
364 ppr EmptyLocalBinds = empty
365
366 instance (OutputableBndr idL, OutputableBndr idR) => Outputable (HsValBindsLR idL idR) where
367 ppr (ValBindsIn binds sigs)
368 = pprDeclList (pprLHsBindsForUser binds sigs)
369
370 ppr (ValBindsOut sccs sigs)
371 = getPprStyle $ \ sty ->
372 if debugStyle sty then -- Print with sccs showing
373 vcat (map ppr sigs) $$ vcat (map ppr_scc sccs)
374 else
375 pprDeclList (pprLHsBindsForUser (unionManyBags (map snd sccs)) sigs)
376 where
377 ppr_scc (rec_flag, binds) = pp_rec rec_flag <+> pprLHsBinds binds
378 pp_rec Recursive = ptext (sLit "rec")
379 pp_rec NonRecursive = ptext (sLit "nonrec")
380
381 pprLHsBinds :: (OutputableBndr idL, OutputableBndr idR) => LHsBindsLR idL idR -> SDoc
382 pprLHsBinds binds
383 | isEmptyLHsBinds binds = empty
384 | otherwise = pprDeclList (map ppr (bagToList binds))
385
386 pprLHsBindsForUser :: (OutputableBndr idL, OutputableBndr idR, OutputableBndr id2)
387 => LHsBindsLR idL idR -> [LSig id2] -> [SDoc]
388 -- pprLHsBindsForUser is different to pprLHsBinds because
389 -- a) No braces: 'let' and 'where' include a list of HsBindGroups
390 -- and we don't want several groups of bindings each
391 -- with braces around
392 -- b) Sort by location before printing
393 -- c) Include signatures
394 pprLHsBindsForUser binds sigs
395 = map snd (sort_by_loc decls)
396 where
397
398 decls :: [(SrcSpan, SDoc)]
399 decls = [(loc, ppr sig) | L loc sig <- sigs] ++
400 [(loc, ppr bind) | L loc bind <- bagToList binds]
401
402 sort_by_loc decls = sortBy (comparing fst) decls
403
404 pprDeclList :: [SDoc] -> SDoc -- Braces with a space
405 -- Print a bunch of declarations
406 -- One could choose { d1; d2; ... }, using 'sep'
407 -- or d1
408 -- d2
409 -- ..
410 -- using vcat
411 -- At the moment we chose the latter
412 -- Also we do the 'pprDeeperList' thing.
413 pprDeclList ds = pprDeeperList vcat ds
414
415 ------------
416 emptyLocalBinds :: HsLocalBindsLR a b
417 emptyLocalBinds = EmptyLocalBinds
418
419 isEmptyLocalBinds :: HsLocalBindsLR a b -> Bool
420 isEmptyLocalBinds (HsValBinds ds) = isEmptyValBinds ds
421 isEmptyLocalBinds (HsIPBinds ds) = isEmptyIPBinds ds
422 isEmptyLocalBinds EmptyLocalBinds = True
423
424 isEmptyValBinds :: HsValBindsLR a b -> Bool
425 isEmptyValBinds (ValBindsIn ds sigs) = isEmptyLHsBinds ds && null sigs
426 isEmptyValBinds (ValBindsOut ds sigs) = null ds && null sigs
427
428 emptyValBindsIn, emptyValBindsOut :: HsValBindsLR a b
429 emptyValBindsIn = ValBindsIn emptyBag []
430 emptyValBindsOut = ValBindsOut [] []
431
432 emptyLHsBinds :: LHsBindsLR idL idR
433 emptyLHsBinds = emptyBag
434
435 isEmptyLHsBinds :: LHsBindsLR idL idR -> Bool
436 isEmptyLHsBinds = isEmptyBag
437
438 ------------
439 plusHsValBinds :: HsValBinds a -> HsValBinds a -> HsValBinds a
440 plusHsValBinds (ValBindsIn ds1 sigs1) (ValBindsIn ds2 sigs2)
441 = ValBindsIn (ds1 `unionBags` ds2) (sigs1 ++ sigs2)
442 plusHsValBinds (ValBindsOut ds1 sigs1) (ValBindsOut ds2 sigs2)
443 = ValBindsOut (ds1 ++ ds2) (sigs1 ++ sigs2)
444 plusHsValBinds _ _
445 = panic "HsBinds.plusHsValBinds"
446
447 getTypeSigNames :: HsValBinds a -> NameSet
448 -- Get the names that have a user type sig
449 getTypeSigNames (ValBindsOut _ sigs)
450 = mkNameSet [unLoc n | L _ (TypeSig names _ _) <- sigs, n <- names]
451 getTypeSigNames _
452 = panic "HsBinds.getTypeSigNames"
453
454 {-
455 What AbsBinds means
456 ~~~~~~~~~~~~~~~~~~~
457 AbsBinds tvs
458 [d1,d2]
459 [(tvs1, f1p, f1m),
460 (tvs2, f2p, f2m)]
461 BIND
462 means
463
464 f1p = /\ tvs -> \ [d1,d2] -> letrec DBINDS and BIND
465 in fm
466
467 gp = ...same again, with gm instead of fm
468
469 This is a pretty bad translation, because it duplicates all the bindings.
470 So the desugarer tries to do a better job:
471
472 fp = /\ [a,b] -> \ [d1,d2] -> case tp [a,b] [d1,d2] of
473 (fm,gm) -> fm
474 ..ditto for gp..
475
476 tp = /\ [a,b] -> \ [d1,d2] -> letrec DBINDS and BIND
477 in (fm,gm)
478 -}
479
480 instance (OutputableBndr idL, OutputableBndr idR) => Outputable (HsBindLR idL idR) where
481 ppr mbind = ppr_monobind mbind
482
483 ppr_monobind :: (OutputableBndr idL, OutputableBndr idR) => HsBindLR idL idR -> SDoc
484
485 ppr_monobind (PatBind { pat_lhs = pat, pat_rhs = grhss })
486 = pprPatBind pat grhss
487 ppr_monobind (VarBind { var_id = var, var_rhs = rhs })
488 = sep [pprBndr CaseBind var, nest 2 $ equals <+> pprExpr (unLoc rhs)]
489 ppr_monobind (FunBind { fun_id = fun,
490 fun_co_fn = wrap,
491 fun_matches = matches,
492 fun_tick = ticks })
493 = pprTicks empty (if null ticks then empty
494 else text "-- ticks = " <> ppr ticks)
495 $$ ifPprDebug (pprBndr LetBind (unLoc fun))
496 $$ pprFunBind (unLoc fun) matches
497 $$ ifPprDebug (ppr wrap)
498 ppr_monobind (PatSynBind psb) = ppr psb
499 ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars
500 , abs_exports = exports, abs_binds = val_binds
501 , abs_ev_binds = ev_binds })
502 = hang (ptext (sLit "AbsBinds") <+> brackets (interpp'SP tyvars)
503 <+> brackets (interpp'SP dictvars))
504 2 $ braces $ vcat
505 [ ptext (sLit "Exports:") <+> brackets (sep (punctuate comma (map ppr exports)))
506 , ptext (sLit "Exported types:") <+> vcat [pprBndr LetBind (abe_poly ex) | ex <- exports]
507 , ptext (sLit "Binds:") <+> pprLHsBinds val_binds
508 , ifPprDebug (ptext (sLit "Evidence:") <+> ppr ev_binds) ]
509
510 instance (OutputableBndr id) => Outputable (ABExport id) where
511 ppr (ABE { abe_wrap = wrap, abe_poly = gbl, abe_mono = lcl, abe_prags = prags })
512 = vcat [ ppr gbl <+> ptext (sLit "<=") <+> ppr lcl
513 , nest 2 (pprTcSpecPrags prags)
514 , nest 2 (ppr wrap)]
515
516 instance (OutputableBndr idL, OutputableBndr idR) => Outputable (PatSynBind idL idR) where
517 ppr (PSB{ psb_id = L _ psyn, psb_args = details, psb_def = pat, psb_dir = dir })
518 = ppr_lhs <+> ppr_rhs
519 where
520 ppr_lhs = ptext (sLit "pattern") <+> ppr_details
521 ppr_simple syntax = syntax <+> ppr pat
522
523 ppr_details = case details of
524 InfixPatSyn v1 v2 -> hsep [ppr v1, pprInfixOcc psyn, ppr v2]
525 PrefixPatSyn vs -> hsep (pprPrefixOcc psyn : map ppr vs)
526 RecordPatSyn vs ->
527 pprPrefixOcc psyn
528 <> braces (sep (punctuate comma (map ppr vs)))
529
530 ppr_rhs = case dir of
531 Unidirectional -> ppr_simple (ptext (sLit "<-"))
532 ImplicitBidirectional -> ppr_simple equals
533 ExplicitBidirectional mg -> ppr_simple (ptext (sLit "<-")) <+> ptext (sLit "where") $$
534 (nest 2 $ pprFunBind psyn mg)
535
536 pprTicks :: SDoc -> SDoc -> SDoc
537 -- Print stuff about ticks only when -dppr-debug is on, to avoid
538 -- them appearing in error messages (from the desugarer); see Trac # 3263
539 -- Also print ticks in dumpStyle, so that -ddump-hpc actually does
540 -- something useful.
541 pprTicks pp_no_debug pp_when_debug
542 = getPprStyle (\ sty -> if debugStyle sty || dumpStyle sty
543 then pp_when_debug
544 else pp_no_debug)
545
546 {-
547 ************************************************************************
548 * *
549 Implicit parameter bindings
550 * *
551 ************************************************************************
552 -}
553
554 data HsIPBinds id
555 = IPBinds
556 [LIPBind id]
557 TcEvBinds -- Only in typechecker output; binds
558 -- uses of the implicit parameters
559 deriving (Typeable)
560 deriving instance (DataId id) => Data (HsIPBinds id)
561
562 isEmptyIPBinds :: HsIPBinds id -> Bool
563 isEmptyIPBinds (IPBinds is ds) = null is && isEmptyTcEvBinds ds
564
565 type LIPBind id = Located (IPBind id)
566 -- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi' when in a
567 -- list
568
569 -- For details on above see note [Api annotations] in ApiAnnotation
570
571 -- | Implicit parameter bindings.
572 --
573 -- These bindings start off as (Left "x") in the parser and stay
574 -- that way until after type-checking when they are replaced with
575 -- (Right d), where "d" is the name of the dictionary holding the
576 -- evidence for the implicit parameter.
577 --
578 -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnEqual'
579
580 -- For details on above see note [Api annotations] in ApiAnnotation
581 data IPBind id
582 = IPBind (Either (Located HsIPName) id) (LHsExpr id)
583 deriving (Typeable)
584 deriving instance (DataId name) => Data (IPBind name)
585
586 instance (OutputableBndr id) => Outputable (HsIPBinds id) where
587 ppr (IPBinds bs ds) = pprDeeperList vcat (map ppr bs)
588 $$ ifPprDebug (ppr ds)
589
590 instance (OutputableBndr id) => Outputable (IPBind id) where
591 ppr (IPBind lr rhs) = name <+> equals <+> pprExpr (unLoc rhs)
592 where name = case lr of
593 Left (L _ ip) -> pprBndr LetBind ip
594 Right id -> pprBndr LetBind id
595
596 {-
597 ************************************************************************
598 * *
599 \subsection{@Sig@: type signatures and value-modifying user pragmas}
600 * *
601 ************************************************************************
602
603 It is convenient to lump ``value-modifying'' user-pragmas (e.g.,
604 ``specialise this function to these four types...'') in with type
605 signatures. Then all the machinery to move them into place, etc.,
606 serves for both.
607 -}
608
609 type LSig name = Located (Sig name)
610
611 -- | Signatures and pragmas
612 data Sig name
613 = -- | An ordinary type signature
614 --
615 -- > f :: Num a => a -> a
616 --
617 -- After renaming, this list of Names contains the named and unnamed
618 -- wildcards brought into scope by this signature. For a signature
619 -- @_ -> _a -> Bool@, the renamer will give the unnamed wildcard @_@
620 -- a freshly generated name, e.g. @_w@. @_w@ and the named wildcard @_a@
621 -- are then both replaced with fresh meta vars in the type. Their names
622 -- are stored in the type signature that brought them into scope, in
623 -- this third field to be more specific.
624 --
625 -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon',
626 -- 'ApiAnnotation.AnnComma'
627
628 -- For details on above see note [Api annotations] in ApiAnnotation
629 TypeSig
630 [Located name] -- LHS of the signature; e.g. f,g,h :: blah
631 (LHsType name) -- RHS of the signature
632 (PostRn name [Name]) -- Wildcards (both named and anonymous) of the RHS
633
634 -- | A pattern synonym type signature
635 --
636 -- > pattern Single :: () => (Show a) => a -> [a]
637 --
638 -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnPattern',
639 -- 'ApiAnnotation.AnnDcolon','ApiAnnotation.AnnForall'
640 -- 'ApiAnnotation.AnnDot','ApiAnnotation.AnnDarrow'
641
642 -- For details on above see note [Api annotations] in ApiAnnotation
643 | PatSynSig (Located name)
644 (HsExplicitFlag, LHsTyVarBndrs name)
645 (LHsContext name) -- Required context
646 (LHsContext name) -- Provided context
647 (LHsType name)
648
649 -- | A type signature for a default method inside a class
650 --
651 -- > default eq :: (Representable0 a, GEq (Rep0 a)) => a -> a -> Bool
652 --
653 -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDefault',
654 -- 'ApiAnnotation.AnnDcolon'
655
656 -- For details on above see note [Api annotations] in ApiAnnotation
657 | GenericSig [Located name] (LHsType name)
658
659 -- | A type signature in generated code, notably the code
660 -- generated for record selectors. We simply record
661 -- the desired Id itself, replete with its name, type
662 -- and IdDetails. Otherwise it's just like a type
663 -- signature: there should be an accompanying binding
664 | IdSig Id
665
666 -- | An ordinary fixity declaration
667 --
668 -- > infixl 8 ***
669 --
670 --
671 -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnInfix',
672 -- 'ApiAnnotation.AnnVal'
673
674 -- For details on above see note [Api annotations] in ApiAnnotation
675 | FixSig (FixitySig name)
676
677 -- | An inline pragma
678 --
679 -- > {#- INLINE f #-}
680 --
681 -- - 'ApiAnnotation.AnnKeywordId' :
682 -- 'ApiAnnotation.AnnOpen' @'{-\# INLINE'@ and @'['@,
683 -- 'ApiAnnotation.AnnClose','ApiAnnotation.AnnOpen',
684 -- 'ApiAnnotation.AnnVal','ApiAnnotation.AnnTilde',
685 -- 'ApiAnnotation.AnnClose'
686
687 -- For details on above see note [Api annotations] in ApiAnnotation
688 | InlineSig (Located name) -- Function name
689 InlinePragma -- Never defaultInlinePragma
690
691 -- | A specialisation pragma
692 --
693 -- > {-# SPECIALISE f :: Int -> Int #-}
694 --
695 -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
696 -- 'ApiAnnotation.AnnOpen' @'{-\# SPECIALISE'@ and @'['@,
697 -- 'ApiAnnotation.AnnTilde',
698 -- 'ApiAnnotation.AnnVal',
699 -- 'ApiAnnotation.AnnClose' @']'@ and @'\#-}'@,
700 -- 'ApiAnnotation.AnnDcolon'
701
702 -- For details on above see note [Api annotations] in ApiAnnotation
703 | SpecSig (Located name) -- Specialise a function or datatype ...
704 [LHsType name] -- ... to these types
705 InlinePragma -- The pragma on SPECIALISE_INLINE form.
706 -- If it's just defaultInlinePragma, then we said
707 -- SPECIALISE, not SPECIALISE_INLINE
708
709 -- | A specialisation pragma for instance declarations only
710 --
711 -- > {-# SPECIALISE instance Eq [Int] #-}
712 --
713 -- (Class tys); should be a specialisation of the
714 -- current instance declaration
715 --
716 -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
717 -- 'ApiAnnotation.AnnInstance','ApiAnnotation.AnnClose'
718
719 -- For details on above see note [Api annotations] in ApiAnnotation
720 | SpecInstSig SourceText (LHsType name)
721 -- Note [Pragma source text] in BasicTypes
722
723 -- | A minimal complete definition pragma
724 --
725 -- > {-# MINIMAL a | (b, c | (d | e)) #-}
726 --
727 -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
728 -- 'ApiAnnotation.AnnVbar','ApiAnnotation.AnnComma',
729 -- 'ApiAnnotation.AnnClose'
730
731 -- For details on above see note [Api annotations] in ApiAnnotation
732 | MinimalSig SourceText (LBooleanFormula (Located name))
733 -- Note [Pragma source text] in BasicTypes
734
735 deriving (Typeable)
736 deriving instance (DataId name) => Data (Sig name)
737
738
739 type LFixitySig name = Located (FixitySig name)
740 data FixitySig name = FixitySig [Located name] Fixity
741 deriving (Data, Typeable)
742
743 -- | TsSpecPrags conveys pragmas from the type checker to the desugarer
744 data TcSpecPrags
745 = IsDefaultMethod -- ^ Super-specialised: a default method should
746 -- be macro-expanded at every call site
747 | SpecPrags [LTcSpecPrag]
748 deriving (Data, Typeable)
749
750 type LTcSpecPrag = Located TcSpecPrag
751
752 data TcSpecPrag
753 = SpecPrag
754 Id
755 HsWrapper
756 InlinePragma
757 -- ^ The Id to be specialised, an wrapper that specialises the
758 -- polymorphic function, and inlining spec for the specialised function
759 deriving (Data, Typeable)
760
761 noSpecPrags :: TcSpecPrags
762 noSpecPrags = SpecPrags []
763
764 hasSpecPrags :: TcSpecPrags -> Bool
765 hasSpecPrags (SpecPrags ps) = not (null ps)
766 hasSpecPrags IsDefaultMethod = False
767
768 isDefaultMethod :: TcSpecPrags -> Bool
769 isDefaultMethod IsDefaultMethod = True
770 isDefaultMethod (SpecPrags {}) = False
771
772
773 isFixityLSig :: LSig name -> Bool
774 isFixityLSig (L _ (FixSig {})) = True
775 isFixityLSig _ = False
776
777 isVanillaLSig :: LSig name -> Bool -- User type signatures
778 -- A badly-named function, but it's part of the GHCi (used
779 -- by Haddock) so I don't want to change it gratuitously.
780 isVanillaLSig (L _(TypeSig {})) = True
781 isVanillaLSig _ = False
782
783 isTypeLSig :: LSig name -> Bool -- Type signatures
784 isTypeLSig (L _(TypeSig {})) = True
785 isTypeLSig (L _(GenericSig {})) = True
786 isTypeLSig (L _(IdSig {})) = True
787 isTypeLSig _ = False
788
789 isSpecLSig :: LSig name -> Bool
790 isSpecLSig (L _(SpecSig {})) = True
791 isSpecLSig _ = False
792
793 isSpecInstLSig :: LSig name -> Bool
794 isSpecInstLSig (L _ (SpecInstSig {})) = True
795 isSpecInstLSig _ = False
796
797 isPragLSig :: LSig name -> Bool
798 -- Identifies pragmas
799 isPragLSig (L _ (SpecSig {})) = True
800 isPragLSig (L _ (InlineSig {})) = True
801 isPragLSig _ = False
802
803 isInlineLSig :: LSig name -> Bool
804 -- Identifies inline pragmas
805 isInlineLSig (L _ (InlineSig {})) = True
806 isInlineLSig _ = False
807
808 isMinimalLSig :: LSig name -> Bool
809 isMinimalLSig (L _ (MinimalSig {})) = True
810 isMinimalLSig _ = False
811
812 hsSigDoc :: Sig name -> SDoc
813 hsSigDoc (TypeSig {}) = ptext (sLit "type signature")
814 hsSigDoc (PatSynSig {}) = ptext (sLit "pattern synonym signature")
815 hsSigDoc (GenericSig {}) = ptext (sLit "default type signature")
816 hsSigDoc (IdSig {}) = ptext (sLit "id signature")
817 hsSigDoc (SpecSig {}) = ptext (sLit "SPECIALISE pragma")
818 hsSigDoc (InlineSig _ prag) = ppr (inlinePragmaSpec prag) <+> ptext (sLit "pragma")
819 hsSigDoc (SpecInstSig {}) = ptext (sLit "SPECIALISE instance pragma")
820 hsSigDoc (FixSig {}) = ptext (sLit "fixity declaration")
821 hsSigDoc (MinimalSig {}) = ptext (sLit "MINIMAL pragma")
822
823 {-
824 Check if signatures overlap; this is used when checking for duplicate
825 signatures. Since some of the signatures contain a list of names, testing for
826 equality is not enough -- we have to check if they overlap.
827 -}
828
829 instance (OutputableBndr name) => Outputable (Sig name) where
830 ppr sig = ppr_sig sig
831
832 ppr_sig :: OutputableBndr name => Sig name -> SDoc
833 ppr_sig (TypeSig vars ty _wcs) = pprVarSig (map unLoc vars) (ppr ty)
834 ppr_sig (GenericSig vars ty) = ptext (sLit "default") <+> pprVarSig (map unLoc vars) (ppr ty)
835 ppr_sig (IdSig id) = pprVarSig [id] (ppr (varType id))
836 ppr_sig (FixSig fix_sig) = ppr fix_sig
837 ppr_sig (SpecSig var ty inl)
838 = pragBrackets (pprSpec (unLoc var) (interpp'SP ty) inl)
839 ppr_sig (InlineSig var inl) = pragBrackets (ppr inl <+> pprPrefixOcc (unLoc var))
840 ppr_sig (SpecInstSig _ ty)
841 = pragBrackets (ptext (sLit "SPECIALIZE instance") <+> ppr ty)
842 ppr_sig (MinimalSig _ bf) = pragBrackets (pprMinimalSig bf)
843 ppr_sig (PatSynSig name (flag, qtvs) (L _ req) (L _ prov) ty)
844 = pprPatSynSig (unLoc name) False -- TODO: is_bindir
845 (pprHsForAll flag qtvs (noLoc []))
846 (pprHsContextMaybe req) (pprHsContextMaybe prov)
847 (ppr ty)
848
849 pprPatSynSig :: (OutputableBndr name)
850 => name -> Bool -> SDoc -> Maybe SDoc -> Maybe SDoc -> SDoc -> SDoc
851 pprPatSynSig ident _is_bidir tvs req prov ty
852 = ptext (sLit "pattern") <+> pprPrefixOcc ident <+> dcolon <+>
853 tvs <+> context <+> ty
854 where
855 context = case (req, prov) of
856 (Nothing, Nothing) -> empty
857 (Nothing, Just prov) -> parens empty <+> darrow <+> prov <+> darrow
858 (Just req, Nothing) -> req <+> darrow
859 (Just req, Just prov) -> req <+> darrow <+> prov <+> darrow
860
861 instance OutputableBndr name => Outputable (FixitySig name) where
862 ppr (FixitySig names fixity) = sep [ppr fixity, pprops]
863 where
864 pprops = hsep $ punctuate comma (map (pprInfixOcc . unLoc) names)
865
866 pragBrackets :: SDoc -> SDoc
867 pragBrackets doc = ptext (sLit "{-#") <+> doc <+> ptext (sLit "#-}")
868
869 pprVarSig :: (OutputableBndr id) => [id] -> SDoc -> SDoc
870 pprVarSig vars pp_ty = sep [pprvars <+> dcolon, nest 2 pp_ty]
871 where
872 pprvars = hsep $ punctuate comma (map pprPrefixOcc vars)
873
874 pprSpec :: (OutputableBndr id) => id -> SDoc -> InlinePragma -> SDoc
875 pprSpec var pp_ty inl = ptext (sLit "SPECIALIZE") <+> pp_inl <+> pprVarSig [var] pp_ty
876 where
877 pp_inl | isDefaultInlinePragma inl = empty
878 | otherwise = ppr inl
879
880 pprTcSpecPrags :: TcSpecPrags -> SDoc
881 pprTcSpecPrags IsDefaultMethod = ptext (sLit "<default method>")
882 pprTcSpecPrags (SpecPrags ps) = vcat (map (ppr . unLoc) ps)
883
884 instance Outputable TcSpecPrag where
885 ppr (SpecPrag var _ inl) = pprSpec var (ptext (sLit "<type>")) inl
886
887 pprMinimalSig :: OutputableBndr name => LBooleanFormula (Located name) -> SDoc
888 pprMinimalSig (L _ bf) = ptext (sLit "MINIMAL") <+> ppr (fmap unLoc bf)
889
890 {-
891 ************************************************************************
892 * *
893 \subsection[PatSynBind]{A pattern synonym definition}
894 * *
895 ************************************************************************
896 -}
897
898 data HsPatSynDetails a
899 = InfixPatSyn a a
900 | PrefixPatSyn [a]
901 | RecordPatSyn [RecordPatSynField a]
902 deriving (Typeable, Data)
903
904
905 -- See Note [Record PatSyn Fields]
906 data RecordPatSynField a
907 = RecordPatSynField {
908 recordPatSynSelectorId :: a -- Selector name visible in rest of the file
909 , recordPatSynPatVar :: a
910 -- Filled in by renamer, the name used internally
911 -- by the pattern
912 } deriving (Typeable, Data)
913
914
915
916 {-
917 Note [Record PatSyn Fields]
918
919 Consider the following two pattern synonyms.
920
921 pattern P x y = ([x,True], [y,'v'])
922 pattern Q{ x, y } =([x,True], [y,'v'])
923
924 In P, we just have two local binders, x and y.
925
926 In Q, we have local binders but also top-level record selectors
927 x :: ([Bool], [Char]) -> Bool and similarly for y.
928
929 It would make sense to support record-like syntax
930
931 pattern Q{ x=x1, y=y1 } = ([x1,True], [y1,'v'])
932
933 when we have a different name for the local and top-level binder
934 the distinction between the two names clear
935
936 -}
937 instance Functor RecordPatSynField where
938 fmap f (RecordPatSynField visible hidden) =
939 RecordPatSynField (f visible) (f hidden)
940
941 instance Outputable a => Outputable (RecordPatSynField a) where
942 ppr (RecordPatSynField v _) = ppr v
943
944 instance Foldable RecordPatSynField where
945 foldMap f (RecordPatSynField visible hidden) =
946 f visible `mappend` f hidden
947
948 instance Traversable RecordPatSynField where
949 traverse f (RecordPatSynField visible hidden) =
950 RecordPatSynField <$> f visible <*> f hidden
951
952
953 instance Functor HsPatSynDetails where
954 fmap f (InfixPatSyn left right) = InfixPatSyn (f left) (f right)
955 fmap f (PrefixPatSyn args) = PrefixPatSyn (fmap f args)
956 fmap f (RecordPatSyn args) = RecordPatSyn (map (fmap f) args)
957
958 instance Foldable HsPatSynDetails where
959 foldMap f (InfixPatSyn left right) = f left `mappend` f right
960 foldMap f (PrefixPatSyn args) = foldMap f args
961 foldMap f (RecordPatSyn args) = foldMap (foldMap f) args
962
963 foldl1 f (InfixPatSyn left right) = left `f` right
964 foldl1 f (PrefixPatSyn args) = Data.List.foldl1 f args
965 foldl1 f (RecordPatSyn args) =
966 Data.List.foldl1 f (map (Data.Foldable.foldl1 f) args)
967
968 foldr1 f (InfixPatSyn left right) = left `f` right
969 foldr1 f (PrefixPatSyn args) = Data.List.foldr1 f args
970 foldr1 f (RecordPatSyn args) =
971 Data.List.foldr1 f (map (Data.Foldable.foldr1 f) args)
972
973 -- TODO: After a few more versions, we should probably use these.
974 #if __GLASGOW_HASKELL__ >= 709
975 length (InfixPatSyn _ _) = 2
976 length (PrefixPatSyn args) = Data.List.length args
977 length (RecordPatSyn args) = Data.List.length args
978
979 null (InfixPatSyn _ _) = False
980 null (PrefixPatSyn args) = Data.List.null args
981 null (RecordPatSyn args) = Data.List.null args
982
983 toList (InfixPatSyn left right) = [left, right]
984 toList (PrefixPatSyn args) = args
985 toList (RecordPatSyn args) = foldMap toList args
986 #endif
987
988 instance Traversable HsPatSynDetails where
989 traverse f (InfixPatSyn left right) = InfixPatSyn <$> f left <*> f right
990 traverse f (PrefixPatSyn args) = PrefixPatSyn <$> traverse f args
991 traverse f (RecordPatSyn args) = RecordPatSyn <$> traverse (traverse f) args
992
993 data HsPatSynDir id
994 = Unidirectional
995 | ImplicitBidirectional
996 | ExplicitBidirectional (MatchGroup id (LHsExpr id))
997 deriving (Typeable)
998 deriving instance (DataId id) => Data (HsPatSynDir id)