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