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