Revert "Refactor CallStack defaulting slightly"
[ghc.git] / compiler / typecheck / TcSigs.hs
1 {-
2 (c) The University of Glasgow 2006-2012
3 (c) The GRASP Project, Glasgow University, 1992-2002
4
5 -}
6
7 {-# LANGUAGE CPP #-}
8
9 module TcSigs(
10 TcSigInfo(..),
11 TcIdSigInfo(..), TcIdSigInst,
12 TcPatSynInfo(..),
13 TcSigFun,
14
15 isPartialSig, noCompleteSig, tcIdSigName, tcSigInfoName,
16 completeSigPolyId_maybe,
17
18 tcTySigs, tcUserTypeSig, completeSigFromId,
19 tcInstSig,
20
21 TcPragEnv, emptyPragEnv, lookupPragEnv, extendPragEnv,
22 mkPragEnv, tcSpecPrags, tcSpecWrapper, tcImpPrags, addInlinePrags
23 ) where
24
25 #include "HsVersions.h"
26
27 import HsSyn
28 import TcHsType
29 import TcRnTypes
30 import TcRnMonad
31 import TcType
32 import TcMType
33 import TcUnify( tcSkolemise, unifyType, noThing )
34 import Inst( topInstantiate )
35 import TcEnv( tcLookupId )
36 import TcEvidence( HsWrapper, (<.>) )
37 import Type( mkTyVarBinders )
38
39 import DynFlags
40 import Var ( TyVar, tyVarName, tyVarKind )
41 import Id ( Id, idName, idType, idInlinePragma, setInlinePragma, mkLocalId )
42 import PrelNames( mkUnboundName )
43 import BasicTypes
44 import Bag( foldrBag )
45 import Module( getModule )
46 import Name
47 import NameEnv
48 import VarSet
49 import Outputable
50 import SrcLoc
51 import Util( singleton )
52 import Maybes( orElse )
53 import Data.Maybe( mapMaybe )
54 import Control.Monad( unless )
55
56
57 {- -------------------------------------------------------------
58 Note [Overview of type signatures]
59 ----------------------------------------------------------------
60 Type signatures, including partial signatures, are jolly tricky,
61 especially on value bindings. Here's an overview.
62
63 f :: forall a. [a] -> [a]
64 g :: forall b. _ -> b
65
66 f = ...g...
67 g = ...f...
68
69 * HsSyn: a signature in a binding starts of as a TypeSig, in
70 type HsBinds.Sig
71
72 * When starting a mutually recursive group, like f/g above, we
73 call tcTySig on each signature in the group.
74
75 * tcTySig: Sig -> TcIdSigInfo
76 - For a /complete/ signature, like 'f' above, tcTySig kind-checks
77 the HsType, producing a Type, and wraps it in a CompleteSig, and
78 extend the type environment with this polymorphic 'f'.
79
80 - For a /partial/signauture, like 'g' above, tcTySig does nothing
81 Instead it just wraps the pieces in a PartialSig, to be handled
82 later.
83
84 * tcInstSig: TcIdSigInfo -> TcIdSigInst
85 In tcMonoBinds, when looking at an individual binding, we use
86 tcInstSig to instantiate the signature forall's in the signature,
87 and attribute that instantiated (monomorphic) type to the
88 binder. You can see this in TcBinds.tcLhsId.
89
90 The instantiation does the obvious thing for complete signatures,
91 but for /partial/ signatures it starts from the HsSyn, so it
92 has to kind-check it etc: tcHsPartialSigType. It's convenient
93 to do this at the same time as instantiation, because we can
94 make the wildcards into unification variables right away, raather
95 than somehow quantifying over them. And the "TcLevel" of those
96 unification variables is correct because we are in tcMonoBinds.
97
98
99 Note [Scoped tyvars]
100 ~~~~~~~~~~~~~~~~~~~~
101 The -XScopedTypeVariables flag brings lexically-scoped type variables
102 into scope for any explicitly forall-quantified type variables:
103 f :: forall a. a -> a
104 f x = e
105 Then 'a' is in scope inside 'e'.
106
107 However, we do *not* support this
108 - For pattern bindings e.g
109 f :: forall a. a->a
110 (f,g) = e
111
112 Note [Binding scoped type variables]
113 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
114 The type variables *brought into lexical scope* by a type signature
115 may be a subset of the *quantified type variables* of the signatures,
116 for two reasons:
117
118 * With kind polymorphism a signature like
119 f :: forall f a. f a -> f a
120 may actually give rise to
121 f :: forall k. forall (f::k -> *) (a:k). f a -> f a
122 So the sig_tvs will be [k,f,a], but only f,a are scoped.
123 NB: the scoped ones are not necessarily the *inital* ones!
124
125 * Even aside from kind polymorphism, there may be more instantiated
126 type variables than lexically-scoped ones. For example:
127 type T a = forall b. b -> (a,b)
128 f :: forall c. T c
129 Here, the signature for f will have one scoped type variable, c,
130 but two instantiated type variables, c' and b'.
131
132 However, all of this only applies to the renamer. The typechecker
133 just puts all of them into the type environment; any lexical-scope
134 errors were dealt with by the renamer.
135
136 -}
137
138
139 {- *********************************************************************
140 * *
141 Utility functions for TcSigInfo
142 * *
143 ********************************************************************* -}
144
145 type TcSigFun = Name -> Maybe TcSigInfo
146
147 -- | No signature or a partial signature
148 noCompleteSig :: Maybe TcSigInfo -> Bool
149 noCompleteSig (Just (TcIdSig (CompleteSig {}))) = False
150 noCompleteSig _ = True
151
152 tcIdSigName :: TcIdSigInfo -> Name
153 tcIdSigName (CompleteSig { sig_bndr = id }) = idName id
154 tcIdSigName (PartialSig { psig_name = n }) = n
155
156 tcSigInfoName :: TcSigInfo -> Name
157 tcSigInfoName (TcIdSig idsi) = tcIdSigName idsi
158 tcSigInfoName (TcPatSynSig tpsi) = patsig_name tpsi
159
160 completeSigPolyId_maybe :: TcSigInfo -> Maybe TcId
161 completeSigPolyId_maybe sig
162 | TcIdSig sig_info <- sig
163 , CompleteSig { sig_bndr = id } <- sig_info = Just id
164 | otherwise = Nothing
165
166
167 {- *********************************************************************
168 * *
169 Typechecking user signatures
170 * *
171 ********************************************************************* -}
172
173 tcTySigs :: [LSig Name] -> TcM ([TcId], TcSigFun)
174 tcTySigs hs_sigs
175 = checkNoErrs $ -- See Note [Fail eagerly on bad signatures]
176 do { ty_sigs_s <- mapAndRecoverM tcTySig hs_sigs
177 ; let ty_sigs = concat ty_sigs_s
178 poly_ids = mapMaybe completeSigPolyId_maybe ty_sigs
179 -- The returned [TcId] are the ones for which we have
180 -- a complete type signature.
181 -- See Note [Complete and partial type signatures]
182 env = mkNameEnv [(tcSigInfoName sig, sig) | sig <- ty_sigs]
183 ; return (poly_ids, lookupNameEnv env) }
184
185 tcTySig :: LSig Name -> TcM [TcSigInfo]
186 tcTySig (L _ (IdSig id))
187 = do { let ctxt = FunSigCtxt (idName id) False
188 -- False: do not report redundant constraints
189 -- The user has no control over the signature!
190 sig = completeSigFromId ctxt id
191 ; return [TcIdSig sig] }
192
193 tcTySig (L loc (TypeSig names sig_ty))
194 = setSrcSpan loc $
195 do { sigs <- sequence [ tcUserTypeSig loc sig_ty (Just name)
196 | L _ name <- names ]
197 ; return (map TcIdSig sigs) }
198
199 tcTySig (L loc (PatSynSig names sig_ty))
200 = setSrcSpan loc $
201 do { tpsigs <- sequence [ tcPatSynSig name sig_ty
202 | L _ name <- names ]
203 ; return (map TcPatSynSig tpsigs) }
204
205 tcTySig _ = return []
206
207
208 tcUserTypeSig :: SrcSpan -> LHsSigWcType Name -> Maybe Name -> TcM TcIdSigInfo
209 -- A function or expression type signature
210 -- Returns a fully quantified type signature; even the wildcards
211 -- are quantified with ordinary skolems that should be instantiated
212 --
213 -- The SrcSpan is what to declare as the binding site of the
214 -- any skolems in the signature. For function signatures we
215 -- use the whole `f :: ty' signature; for expression signatures
216 -- just the type part.
217 --
218 -- Just n => Function type signature name :: type
219 -- Nothing => Expression type signature <expr> :: type
220 tcUserTypeSig loc hs_sig_ty mb_name
221 | isCompleteHsSig hs_sig_ty
222 = do { sigma_ty <- tcHsSigWcType ctxt_F hs_sig_ty
223 ; return $
224 CompleteSig { sig_bndr = mkLocalId name sigma_ty
225 , sig_ctxt = ctxt_T
226 , sig_loc = loc } }
227 -- Location of the <type> in f :: <type>
228
229 -- Partial sig with wildcards
230 | otherwise
231 = return (PartialSig { psig_name = name, psig_hs_ty = hs_sig_ty
232 , sig_ctxt = ctxt_F, sig_loc = loc })
233 where
234 name = case mb_name of
235 Just n -> n
236 Nothing -> mkUnboundName (mkVarOcc "<expression>")
237 ctxt_F = case mb_name of
238 Just n -> FunSigCtxt n False
239 Nothing -> ExprSigCtxt
240 ctxt_T = case mb_name of
241 Just n -> FunSigCtxt n True
242 Nothing -> ExprSigCtxt
243
244
245
246 completeSigFromId :: UserTypeCtxt -> Id -> TcIdSigInfo
247 -- Used for instance methods and record selectors
248 completeSigFromId ctxt id
249 = CompleteSig { sig_bndr = id
250 , sig_ctxt = ctxt
251 , sig_loc = getSrcSpan id }
252
253 isCompleteHsSig :: LHsSigWcType Name -> Bool
254 -- ^ If there are no wildcards, return a LHsSigType
255 isCompleteHsSig (HsWC { hswc_wcs = wcs }) = null wcs
256
257 {- Note [Fail eagerly on bad signatures]
258 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
259 If a type signaure is wrong, fail immediately:
260
261 * the type sigs may bind type variables, so proceeding without them
262 can lead to a cascade of errors
263
264 * the type signature might be ambiguous, in which case checking
265 the code against the signature will give a very similar error
266 to the ambiguity error.
267
268 ToDo: this means we fall over if any type sig
269 is wrong (eg at the top level of the module),
270 which is over-conservative
271 -}
272
273 {- *********************************************************************
274 * *
275 Type checking a pattern synonym signature
276 * *
277 ************************************************************************
278
279 Note [Pattern synonym signatures]
280 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
281 Pattern synonym signatures are surprisingly tricky (see Trac #11224 for example).
282 In general they look like this:
283
284 pattern P :: forall univ_tvs. req_theta
285 => forall ex_tvs. prov_theta
286 => arg1 -> .. -> argn -> res_ty
287
288 For parsing and renaming we treat the signature as an ordinary LHsSigType.
289
290 Once we get to type checking, we decompose it into its parts, in tcPatSynSig.
291
292 * Note that 'forall univ_tvs' and 'req_theta =>'
293 and 'forall ex_tvs' and 'prov_theta =>'
294 are all optional. We gather the pieces at the the top of tcPatSynSig
295
296 * Initially the implicitly-bound tyvars (added by the renamer) include both
297 universal and existential vars.
298
299 * After we kind-check the pieces and convert to Types, we do kind generalisation.
300
301 Note [The pattern-synonym signature splitting rule]
302 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
303 Given a pattern signature, we must split
304 the kind-generalised variables, and
305 the implicitly-bound variables
306 into universal and existential. The rule is this
307 (see discussion on Trac #11224):
308
309 The universal tyvars are the ones mentioned in
310 - univ_tvs: the user-specified (forall'd) universals
311 - req_theta
312 - res_ty
313 The existential tyvars are all the rest
314
315 For example
316
317 pattern P :: () => b -> T a
318 pattern P x = ...
319
320 Here 'a' is universal, and 'b' is existential. But there is a wrinkle:
321 how do we split the arg_tys from req_ty? Consider
322
323 pattern Q :: () => b -> S c -> T a
324 pattern Q x = ...
325
326 This is an odd example because Q has only one syntactic argument, and
327 so presumably is defined by a view pattern matching a function. But
328 it can happen (Trac #11977, #12108).
329
330 We don't know Q's arity from the pattern signature, so we have to wait
331 until we see the pattern declaration itself before deciding res_ty is,
332 and hence which variables are existential and which are universal.
333
334 And that in turn is why TcPatSynInfo has a separate field,
335 patsig_implicit_bndrs, to capture the implicitly bound type variables,
336 because we don't yet know how to split them up.
337
338 It's a slight compromise, because it means we don't really know the
339 pattern synonym's real signature until we see its declaration. So,
340 for example, in hs-boot file, we may need to think what to do...
341 (eg don't have any implicitly-bound variables).
342 -}
343
344 tcPatSynSig :: Name -> LHsSigType Name -> TcM TcPatSynInfo
345 tcPatSynSig name sig_ty
346 | HsIB { hsib_vars = implicit_hs_tvs
347 , hsib_body = hs_ty } <- sig_ty
348 , (univ_hs_tvs, hs_req, hs_ty1) <- splitLHsSigmaTy hs_ty
349 , (ex_hs_tvs, hs_prov, hs_body_ty) <- splitLHsSigmaTy hs_ty1
350 = do { (implicit_tvs, (univ_tvs, req, ex_tvs, prov, body_ty))
351 <- solveEqualities $
352 tcImplicitTKBndrs implicit_hs_tvs $
353 tcExplicitTKBndrs univ_hs_tvs $ \ univ_tvs ->
354 tcExplicitTKBndrs ex_hs_tvs $ \ ex_tvs ->
355 do { req <- tcHsContext hs_req
356 ; prov <- tcHsContext hs_prov
357 ; body_ty <- tcHsOpenType hs_body_ty
358 -- A (literal) pattern can be unlifted;
359 -- e.g. pattern Zero <- 0# (Trac #12094)
360 ; let bound_tvs
361 = unionVarSets [ allBoundVariabless req
362 , allBoundVariabless prov
363 , allBoundVariables body_ty
364 ]
365 ; return ( (univ_tvs, req, ex_tvs, prov, body_ty)
366 , bound_tvs) }
367
368 -- Kind generalisation
369 ; kvs <- kindGeneralize $
370 mkSpecForAllTys (implicit_tvs ++ univ_tvs) $
371 mkFunTys req $
372 mkSpecForAllTys ex_tvs $
373 mkFunTys prov $
374 body_ty
375
376 -- These are /signatures/ so we zonk to squeeze out any kind
377 -- unification variables. Do this after quantifyTyVars which may
378 -- default kind variables to *.
379 -- ToDo: checkValidType?
380 ; traceTc "about zonk" empty
381 ; implicit_tvs <- mapM zonkTcTyCoVarBndr implicit_tvs
382 ; univ_tvs <- mapM zonkTcTyCoVarBndr univ_tvs
383 ; ex_tvs <- mapM zonkTcTyCoVarBndr ex_tvs
384 ; req <- zonkTcTypes req
385 ; prov <- zonkTcTypes prov
386 ; body_ty <- zonkTcType body_ty
387
388 ; traceTc "tcTySig }" $
389 vcat [ text "implicit_tvs" <+> ppr_tvs implicit_tvs
390 , text "kvs" <+> ppr_tvs kvs
391 , text "univ_tvs" <+> ppr_tvs univ_tvs
392 , text "req" <+> ppr req
393 , text "ex_tvs" <+> ppr_tvs ex_tvs
394 , text "prov" <+> ppr prov
395 , text "body_ty" <+> ppr body_ty ]
396 ; return (TPSI { patsig_name = name
397 , patsig_implicit_bndrs = mkTyVarBinders Inferred kvs ++
398 mkTyVarBinders Specified implicit_tvs
399 , patsig_univ_bndrs = univ_tvs
400 , patsig_req = req
401 , patsig_ex_bndrs = ex_tvs
402 , patsig_prov = prov
403 , patsig_body_ty = body_ty }) }
404 where
405
406 ppr_tvs :: [TyVar] -> SDoc
407 ppr_tvs tvs = braces (vcat [ ppr tv <+> dcolon <+> ppr (tyVarKind tv)
408 | tv <- tvs])
409
410
411 {- *********************************************************************
412 * *
413 Instantiating user signatures
414 * *
415 ********************************************************************* -}
416
417
418 tcInstSig :: TcIdSigInfo -> TcM TcIdSigInst
419 -- Instantiate a type signature; only used with plan InferGen
420 tcInstSig sig@(CompleteSig { sig_bndr = poly_id, sig_loc = loc })
421 = setSrcSpan loc $ -- Set the binding site of the tyvars
422 do { (tv_prs, theta, tau) <- tcInstType newMetaSigTyVars poly_id
423 -- See Note [Pattern bindings and complete signatures]
424
425 ; return (TISI { sig_inst_sig = sig
426 , sig_inst_skols = tv_prs
427 , sig_inst_wcs = []
428 , sig_inst_wcx = Nothing
429 , sig_inst_theta = theta
430 , sig_inst_tau = tau }) }
431
432 tcInstSig sig@(PartialSig { psig_hs_ty = hs_ty
433 , sig_ctxt = ctxt
434 , sig_loc = loc })
435 = setSrcSpan loc $ -- Set the binding site of the tyvars
436 do { (wcs, wcx, tvs, theta, tau) <- tcHsPartialSigType ctxt hs_ty
437 ; return (TISI { sig_inst_sig = sig
438 , sig_inst_skols = map (\tv -> (tyVarName tv, tv)) tvs
439 , sig_inst_wcs = wcs
440 , sig_inst_wcx = wcx
441 , sig_inst_theta = theta
442 , sig_inst_tau = tau }) }
443
444
445 {- Note [Pattern bindings and complete signatures]
446 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
447 Consider
448 data T a = MkT a a
449 f :: forall a. a->a
450 g :: forall b. b->b
451 MkT f g = MkT (\x->x) (\y->y)
452 Here we'll infer a type from the pattern of 'T a', but if we feed in
453 the signature types for f and g, we'll end up unifying 'a' and 'b'
454
455 So we instantiate f and g's signature with SigTv skolems
456 (newMetaSigTyVars) that can unify with each other. If too much
457 unification takes place, we'll find out when we do the final
458 impedence-matching check in TcBinds.mkExport
459
460 See Note [Signature skolems] in TcType
461
462 None of this applies to a function binding with a complete
463 signature, which doesn't use tcInstSig. See TcBinds.tcPolyCheck.
464 -}
465
466 {- *********************************************************************
467 * *
468 Pragmas and PragEnv
469 * *
470 ********************************************************************* -}
471
472 type TcPragEnv = NameEnv [LSig Name]
473
474 emptyPragEnv :: TcPragEnv
475 emptyPragEnv = emptyNameEnv
476
477 lookupPragEnv :: TcPragEnv -> Name -> [LSig Name]
478 lookupPragEnv prag_fn n = lookupNameEnv prag_fn n `orElse` []
479
480 extendPragEnv :: TcPragEnv -> (Name, LSig Name) -> TcPragEnv
481 extendPragEnv prag_fn (n, sig) = extendNameEnv_Acc (:) singleton prag_fn n sig
482
483 ---------------
484 mkPragEnv :: [LSig Name] -> LHsBinds Name -> TcPragEnv
485 mkPragEnv sigs binds
486 = foldl extendPragEnv emptyNameEnv prs
487 where
488 prs = mapMaybe get_sig sigs
489
490 get_sig :: LSig Name -> Maybe (Name, LSig Name)
491 get_sig (L l (SpecSig lnm@(L _ nm) ty inl)) = Just (nm, L l $ SpecSig lnm ty (add_arity nm inl))
492 get_sig (L l (InlineSig lnm@(L _ nm) inl)) = Just (nm, L l $ InlineSig lnm (add_arity nm inl))
493 get_sig (L l (SCCFunSig st lnm@(L _ nm) str)) = Just (nm, L l $ SCCFunSig st lnm str)
494 get_sig _ = Nothing
495
496 add_arity n inl_prag -- Adjust inl_sat field to match visible arity of function
497 | Inline <- inl_inline inl_prag
498 -- add arity only for real INLINE pragmas, not INLINABLE
499 = case lookupNameEnv ar_env n of
500 Just ar -> inl_prag { inl_sat = Just ar }
501 Nothing -> WARN( True, text "mkPragEnv no arity" <+> ppr n )
502 -- There really should be a binding for every INLINE pragma
503 inl_prag
504 | otherwise
505 = inl_prag
506
507 -- ar_env maps a local to the arity of its definition
508 ar_env :: NameEnv Arity
509 ar_env = foldrBag lhsBindArity emptyNameEnv binds
510
511 lhsBindArity :: LHsBind Name -> NameEnv Arity -> NameEnv Arity
512 lhsBindArity (L _ (FunBind { fun_id = id, fun_matches = ms })) env
513 = extendNameEnv env (unLoc id) (matchGroupArity ms)
514 lhsBindArity _ env = env -- PatBind/VarBind
515
516
517 -----------------
518 addInlinePrags :: TcId -> [LSig Name] -> TcM TcId
519 addInlinePrags poly_id prags_for_me
520 | inl@(L _ prag) : inls <- inl_prags
521 = do { traceTc "addInlinePrag" (ppr poly_id $$ ppr prag)
522 ; unless (null inls) (warn_multiple_inlines inl inls)
523 ; return (poly_id `setInlinePragma` prag) }
524 | otherwise
525 = return poly_id
526 where
527 inl_prags = [L loc prag | L loc (InlineSig _ prag) <- prags_for_me]
528
529 warn_multiple_inlines _ [] = return ()
530
531 warn_multiple_inlines inl1@(L loc prag1) (inl2@(L _ prag2) : inls)
532 | inlinePragmaActivation prag1 == inlinePragmaActivation prag2
533 , isEmptyInlineSpec (inlinePragmaSpec prag1)
534 = -- Tiresome: inl1 is put there by virtue of being in a hs-boot loop
535 -- and inl2 is a user NOINLINE pragma; we don't want to complain
536 warn_multiple_inlines inl2 inls
537 | otherwise
538 = setSrcSpan loc $
539 addWarnTc NoReason
540 (hang (text "Multiple INLINE pragmas for" <+> ppr poly_id)
541 2 (vcat (text "Ignoring all but the first"
542 : map pp_inl (inl1:inl2:inls))))
543
544 pp_inl (L loc prag) = ppr prag <+> parens (ppr loc)
545
546
547 {- *********************************************************************
548 * *
549 SPECIALISE pragmas
550 * *
551 ************************************************************************
552
553 Note [Handling SPECIALISE pragmas]
554 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
555 The basic idea is this:
556
557 foo :: Num a => a -> b -> a
558 {-# SPECIALISE foo :: Int -> b -> Int #-}
559
560 We check that
561 (forall a b. Num a => a -> b -> a)
562 is more polymorphic than
563 forall b. Int -> b -> Int
564 (for which we could use tcSubType, but see below), generating a HsWrapper
565 to connect the two, something like
566 wrap = /\b. <hole> Int b dNumInt
567 This wrapper is put in the TcSpecPrag, in the ABExport record of
568 the AbsBinds.
569
570
571 f :: (Eq a, Ix b) => a -> b -> Bool
572 {-# SPECIALISE f :: (Ix p, Ix q) => Int -> (p,q) -> Bool #-}
573 f = <poly_rhs>
574
575 From this the typechecker generates
576
577 AbsBinds [ab] [d1,d2] [([ab], f, f_mono, prags)] binds
578
579 SpecPrag (wrap_fn :: forall a b. (Eq a, Ix b) => XXX
580 -> forall p q. (Ix p, Ix q) => XXX[ Int/a, (p,q)/b ])
581
582 From these we generate:
583
584 Rule: forall p, q, (dp:Ix p), (dq:Ix q).
585 f Int (p,q) dInt ($dfInPair dp dq) = f_spec p q dp dq
586
587 Spec bind: f_spec = wrap_fn <poly_rhs>
588
589 Note that
590
591 * The LHS of the rule may mention dictionary *expressions* (eg
592 $dfIxPair dp dq), and that is essential because the dp, dq are
593 needed on the RHS.
594
595 * The RHS of f_spec, <poly_rhs> has a *copy* of 'binds', so that it
596 can fully specialise it.
597
598
599
600 From the TcSpecPrag, in DsBinds we generate a binding for f_spec and a RULE:
601
602 f_spec :: Int -> b -> Int
603 f_spec = wrap<f rhs>
604
605 RULE: forall b (d:Num b). f b d = f_spec b
606
607 The RULE is generated by taking apart the HsWrapper, which is a little
608 delicate, but works.
609
610 Some wrinkles
611
612 1. We don't use full-on tcSubType, because that does co and contra
613 variance and that in turn will generate too complex a LHS for the
614 RULE. So we use a single invocation of skolemise /
615 topInstantiate in tcSpecWrapper. (Actually I think that even
616 the "deeply" stuff may be too much, because it introduces lambdas,
617 though I think it can be made to work without too much trouble.)
618
619 2. We need to take care with type families (Trac #5821). Consider
620 type instance F Int = Bool
621 f :: Num a => a -> F a
622 {-# SPECIALISE foo :: Int -> Bool #-}
623
624 We *could* try to generate an f_spec with precisely the declared type:
625 f_spec :: Int -> Bool
626 f_spec = <f rhs> Int dNumInt |> co
627
628 RULE: forall d. f Int d = f_spec |> sym co
629
630 but the 'co' and 'sym co' are (a) playing no useful role, and (b) are
631 hard to generate. At all costs we must avoid this:
632 RULE: forall d. f Int d |> co = f_spec
633 because the LHS will never match (indeed it's rejected in
634 decomposeRuleLhs).
635
636 So we simply do this:
637 - Generate a constraint to check that the specialised type (after
638 skolemiseation) is equal to the instantiated function type.
639 - But *discard* the evidence (coercion) for that constraint,
640 so that we ultimately generate the simpler code
641 f_spec :: Int -> F Int
642 f_spec = <f rhs> Int dNumInt
643
644 RULE: forall d. f Int d = f_spec
645 You can see this discarding happening in
646
647 3. Note that the HsWrapper can transform *any* function with the right
648 type prefix
649 forall ab. (Eq a, Ix b) => XXX
650 regardless of XXX. It's sort of polymorphic in XXX. This is
651 useful: we use the same wrapper to transform each of the class ops, as
652 well as the dict. That's what goes on in TcInstDcls.mk_meth_spec_prags
653 -}
654
655 tcSpecPrags :: Id -> [LSig Name]
656 -> TcM [LTcSpecPrag]
657 -- Add INLINE and SPECIALSE pragmas
658 -- INLINE prags are added to the (polymorphic) Id directly
659 -- SPECIALISE prags are passed to the desugarer via TcSpecPrags
660 -- Pre-condition: the poly_id is zonked
661 -- Reason: required by tcSubExp
662 tcSpecPrags poly_id prag_sigs
663 = do { traceTc "tcSpecPrags" (ppr poly_id <+> ppr spec_sigs)
664 ; unless (null bad_sigs) warn_discarded_sigs
665 ; pss <- mapAndRecoverM (wrapLocM (tcSpecPrag poly_id)) spec_sigs
666 ; return $ concatMap (\(L l ps) -> map (L l) ps) pss }
667 where
668 spec_sigs = filter isSpecLSig prag_sigs
669 bad_sigs = filter is_bad_sig prag_sigs
670 is_bad_sig s = not (isSpecLSig s || isInlineLSig s || isSCCFunSig s)
671
672 warn_discarded_sigs
673 = addWarnTc NoReason
674 (hang (text "Discarding unexpected pragmas for" <+> ppr poly_id)
675 2 (vcat (map (ppr . getLoc) bad_sigs)))
676
677 --------------
678 tcSpecPrag :: TcId -> Sig Name -> TcM [TcSpecPrag]
679 tcSpecPrag poly_id prag@(SpecSig fun_name hs_tys inl)
680 -- See Note [Handling SPECIALISE pragmas]
681 --
682 -- The Name fun_name in the SpecSig may not be the same as that of the poly_id
683 -- Example: SPECIALISE for a class method: the Name in the SpecSig is
684 -- for the selector Id, but the poly_id is something like $cop
685 -- However we want to use fun_name in the error message, since that is
686 -- what the user wrote (Trac #8537)
687 = addErrCtxt (spec_ctxt prag) $
688 do { warnIf NoReason (not (isOverloadedTy poly_ty || isInlinePragma inl))
689 (text "SPECIALISE pragma for non-overloaded function"
690 <+> quotes (ppr fun_name))
691 -- Note [SPECIALISE pragmas]
692 ; spec_prags <- mapM tc_one hs_tys
693 ; traceTc "tcSpecPrag" (ppr poly_id $$ nest 2 (vcat (map ppr spec_prags)))
694 ; return spec_prags }
695 where
696 name = idName poly_id
697 poly_ty = idType poly_id
698 spec_ctxt prag = hang (text "In the SPECIALISE pragma") 2 (ppr prag)
699
700 tc_one hs_ty
701 = do { spec_ty <- tcHsSigType (FunSigCtxt name False) hs_ty
702 ; wrap <- tcSpecWrapper (FunSigCtxt name True) poly_ty spec_ty
703 ; return (SpecPrag poly_id wrap inl) }
704
705 tcSpecPrag _ prag = pprPanic "tcSpecPrag" (ppr prag)
706
707 --------------
708 tcSpecWrapper :: UserTypeCtxt -> TcType -> TcType -> TcM HsWrapper
709 -- A simpler variant of tcSubType, used for SPECIALISE pragmas
710 -- See Note [Handling SPECIALISE pragmas], wrinkle 1
711 tcSpecWrapper ctxt poly_ty spec_ty
712 = do { (sk_wrap, inst_wrap)
713 <- tcSkolemise ctxt spec_ty $ \ _ spec_tau ->
714 do { (inst_wrap, tau) <- topInstantiate orig poly_ty
715 ; _ <- unifyType noThing spec_tau tau
716 -- Deliberately ignore the evidence
717 -- See Note [Handling SPECIALISE pragmas],
718 -- wrinkle (2)
719 ; return inst_wrap }
720 ; return (sk_wrap <.> inst_wrap) }
721 where
722 orig = SpecPragOrigin ctxt
723
724 --------------
725 tcImpPrags :: [LSig Name] -> TcM [LTcSpecPrag]
726 -- SPECIALISE pragmas for imported things
727 tcImpPrags prags
728 = do { this_mod <- getModule
729 ; dflags <- getDynFlags
730 ; if (not_specialising dflags) then
731 return []
732 else do
733 { pss <- mapAndRecoverM (wrapLocM tcImpSpec)
734 [L loc (name,prag)
735 | (L loc prag@(SpecSig (L _ name) _ _)) <- prags
736 , not (nameIsLocalOrFrom this_mod name) ]
737 ; return $ concatMap (\(L l ps) -> map (L l) ps) pss } }
738 where
739 -- Ignore SPECIALISE pragmas for imported things
740 -- when we aren't specialising, or when we aren't generating
741 -- code. The latter happens when Haddocking the base library;
742 -- we don't wnat complaints about lack of INLINABLE pragmas
743 not_specialising dflags
744 | not (gopt Opt_Specialise dflags) = True
745 | otherwise = case hscTarget dflags of
746 HscNothing -> True
747 HscInterpreted -> True
748 _other -> False
749
750 tcImpSpec :: (Name, Sig Name) -> TcM [TcSpecPrag]
751 tcImpSpec (name, prag)
752 = do { id <- tcLookupId name
753 ; unless (isAnyInlinePragma (idInlinePragma id))
754 (addWarnTc NoReason (impSpecErr name))
755 ; tcSpecPrag id prag }
756
757 impSpecErr :: Name -> SDoc
758 impSpecErr name
759 = hang (text "You cannot SPECIALISE" <+> quotes (ppr name))
760 2 (vcat [ text "because its definition has no INLINE/INLINABLE pragma"
761 , parens $ sep
762 [ text "or its defining module" <+> quotes (ppr mod)
763 , text "was compiled without -O"]])
764 where
765 mod = nameModule name