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