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