Refactor treatment of wildcards
[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 (LHsSigWcType name) -- RHS of the signature; can have wildcards
632
633 -- | A pattern synonym type signature
634 --
635 -- > pattern Single :: () => (Show a) => a -> [a]
636 --
637 -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnPattern',
638 -- 'ApiAnnotation.AnnDcolon','ApiAnnotation.AnnForall'
639 -- 'ApiAnnotation.AnnDot','ApiAnnotation.AnnDarrow'
640
641 -- For details on above see note [Api annotations] in ApiAnnotation
642 | PatSynSig (Located name) (LHsSigType name)
643 -- P :: forall a b. Prov => Req => ty
644
645 -- | A signature for a class method
646 -- False: ordinary class-method signauure
647 -- True: default class method signature
648 -- e.g. class C a where
649 -- op :: a -> a -- Ordinary
650 -- default op :: Eq a => a -> a -- Generic default
651 -- No wildcards allowed here
652 --
653 -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDefault',
654 -- 'ApiAnnotation.AnnDcolon'
655 | ClassOpSig Bool [Located name] (LHsSigType name)
656
657 -- | A type signature in generated code, notably the code
658 -- generated for record selectors. We simply record
659 -- the desired Id itself, replete with its name, type
660 -- and IdDetails. Otherwise it's just like a type
661 -- signature: there should be an accompanying binding
662 | IdSig Id
663
664 -- | An ordinary fixity declaration
665 --
666 -- > infixl 8 ***
667 --
668 --
669 -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnInfix',
670 -- 'ApiAnnotation.AnnVal'
671
672 -- For details on above see note [Api annotations] in ApiAnnotation
673 | FixSig (FixitySig name)
674
675 -- | An inline pragma
676 --
677 -- > {#- INLINE f #-}
678 --
679 -- - 'ApiAnnotation.AnnKeywordId' :
680 -- 'ApiAnnotation.AnnOpen' @'{-\# INLINE'@ and @'['@,
681 -- 'ApiAnnotation.AnnClose','ApiAnnotation.AnnOpen',
682 -- 'ApiAnnotation.AnnVal','ApiAnnotation.AnnTilde',
683 -- 'ApiAnnotation.AnnClose'
684
685 -- For details on above see note [Api annotations] in ApiAnnotation
686 | InlineSig (Located name) -- Function name
687 InlinePragma -- Never defaultInlinePragma
688
689 -- | A specialisation pragma
690 --
691 -- > {-# SPECIALISE f :: Int -> Int #-}
692 --
693 -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
694 -- 'ApiAnnotation.AnnOpen' @'{-\# SPECIALISE'@ and @'['@,
695 -- 'ApiAnnotation.AnnTilde',
696 -- 'ApiAnnotation.AnnVal',
697 -- 'ApiAnnotation.AnnClose' @']'@ and @'\#-}'@,
698 -- 'ApiAnnotation.AnnDcolon'
699
700 -- For details on above see note [Api annotations] in ApiAnnotation
701 | SpecSig (Located name) -- Specialise a function or datatype ...
702 [LHsSigType name] -- ... to these types
703 InlinePragma -- The pragma on SPECIALISE_INLINE form.
704 -- If it's just defaultInlinePragma, then we said
705 -- SPECIALISE, not SPECIALISE_INLINE
706
707 -- | A specialisation pragma for instance declarations only
708 --
709 -- > {-# SPECIALISE instance Eq [Int] #-}
710 --
711 -- (Class tys); should be a specialisation of the
712 -- current instance declaration
713 --
714 -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
715 -- 'ApiAnnotation.AnnInstance','ApiAnnotation.AnnClose'
716
717 -- For details on above see note [Api annotations] in ApiAnnotation
718 | SpecInstSig SourceText (LHsSigType name)
719 -- Note [Pragma source text] in BasicTypes
720
721 -- | A minimal complete definition pragma
722 --
723 -- > {-# MINIMAL a | (b, c | (d | e)) #-}
724 --
725 -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
726 -- 'ApiAnnotation.AnnVbar','ApiAnnotation.AnnComma',
727 -- 'ApiAnnotation.AnnClose'
728
729 -- For details on above see note [Api annotations] in ApiAnnotation
730 | MinimalSig SourceText (LBooleanFormula (Located name))
731 -- Note [Pragma source text] in BasicTypes
732
733 deriving (Typeable)
734 deriving instance (DataId name) => Data (Sig name)
735
736
737 type LFixitySig name = Located (FixitySig name)
738 data FixitySig name = FixitySig [Located name] Fixity
739 deriving (Data, Typeable)
740
741 -- | TsSpecPrags conveys pragmas from the type checker to the desugarer
742 data TcSpecPrags
743 = IsDefaultMethod -- ^ Super-specialised: a default method should
744 -- be macro-expanded at every call site
745 | SpecPrags [LTcSpecPrag]
746 deriving (Data, Typeable)
747
748 type LTcSpecPrag = Located TcSpecPrag
749
750 data TcSpecPrag
751 = SpecPrag
752 Id
753 HsWrapper
754 InlinePragma
755 -- ^ The Id to be specialised, an wrapper that specialises the
756 -- polymorphic function, and inlining spec for the specialised function
757 deriving (Data, Typeable)
758
759 noSpecPrags :: TcSpecPrags
760 noSpecPrags = SpecPrags []
761
762 hasSpecPrags :: TcSpecPrags -> Bool
763 hasSpecPrags (SpecPrags ps) = not (null ps)
764 hasSpecPrags IsDefaultMethod = False
765
766 isDefaultMethod :: TcSpecPrags -> Bool
767 isDefaultMethod IsDefaultMethod = True
768 isDefaultMethod (SpecPrags {}) = False
769
770
771 isFixityLSig :: LSig name -> Bool
772 isFixityLSig (L _ (FixSig {})) = True
773 isFixityLSig _ = False
774
775 isVanillaLSig :: LSig name -> Bool -- User type signatures
776 -- A badly-named function, but it's part of the GHCi (used
777 -- by Haddock) so I don't want to change it gratuitously.
778 isVanillaLSig (L _(TypeSig {})) = True
779 isVanillaLSig _ = False
780
781 isTypeLSig :: LSig name -> Bool -- Type signatures
782 isTypeLSig (L _(TypeSig {})) = True
783 isTypeLSig (L _(ClassOpSig {})) = True
784 isTypeLSig (L _(IdSig {})) = True
785 isTypeLSig _ = False
786
787 isSpecLSig :: LSig name -> Bool
788 isSpecLSig (L _(SpecSig {})) = True
789 isSpecLSig _ = False
790
791 isSpecInstLSig :: LSig name -> Bool
792 isSpecInstLSig (L _ (SpecInstSig {})) = True
793 isSpecInstLSig _ = False
794
795 isPragLSig :: LSig name -> Bool
796 -- Identifies pragmas
797 isPragLSig (L _ (SpecSig {})) = True
798 isPragLSig (L _ (InlineSig {})) = True
799 isPragLSig _ = False
800
801 isInlineLSig :: LSig name -> Bool
802 -- Identifies inline pragmas
803 isInlineLSig (L _ (InlineSig {})) = True
804 isInlineLSig _ = False
805
806 isMinimalLSig :: LSig name -> Bool
807 isMinimalLSig (L _ (MinimalSig {})) = True
808 isMinimalLSig _ = False
809
810 hsSigDoc :: Sig name -> SDoc
811 hsSigDoc (TypeSig {}) = ptext (sLit "type signature")
812 hsSigDoc (PatSynSig {}) = ptext (sLit "pattern synonym signature")
813 hsSigDoc (ClassOpSig is_deflt _ _)
814 | is_deflt = ptext (sLit "default type signature")
815 | otherwise = ptext (sLit "class method 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) = pprVarSig (map unLoc vars) (ppr ty)
834 ppr_sig (ClassOpSig is_deflt vars ty)
835 | is_deflt = ptext (sLit "default") <+> pprVarSig (map unLoc vars) (ppr ty)
836 | otherwise = pprVarSig (map unLoc vars) (ppr ty)
837 ppr_sig (IdSig id) = pprVarSig [id] (ppr (varType id))
838 ppr_sig (FixSig fix_sig) = ppr fix_sig
839 ppr_sig (SpecSig var ty inl)
840 = pragBrackets (pprSpec (unLoc var) (interpp'SP ty) inl)
841 ppr_sig (InlineSig var inl) = pragBrackets (ppr inl <+> pprPrefixOcc (unLoc var))
842 ppr_sig (SpecInstSig _ ty)
843 = pragBrackets (ptext (sLit "SPECIALIZE instance") <+> ppr ty)
844 ppr_sig (MinimalSig _ bf) = pragBrackets (pprMinimalSig bf)
845 ppr_sig (PatSynSig name sig_ty)
846 = pprPatSynSig (unLoc name) False -- TODO: is_bindir
847 (pprHsForAllTvs qtvs)
848 (pprHsContextMaybe (unLoc req))
849 (pprHsContextMaybe (unLoc prov))
850 (ppr ty)
851 where
852 (qtvs, req, prov, ty) = splitLHsPatSynTy (hsSigType sig_ty)
853
854 pprPatSynSig :: (OutputableBndr name)
855 => name -> Bool -> SDoc -> Maybe SDoc -> Maybe SDoc -> SDoc -> SDoc
856 pprPatSynSig ident _is_bidir tvs req prov ty
857 = ptext (sLit "pattern") <+> pprPrefixOcc ident <+> dcolon <+>
858 tvs <+> context <+> ty
859 where
860 context = case (req, prov) of
861 (Nothing, Nothing) -> empty
862 (Nothing, Just prov) -> parens empty <+> darrow <+> prov <+> darrow
863 (Just req, Nothing) -> req <+> darrow
864 (Just req, Just prov) -> req <+> darrow <+> prov <+> darrow
865
866 instance OutputableBndr name => Outputable (FixitySig name) where
867 ppr (FixitySig names fixity) = sep [ppr fixity, pprops]
868 where
869 pprops = hsep $ punctuate comma (map (pprInfixOcc . unLoc) names)
870
871 pragBrackets :: SDoc -> SDoc
872 pragBrackets doc = ptext (sLit "{-#") <+> doc <+> ptext (sLit "#-}")
873
874 pprVarSig :: (OutputableBndr id) => [id] -> SDoc -> SDoc
875 pprVarSig vars pp_ty = sep [pprvars <+> dcolon, nest 2 pp_ty]
876 where
877 pprvars = hsep $ punctuate comma (map pprPrefixOcc vars)
878
879 pprSpec :: (OutputableBndr id) => id -> SDoc -> InlinePragma -> SDoc
880 pprSpec var pp_ty inl = ptext (sLit "SPECIALIZE") <+> pp_inl <+> pprVarSig [var] pp_ty
881 where
882 pp_inl | isDefaultInlinePragma inl = empty
883 | otherwise = ppr inl
884
885 pprTcSpecPrags :: TcSpecPrags -> SDoc
886 pprTcSpecPrags IsDefaultMethod = ptext (sLit "<default method>")
887 pprTcSpecPrags (SpecPrags ps) = vcat (map (ppr . unLoc) ps)
888
889 instance Outputable TcSpecPrag where
890 ppr (SpecPrag var _ inl) = pprSpec var (ptext (sLit "<type>")) inl
891
892 pprMinimalSig :: OutputableBndr name => LBooleanFormula (Located name) -> SDoc
893 pprMinimalSig (L _ bf) = ptext (sLit "MINIMAL") <+> ppr (fmap unLoc bf)
894
895 {-
896 ************************************************************************
897 * *
898 \subsection[PatSynBind]{A pattern synonym definition}
899 * *
900 ************************************************************************
901 -}
902
903 data HsPatSynDetails a
904 = InfixPatSyn a a
905 | PrefixPatSyn [a]
906 | RecordPatSyn [RecordPatSynField a]
907 deriving (Typeable, Data)
908
909
910 -- See Note [Record PatSyn Fields]
911 data RecordPatSynField a
912 = RecordPatSynField {
913 recordPatSynSelectorId :: a -- Selector name visible in rest of the file
914 , recordPatSynPatVar :: a
915 -- Filled in by renamer, the name used internally
916 -- by the pattern
917 } deriving (Typeable, Data)
918
919
920
921 {-
922 Note [Record PatSyn Fields]
923
924 Consider the following two pattern synonyms.
925
926 pattern P x y = ([x,True], [y,'v'])
927 pattern Q{ x, y } =([x,True], [y,'v'])
928
929 In P, we just have two local binders, x and y.
930
931 In Q, we have local binders but also top-level record selectors
932 x :: ([Bool], [Char]) -> Bool and similarly for y.
933
934 It would make sense to support record-like syntax
935
936 pattern Q{ x=x1, y=y1 } = ([x1,True], [y1,'v'])
937
938 when we have a different name for the local and top-level binder
939 the distinction between the two names clear
940
941 -}
942 instance Functor RecordPatSynField where
943 fmap f (RecordPatSynField visible hidden) =
944 RecordPatSynField (f visible) (f hidden)
945
946 instance Outputable a => Outputable (RecordPatSynField a) where
947 ppr (RecordPatSynField v _) = ppr v
948
949 instance Foldable RecordPatSynField where
950 foldMap f (RecordPatSynField visible hidden) =
951 f visible `mappend` f hidden
952
953 instance Traversable RecordPatSynField where
954 traverse f (RecordPatSynField visible hidden) =
955 RecordPatSynField <$> f visible <*> f hidden
956
957
958 instance Functor HsPatSynDetails where
959 fmap f (InfixPatSyn left right) = InfixPatSyn (f left) (f right)
960 fmap f (PrefixPatSyn args) = PrefixPatSyn (fmap f args)
961 fmap f (RecordPatSyn args) = RecordPatSyn (map (fmap f) args)
962
963 instance Foldable HsPatSynDetails where
964 foldMap f (InfixPatSyn left right) = f left `mappend` f right
965 foldMap f (PrefixPatSyn args) = foldMap f args
966 foldMap f (RecordPatSyn args) = foldMap (foldMap f) args
967
968 foldl1 f (InfixPatSyn left right) = left `f` right
969 foldl1 f (PrefixPatSyn args) = Data.List.foldl1 f args
970 foldl1 f (RecordPatSyn args) =
971 Data.List.foldl1 f (map (Data.Foldable.foldl1 f) args)
972
973 foldr1 f (InfixPatSyn left right) = left `f` right
974 foldr1 f (PrefixPatSyn args) = Data.List.foldr1 f args
975 foldr1 f (RecordPatSyn args) =
976 Data.List.foldr1 f (map (Data.Foldable.foldr1 f) args)
977
978 -- TODO: After a few more versions, we should probably use these.
979 #if __GLASGOW_HASKELL__ >= 709
980 length (InfixPatSyn _ _) = 2
981 length (PrefixPatSyn args) = Data.List.length args
982 length (RecordPatSyn args) = Data.List.length args
983
984 null (InfixPatSyn _ _) = False
985 null (PrefixPatSyn args) = Data.List.null args
986 null (RecordPatSyn args) = Data.List.null args
987
988 toList (InfixPatSyn left right) = [left, right]
989 toList (PrefixPatSyn args) = args
990 toList (RecordPatSyn args) = foldMap toList args
991 #endif
992
993 instance Traversable HsPatSynDetails where
994 traverse f (InfixPatSyn left right) = InfixPatSyn <$> f left <*> f right
995 traverse f (PrefixPatSyn args) = PrefixPatSyn <$> traverse f args
996 traverse f (RecordPatSyn args) = RecordPatSyn <$> traverse (traverse f) args
997
998 data HsPatSynDir id
999 = Unidirectional
1000 | ImplicitBidirectional
1001 | ExplicitBidirectional (MatchGroup id (LHsExpr id))
1002 deriving (Typeable)
1003 deriving instance (DataId id) => Data (HsPatSynDir id)