3 TyThing(..), TcTyThing(..), TcId,
5 -- Instance environment, and InstInfo type
6 InstInfo(..), iDFunId, pprInstInfo, pprInstInfoDetails,
7 simpleInstInfoClsTy, simpleInstInfoTy, simpleInstInfoTyCon,
13 tcLookupLocatedGlobal, tcLookupGlobal,
14 tcLookupGlobalId, tcLookupTyCon, tcLookupClass, tcLookupDataCon,
15 tcLookupLocatedGlobalId, tcLookupLocatedTyCon,
19 tcExtendKindEnv, tcExtendKindEnvTvs,
20 tcExtendTyVarEnv, tcExtendTyVarEnv2,
21 tcExtendIdEnv, tcExtendIdEnv1, tcExtendIdEnv2,
22 tcLookup, tcLookupLocated, tcLookupLocalIds,
23 tcLookupId, tcLookupTyVar,
24 lclEnvElts, getInLocalScope, findGlobals,
25 wrongThingErr, pprBinders,
27 tcExtendRecEnv, -- For knot-tying
32 -- Global type variables
35 -- Template Haskell stuff
36 checkWellStaged, spliceOK, bracketOK, tcMetaTy, thLevel,
40 newLocalName, newDFunName
43 #include "HsVersions.h"
45 import HsSyn ( LRuleDecl, LHsBinds, LSig,
46 LHsTyVarBndr, HsTyVarBndr(..), pprLHsBinds )
47 import TcIface ( tcImportDecl )
48 import IfaceEnv ( newGlobalBinder )
50 import TcMType ( zonkTcType, zonkTcTyVarsAndFV )
51 import TcType ( Type, TcKind, TcTyVar, TcTyVarSet, TcType,
52 tyVarsOfType, tyVarsOfTypes, mkGenTyConApp,
53 getDFunTyKey, tcTyConAppTyCon, tcGetTyVar, mkTyVarTy,
56 import qualified Type ( getTyVar_maybe )
57 import Id ( idName, isLocalId )
58 import Var ( TyVar, Id, idType, tyVarName )
61 import RdrName ( extendLocalRdrEnv )
62 import InstEnv ( Instance, DFunId, instanceDFunId, instanceHead )
63 import DataCon ( DataCon )
64 import TyCon ( TyCon )
65 import Class ( Class )
66 import Name ( Name, NamedThing(..), getSrcLoc, nameModule, isExternalName )
67 import PrelNames ( thFAKE )
69 import OccName ( mkDFunOcc, occNameString )
70 import HscTypes ( extendTypeEnvList, lookupType,
71 TyThing(..), tyThingId, tyThingDataCon,
72 ExternalPackageState(..) )
74 import SrcLoc ( SrcLoc, Located(..) )
79 %************************************************************************
83 %************************************************************************
85 Using the Located versions (eg. tcLookupLocatedGlobal) is preferred,
86 unless you know that the SrcSpan in the monad is already set to the
90 tcLookupLocatedGlobal :: Located Name -> TcM TyThing
91 -- c.f. IfaceEnvEnv.tcIfaceGlobal
92 tcLookupLocatedGlobal name
93 = addLocM tcLookupGlobal name
95 tcLookupGlobal :: Name -> TcM TyThing
97 = ASSERT( isExternalName name )
101 ; case lookupNameEnv (tcg_type_env env) name of {
102 Just thing -> return thing ;
106 { (eps,hpt) <- getEpsAndHpt
107 ; case lookupType hpt (eps_PTE eps) name of {
108 Just thing -> return thing ;
111 -- Should it have been in the local envt?
112 { let mod = nameModule name
113 ; if mod == tcg_mod env || mod == thFAKE then
114 notFound name -- It should be local, so panic
115 -- The thFAKE possibility is because it
116 -- might be in a declaration bracket
118 tcImportDecl name -- Go find it in an interface
121 tcLookupGlobalId :: Name -> TcM Id
122 -- Never used for Haskell-source DataCons, hence no ADataCon case
123 tcLookupGlobalId name
124 = tcLookupGlobal name `thenM` \ thing ->
125 return (tyThingId thing)
127 tcLookupDataCon :: Name -> TcM DataCon
128 tcLookupDataCon con_name
129 = tcLookupGlobal con_name `thenM` \ thing ->
130 return (tyThingDataCon thing)
132 tcLookupClass :: Name -> TcM Class
134 = tcLookupGlobal name `thenM` \ thing ->
136 AClass cls -> return cls
137 other -> wrongThingErr "class" (AGlobal thing) name
139 tcLookupTyCon :: Name -> TcM TyCon
141 = tcLookupGlobal name `thenM` \ thing ->
143 ATyCon tc -> return tc
144 other -> wrongThingErr "type constructor" (AGlobal thing) name
146 tcLookupLocatedGlobalId :: Located Name -> TcM Id
147 tcLookupLocatedGlobalId = addLocM tcLookupId
149 tcLookupLocatedClass :: Located Name -> TcM Class
150 tcLookupLocatedClass = addLocM tcLookupClass
152 tcLookupLocatedTyCon :: Located Name -> TcM TyCon
153 tcLookupLocatedTyCon = addLocM tcLookupTyCon
156 %************************************************************************
158 Extending the global environment
160 %************************************************************************
164 tcExtendGlobalEnv :: [TyThing] -> TcM r -> TcM r
165 -- Given a mixture of Ids, TyCons, Classes, all from the
166 -- module being compiled, extend the global environment
167 tcExtendGlobalEnv things thing_inside
168 = do { env <- getGblEnv
169 ; let ge' = extendTypeEnvList (tcg_type_env env) things
170 ; setGblEnv (env {tcg_type_env = ge'}) thing_inside }
172 tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a
173 -- Same deal as tcExtendGlobalEnv, but for Ids
174 tcExtendGlobalValEnv ids thing_inside
175 = tcExtendGlobalEnv [AnId id | id <- ids] thing_inside
179 tcExtendRecEnv :: [(Name,TyThing)] -> TcM r -> TcM r
180 -- Extend the global environments for the type/class knot tying game
181 tcExtendRecEnv gbl_stuff thing_inside
182 = updGblEnv upd thing_inside
184 upd env = env { tcg_type_env = extend (tcg_type_env env) }
185 extend env = extendNameEnvList env gbl_stuff
189 %************************************************************************
191 \subsection{The local environment}
193 %************************************************************************
196 tcLookupLocated :: Located Name -> TcM TcTyThing
197 tcLookupLocated = addLocM tcLookup
199 tcLookup :: Name -> TcM TcTyThing
201 = getLclEnv `thenM` \ local_env ->
202 case lookupNameEnv (tcl_env local_env) name of
203 Just thing -> returnM thing
204 Nothing -> tcLookupGlobal name `thenM` \ thing ->
205 returnM (AGlobal thing)
207 tcLookupTyVar :: Name -> TcM TcTyVar
209 = tcLookup name `thenM` \ thing ->
211 ATyVar _ ty -> returnM (tcGetTyVar "tcLookupTyVar" ty)
212 other -> pprPanic "tcLookupTyVar" (ppr name)
214 tcLookupId :: Name -> TcM Id
215 -- Used when we aren't interested in the binding level
216 -- Never a DataCon. (Why does that matter? see TcExpr.tcId)
218 = tcLookup name `thenM` \ thing ->
220 ATcId tc_id _ -> returnM tc_id
221 AGlobal (AnId id) -> returnM id
222 other -> pprPanic "tcLookupId" (ppr name)
224 tcLookupLocalIds :: [Name] -> TcM [TcId]
225 -- We expect the variables to all be bound, and all at
226 -- the same level as the lookup. Only used in one place...
228 = getLclEnv `thenM` \ env ->
229 returnM (map (lookup (tcl_env env) (thLevel (tcl_th_ctxt env))) ns)
232 = case lookupNameEnv lenv name of
233 Just (ATcId id lvl1) -> ASSERT( lvl == lvl1 ) id
234 other -> pprPanic "tcLookupLocalIds" (ppr name)
236 lclEnvElts :: TcLclEnv -> [TcTyThing]
237 lclEnvElts env = nameEnvElts (tcl_env env)
239 getInLocalScope :: TcM (Name -> Bool)
241 getInLocalScope = getLclEnv `thenM` \ env ->
243 lcl_env = tcl_env env
245 return (`elemNameEnv` lcl_env)
249 tcExtendKindEnv :: [(Name, TcKind)] -> TcM r -> TcM r
250 tcExtendKindEnv things thing_inside
251 = updLclEnv upd thing_inside
253 upd lcl_env = lcl_env { tcl_env = extend (tcl_env lcl_env) }
254 extend env = extendNameEnvList env [(n, AThing k) | (n,k) <- things]
256 tcExtendKindEnvTvs :: [LHsTyVarBndr Name] -> TcM r -> TcM r
257 tcExtendKindEnvTvs bndrs thing_inside
258 = updLclEnv upd thing_inside
260 upd lcl_env = lcl_env { tcl_env = extend (tcl_env lcl_env) }
261 extend env = extendNameEnvList env pairs
262 pairs = [(n, AThing k) | L _ (KindedTyVar n k) <- bndrs]
264 tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r
265 tcExtendTyVarEnv tvs thing_inside
266 = tcExtendTyVarEnv2 [(tyVarName tv, mkTyVarTy tv) | tv <- tvs] thing_inside
268 tcExtendTyVarEnv2 :: [(Name,TcType)] -> TcM r -> TcM r
269 tcExtendTyVarEnv2 binds thing_inside
270 = getLclEnv `thenM` \ env@(TcLclEnv {tcl_env = le,
272 tcl_rdr = rdr_env}) ->
274 rdr_env' = extendLocalRdrEnv rdr_env (map fst binds)
275 new_tv_set = tyVarsOfTypes (map snd binds)
276 le' = extendNameEnvList le [(name, ATyVar name ty) | (name, ty) <- binds]
278 -- It's important to add the in-scope tyvars to the global tyvar set
280 -- f (_::r) = let g y = y::r in ...
281 -- Here, g mustn't be generalised. This is also important during
282 -- class and instance decls, when we mustn't generalise the class tyvars
283 -- when typechecking the methods.
284 tc_extend_gtvs gtvs new_tv_set `thenM` \ gtvs' ->
285 setLclEnv (env {tcl_env = le', tcl_tyvars = gtvs', tcl_rdr = rdr_env'}) thing_inside
290 tcExtendIdEnv :: [TcId] -> TcM a -> TcM a
291 -- Invariant: the TcIds are fully zonked. Reasons:
292 -- (a) The kinds of the forall'd type variables are defaulted
293 -- (see Kind.defaultKind, done in zonkQuantifiedTyVar)
294 -- (b) There are no via-Indirect occurrences of the bound variables
295 -- in the types, because instantiation does not look through such things
296 -- (c) The call to tyVarsOfTypes is ok without looking through refs
297 tcExtendIdEnv ids thing_inside = tcExtendIdEnv2 [(idName id, id) | id <- ids] thing_inside
299 tcExtendIdEnv1 :: Name -> TcId -> TcM a -> TcM a
300 tcExtendIdEnv1 name id thing_inside = tcExtendIdEnv2 [(name,id)] thing_inside
302 tcExtendIdEnv2 :: [(Name,TcId)] -> TcM a -> TcM a
303 -- Invariant: the TcIds are fully zonked (see tcExtendIdEnv above)
304 tcExtendIdEnv2 names_w_ids thing_inside
305 = getLclEnv `thenM` \ env ->
307 extra_global_tyvars = tyVarsOfTypes [idType id | (name,id) <- names_w_ids]
308 th_lvl = thLevel (tcl_th_ctxt env)
309 extra_env = [(name, ATcId id th_lvl) | (name,id) <- names_w_ids]
310 le' = extendNameEnvList (tcl_env env) extra_env
311 rdr_env' = extendLocalRdrEnv (tcl_rdr env) (map fst names_w_ids)
313 tc_extend_gtvs (tcl_tyvars env) extra_global_tyvars `thenM` \ gtvs' ->
314 setLclEnv (env {tcl_env = le', tcl_tyvars = gtvs', tcl_rdr = rdr_env'}) thing_inside
319 -----------------------
320 -- findGlobals looks at the value environment and finds values
321 -- whose types mention the offending type variable. It has to be
322 -- careful to zonk the Id's type first, so it has to be in the monad.
323 -- We must be careful to pass it a zonked type variable, too.
325 findGlobals :: TcTyVarSet
327 -> TcM (TidyEnv, [SDoc])
329 findGlobals tvs tidy_env
330 = getLclEnv `thenM` \ lcl_env ->
331 go tidy_env [] (lclEnvElts lcl_env)
333 go tidy_env acc [] = returnM (tidy_env, acc)
334 go tidy_env acc (thing : things)
335 = find_thing ignore_it tidy_env thing `thenM` \ (tidy_env1, maybe_doc) ->
337 Just d -> go tidy_env1 (d:acc) things
338 Nothing -> go tidy_env1 acc things
340 ignore_it ty = not (tvs `intersectsVarSet` tyVarsOfType ty)
342 -----------------------
343 find_thing ignore_it tidy_env (ATcId id _)
344 = zonkTcType (idType id) `thenM` \ id_ty ->
345 if ignore_it id_ty then
346 returnM (tidy_env, Nothing)
348 (tidy_env', tidy_ty) = tidyOpenType tidy_env id_ty
349 msg = sep [ppr id <+> dcolon <+> ppr tidy_ty,
350 nest 2 (parens (ptext SLIT("bound at") <+>
351 ppr (getSrcLoc id)))]
353 returnM (tidy_env', Just msg)
355 find_thing ignore_it tidy_env (ATyVar tv ty)
356 = zonkTcType ty `thenM` \ tv_ty ->
357 if ignore_it tv_ty then
358 returnM (tidy_env, Nothing)
360 -- The name tv is scoped, so we don't need to tidy it
361 (tidy_env1, tidy_ty) = tidyOpenType tidy_env tv_ty
362 msg = sep [ptext SLIT("Scoped type variable") <+> quotes (ppr tv) <+> eq_stuff, nest 2 bound_at]
364 eq_stuff | Just tv' <- Type.getTyVar_maybe tv_ty,
365 getOccName tv == getOccName tv' = empty
366 | otherwise = equals <+> ppr tidy_ty
367 -- It's ok to use Type.getTyVar_maybe because ty is zonked by now
368 bound_at = parens $ ptext SLIT("bound at:") <+> ppr (getSrcLoc tv)
370 returnM (tidy_env1, Just msg)
374 %************************************************************************
376 \subsection{The global tyvars}
378 %************************************************************************
381 tc_extend_gtvs gtvs extra_global_tvs
382 = readMutVar gtvs `thenM` \ global_tvs ->
383 newMutVar (global_tvs `unionVarSet` extra_global_tvs)
386 @tcGetGlobalTyVars@ returns a fully-zonked set of tyvars free in the environment.
387 To improve subsequent calls to the same function it writes the zonked set back into
391 tcGetGlobalTyVars :: TcM TcTyVarSet
393 = getLclEnv `thenM` \ (TcLclEnv {tcl_tyvars = gtv_var}) ->
394 readMutVar gtv_var `thenM` \ gbl_tvs ->
395 zonkTcTyVarsAndFV (varSetElems gbl_tvs) `thenM` \ gbl_tvs' ->
396 writeMutVar gtv_var gbl_tvs' `thenM_`
401 %************************************************************************
405 %************************************************************************
408 tcExtendRules :: [LRuleDecl Id] -> TcM a -> TcM a
409 -- Just pop the new rules into the EPS and envt resp
410 -- All the rules come from an interface file, not soruce
411 -- Nevertheless, some may be for this module, if we read
412 -- its interface instead of its source code
413 tcExtendRules lcl_rules thing_inside
414 = do { env <- getGblEnv
416 env' = env { tcg_rules = lcl_rules ++ tcg_rules env }
417 ; setGblEnv env' thing_inside }
421 %************************************************************************
425 %************************************************************************
428 instance Outputable ThStage where
429 ppr Comp = text "Comp"
430 ppr (Brack l _ _) = text "Brack" <+> int l
431 ppr (Splice l) = text "Splice" <+> int l
434 thLevel :: ThStage -> ThLevel
435 thLevel Comp = topLevel
436 thLevel (Splice l) = l
437 thLevel (Brack l _ _) = l
440 checkWellStaged :: SDoc -- What the stage check is for
441 -> ThLevel -- Binding level
442 -> ThStage -- Use stage
443 -> TcM () -- Fail if badly staged, adding an error
444 checkWellStaged pp_thing bind_lvl use_stage
445 | bind_lvl <= use_lvl -- OK!
448 | bind_lvl == topLevel -- GHC restriction on top level splices
450 sep [ptext SLIT("GHC stage restriction:") <+> pp_thing,
451 nest 2 (ptext SLIT("is used in a top-level splice, and must be imported, not defined locally"))]
453 | otherwise -- Badly staged
455 ptext SLIT("Stage error:") <+> pp_thing <+>
456 hsep [ptext SLIT("is bound at stage") <+> ppr bind_lvl,
457 ptext SLIT("but used at stage") <+> ppr use_lvl]
459 use_lvl = thLevel use_stage
462 topIdLvl :: Id -> ThLevel
463 -- Globals may either be imported, or may be from an earlier "chunk"
464 -- (separated by declaration splices) of this module. The former
465 -- *can* be used inside a top-level splice, but the latter cannot.
466 -- Hence we give the former impLevel, but the latter topLevel
470 -- By the time we are prcessing the $(f x), the binding for "x"
471 -- will be in the global env, not the local one.
472 topIdLvl id | isLocalId id = topLevel
473 | otherwise = impLevel
475 -- Indicates the legal transitions on bracket( [| |] ).
476 bracketOK :: ThStage -> Maybe ThLevel
477 bracketOK (Brack _ _ _) = Nothing -- Bracket illegal inside a bracket
478 bracketOK stage = Just (thLevel stage + 1)
480 -- Indicates the legal transitions on splice($).
481 spliceOK :: ThStage -> Maybe ThLevel
482 spliceOK (Splice _) = Nothing -- Splice illegal inside splice
483 spliceOK stage = Just (thLevel stage - 1)
485 tcMetaTy :: Name -> TcM Type
486 -- Given the name of a Template Haskell data type,
488 -- E.g. given the name "Expr" return the type "Expr"
490 = tcLookupTyCon tc_name `thenM` \ t ->
491 returnM (mkGenTyConApp t [])
492 -- Use mkGenTyConApp because it might be a synonym
496 %************************************************************************
498 \subsection{The InstInfo type}
500 %************************************************************************
502 The InstInfo type summarises the information in an instance declaration
504 instance c => k (t tvs) where b
506 It is used just for *local* instance decls (not ones from interface files).
507 But local instance decls includes
510 as well as explicit user written ones.
515 iSpec :: Instance, -- Includes the dfun id. Its forall'd type
516 iBinds :: InstBindings -- variables scope over the stuff in InstBindings!
519 iDFunId :: InstInfo -> DFunId
520 iDFunId info = instanceDFunId (iSpec info)
523 = VanillaInst -- The normal case
524 (LHsBinds Name) -- Bindings
525 [LSig Name] -- User pragmas recorded for generating
526 -- specialised instances
528 | NewTypeDerived -- Used for deriving instances of newtypes, where the
529 [Type] -- witness dictionary is identical to the argument
530 -- dictionary. Hence no bindings, no pragmas
531 -- The [Type] are the representation types
532 -- See notes in TcDeriv
534 pprInstInfo info = vcat [ptext SLIT("InstInfo:") <+> ppr (idType (iDFunId info))]
536 pprInstInfoDetails info = pprInstInfo info $$ nest 2 (details (iBinds info))
538 details (VanillaInst b _) = pprLHsBinds b
539 details (NewTypeDerived _) = text "Derived from the representation type"
541 simpleInstInfoClsTy :: InstInfo -> (Class, Type)
542 simpleInstInfoClsTy info = case instanceHead (iSpec info) of
543 (_, _, cls, [ty]) -> (cls, ty)
545 simpleInstInfoTy :: InstInfo -> Type
546 simpleInstInfoTy info = snd (simpleInstInfoClsTy info)
548 simpleInstInfoTyCon :: InstInfo -> TyCon
549 -- Gets the type constructor for a simple instance declaration,
550 -- i.e. one of the form instance (...) => C (T a b c) where ...
551 simpleInstInfoTyCon inst = tcTyConAppTyCon (simpleInstInfoTy inst)
554 Make a name for the dict fun for an instance decl. It's an *external*
555 name, like otber top-level names, and hence must be made with newGlobalBinder.
558 newDFunName :: Class -> [Type] -> SrcLoc -> TcM Name
559 newDFunName clas (ty:_) loc
560 = do { index <- nextDFunIndex
561 ; is_boot <- tcIsHsBoot
563 ; let info_string = occNameString (getOccName clas) ++
564 occNameString (getDFunTyKey ty)
565 dfun_occ = mkDFunOcc info_string is_boot index
567 ; newGlobalBinder mod dfun_occ Nothing loc }
569 newDFunName clas [] loc = pprPanic "newDFunName" (ppr clas <+> ppr loc)
573 %************************************************************************
577 %************************************************************************
580 pprBinders :: [Name] -> SDoc
581 -- Used in error messages
582 -- Use quotes for a single one; they look a bit "busy" for several
583 pprBinders [bndr] = quotes (ppr bndr)
584 pprBinders bndrs = pprWithCommas ppr bndrs
587 = failWithTc (ptext SLIT("GHC internal error:") <+> quotes (ppr name) <+>
588 ptext SLIT("is not in scope"))
590 wrongThingErr expected thing name
591 = failWithTc (pprTcTyThingCategory thing <+> quotes (ppr name) <+>
592 ptext SLIT("used as a") <+> text expected)