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