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, tcLookupLocalId_maybe,
23 tcLookupId, tcLookupTyVar, getScopedTyVarBinds,
24 lclEnvElts, getInLocalScope, findGlobals,
25 wrongThingErr, pprBinders,
28 tcExtendRecEnv, -- For knot-tying
33 -- Global type variables
36 -- Template Haskell stuff
37 checkWellStaged, spliceOK, bracketOK, tcMetaTy, thLevel,
41 newLocalName, newDFunName
44 #include "HsVersions.h"
46 import HsSyn ( LRuleDecl, LHsBinds, LSig,
47 LHsTyVarBndr, HsTyVarBndr(..), pprLHsBinds )
48 import TcIface ( tcImportDecl )
49 import IfaceEnv ( newGlobalBinder )
51 import TcMType ( zonkTcType, zonkTcTyVarsAndFV )
52 import TcType ( Type, TcKind, TcTyVar, TcTyVarSet, TcType, TvSubst,
53 substTy, substTyVar, tyVarsOfType, tcTyVarsOfTypes, mkTyConApp,
54 getDFunTyKey, tcTyConAppTyCon, tcGetTyVar, mkTyVarTy,
55 tidyOpenType, isRefineableTy
57 import qualified Type ( getTyVar_maybe )
58 import Id ( idName, isLocalId, setIdType )
59 import Var ( TyVar, Id, idType, tyVarName )
62 import RdrName ( extendLocalRdrEnv )
63 import InstEnv ( Instance, DFunId, instanceDFunId, instanceHead )
64 import DataCon ( DataCon )
65 import TyCon ( TyCon )
66 import Class ( Class )
67 import Name ( Name, NamedThing(..), getSrcLoc, nameModule, isExternalName )
68 import PrelNames ( thFAKE )
70 import OccName ( mkDFunOcc, occNameString )
71 import HscTypes ( extendTypeEnvList, lookupType,
72 TyThing(..), tyThingId, tyThingDataCon,
73 ExternalPackageState(..) )
75 import SrcLoc ( SrcLoc, Located(..) )
80 %************************************************************************
84 %************************************************************************
86 Using the Located versions (eg. tcLookupLocatedGlobal) is preferred,
87 unless you know that the SrcSpan in the monad is already set to the
91 tcLookupLocatedGlobal :: Located Name -> TcM TyThing
92 -- c.f. IfaceEnvEnv.tcIfaceGlobal
93 tcLookupLocatedGlobal name
94 = addLocM tcLookupGlobal name
96 tcLookupGlobal :: Name -> TcM TyThing
97 -- The Name is almost always an ExternalName, but not always
98 -- In GHCi, we may make command-line bindings (ghci> let x = True)
99 -- that bind a GlobalId, but with an InternalName
101 = do { env <- getGblEnv
104 ; case lookupNameEnv (tcg_type_env env) name of {
105 Just thing -> return thing ;
109 { (eps,hpt) <- getEpsAndHpt
110 ; case lookupType hpt (eps_PTE eps) name of {
111 Just thing -> return thing ;
114 -- Should it have been in the local envt?
115 { let mod = nameModule name
116 ; if mod == tcg_mod env || mod == thFAKE then
117 notFound name -- It should be local, so panic
118 -- The thFAKE possibility is because it
119 -- might be in a declaration bracket
121 tcImportDecl name -- Go find it in an interface
124 tcLookupGlobalId :: Name -> TcM Id
125 -- Never used for Haskell-source DataCons, hence no ADataCon case
126 tcLookupGlobalId name
127 = tcLookupGlobal name `thenM` \ thing ->
128 return (tyThingId thing)
130 tcLookupDataCon :: Name -> TcM DataCon
131 tcLookupDataCon con_name
132 = tcLookupGlobal con_name `thenM` \ thing ->
133 return (tyThingDataCon thing)
135 tcLookupClass :: Name -> TcM Class
137 = tcLookupGlobal name `thenM` \ thing ->
139 AClass cls -> return cls
140 other -> wrongThingErr "class" (AGlobal thing) name
142 tcLookupTyCon :: Name -> TcM TyCon
144 = tcLookupGlobal name `thenM` \ thing ->
146 ATyCon tc -> return tc
147 other -> wrongThingErr "type constructor" (AGlobal thing) name
149 tcLookupLocatedGlobalId :: Located Name -> TcM Id
150 tcLookupLocatedGlobalId = addLocM tcLookupId
152 tcLookupLocatedClass :: Located Name -> TcM Class
153 tcLookupLocatedClass = addLocM tcLookupClass
155 tcLookupLocatedTyCon :: Located Name -> TcM TyCon
156 tcLookupLocatedTyCon = addLocM tcLookupTyCon
159 %************************************************************************
161 Extending the global environment
163 %************************************************************************
167 tcExtendGlobalEnv :: [TyThing] -> TcM r -> TcM r
168 -- Given a mixture of Ids, TyCons, Classes, all from the
169 -- module being compiled, extend the global environment
170 tcExtendGlobalEnv things thing_inside
171 = do { env <- getGblEnv
172 ; let ge' = extendTypeEnvList (tcg_type_env env) things
173 ; setGblEnv (env {tcg_type_env = ge'}) thing_inside }
175 tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a
176 -- Same deal as tcExtendGlobalEnv, but for Ids
177 tcExtendGlobalValEnv ids thing_inside
178 = tcExtendGlobalEnv [AnId id | id <- ids] thing_inside
182 tcExtendRecEnv :: [(Name,TyThing)] -> TcM r -> TcM r
183 -- Extend the global environments for the type/class knot tying game
184 tcExtendRecEnv gbl_stuff thing_inside
185 = updGblEnv upd thing_inside
187 upd env = env { tcg_type_env = extend (tcg_type_env env) }
188 extend env = extendNameEnvList env gbl_stuff
192 %************************************************************************
194 \subsection{The local environment}
196 %************************************************************************
199 tcLookupLocated :: Located Name -> TcM TcTyThing
200 tcLookupLocated = addLocM tcLookup
202 tcLookup :: Name -> TcM TcTyThing
204 = getLclEnv `thenM` \ local_env ->
205 case lookupNameEnv (tcl_env local_env) name of
206 Just thing -> returnM thing
207 Nothing -> tcLookupGlobal name `thenM` \ thing ->
208 returnM (AGlobal thing)
210 tcLookupTyVar :: Name -> TcM TcTyVar
212 = tcLookup name `thenM` \ thing ->
214 ATyVar _ ty -> return (tcGetTyVar "tcLookupTyVar" ty)
215 other -> pprPanic "tcLookupTyVar" (ppr name)
217 tcLookupId :: Name -> TcM Id
218 -- Used when we aren't interested in the binding level
219 -- Never a DataCon. (Why does that matter? see TcExpr.tcId)
221 = tcLookup name `thenM` \ thing ->
223 ATcId tc_id _ _ -> returnM tc_id
224 AGlobal (AnId id) -> returnM id
225 other -> pprPanic "tcLookupId" (ppr name)
227 tcLookupLocalId_maybe :: Name -> TcM (Maybe Id)
228 tcLookupLocalId_maybe name
229 = getLclEnv `thenM` \ local_env ->
230 case lookupNameEnv (tcl_env local_env) name of
231 Just (ATcId tc_id _ _) -> return (Just tc_id)
232 other -> return Nothing
234 tcLookupLocalIds :: [Name] -> TcM [TcId]
235 -- We expect the variables to all be bound, and all at
236 -- the same level as the lookup. Only used in one place...
238 = getLclEnv `thenM` \ env ->
239 returnM (map (lookup (tcl_env env) (thLevel (tcl_th_ctxt env))) ns)
242 = case lookupNameEnv lenv name of
243 Just (ATcId id lvl1 _) -> ASSERT( lvl == lvl1 ) id
244 other -> pprPanic "tcLookupLocalIds" (ppr name)
246 lclEnvElts :: TcLclEnv -> [TcTyThing]
247 lclEnvElts env = nameEnvElts (tcl_env env)
249 getInLocalScope :: TcM (Name -> Bool)
251 getInLocalScope = getLclEnv `thenM` \ env ->
253 lcl_env = tcl_env env
255 return (`elemNameEnv` lcl_env)
259 tcExtendKindEnv :: [(Name, TcKind)] -> TcM r -> TcM r
260 tcExtendKindEnv things thing_inside
261 = updLclEnv upd thing_inside
263 upd lcl_env = lcl_env { tcl_env = extend (tcl_env lcl_env) }
264 extend env = extendNameEnvList env [(n, AThing k) | (n,k) <- things]
266 tcExtendKindEnvTvs :: [LHsTyVarBndr Name] -> TcM r -> TcM r
267 tcExtendKindEnvTvs bndrs thing_inside
268 = updLclEnv upd thing_inside
270 upd lcl_env = lcl_env { tcl_env = extend (tcl_env lcl_env) }
271 extend env = extendNameEnvList env pairs
272 pairs = [(n, AThing k) | L _ (KindedTyVar n k) <- bndrs]
274 tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r
275 tcExtendTyVarEnv tvs thing_inside
276 = tcExtendTyVarEnv2 [(tyVarName tv, mkTyVarTy tv) | tv <- tvs] thing_inside
278 tcExtendTyVarEnv2 :: [(Name,TcType)] -> TcM r -> TcM r
279 tcExtendTyVarEnv2 binds thing_inside
280 = getLclEnv `thenM` \ env@(TcLclEnv {tcl_env = le,
282 tcl_rdr = rdr_env}) ->
284 rdr_env' = extendLocalRdrEnv rdr_env (map fst binds)
285 new_tv_set = tcTyVarsOfTypes (map snd binds)
286 le' = extendNameEnvList le [(name, ATyVar name ty) | (name, ty) <- binds]
288 -- It's important to add the in-scope tyvars to the global tyvar set
290 -- f (_::r) = let g y = y::r in ...
291 -- Here, g mustn't be generalised. This is also important during
292 -- class and instance decls, when we mustn't generalise the class tyvars
293 -- when typechecking the methods.
294 tc_extend_gtvs gtvs new_tv_set `thenM` \ gtvs' ->
295 setLclEnv (env {tcl_env = le', tcl_tyvars = gtvs', tcl_rdr = rdr_env'}) thing_inside
297 getScopedTyVarBinds :: TcM [(Name, TcType)]
299 = do { lcl_env <- getLclEnv
300 ; return [(name, ty) | ATyVar name ty <- nameEnvElts (tcl_env lcl_env)] }
305 tcExtendIdEnv :: [TcId] -> TcM a -> TcM a
306 -- Invariant: the TcIds are fully zonked. Reasons:
307 -- (a) The kinds of the forall'd type variables are defaulted
308 -- (see Kind.defaultKind, done in zonkQuantifiedTyVar)
309 -- (b) There are no via-Indirect occurrences of the bound variables
310 -- in the types, because instantiation does not look through such things
311 -- (c) The call to tyVarsOfTypes is ok without looking through refs
312 tcExtendIdEnv ids thing_inside = tcExtendIdEnv2 [(idName id, id) | id <- ids] thing_inside
314 tcExtendIdEnv1 :: Name -> TcId -> TcM a -> TcM a
315 tcExtendIdEnv1 name id thing_inside = tcExtendIdEnv2 [(name,id)] thing_inside
317 tcExtendIdEnv2 :: [(Name,TcId)] -> TcM a -> TcM a
318 -- Invariant: the TcIds are fully zonked (see tcExtendIdEnv above)
319 tcExtendIdEnv2 names_w_ids thing_inside
320 = getLclEnv `thenM` \ env ->
322 extra_global_tyvars = tcTyVarsOfTypes [idType id | (_,id) <- names_w_ids]
323 th_lvl = thLevel (tcl_th_ctxt env)
324 extra_env = [ (name, ATcId id th_lvl (isRefineableTy (idType id)))
325 | (name,id) <- names_w_ids]
326 le' = extendNameEnvList (tcl_env env) extra_env
327 rdr_env' = extendLocalRdrEnv (tcl_rdr env) [name | (name,_) <- names_w_ids]
329 traceTc (text "env2") `thenM_`
330 traceTc (text "env3" <+> ppr extra_env) `thenM_`
331 tc_extend_gtvs (tcl_tyvars env) extra_global_tyvars `thenM` \ gtvs' ->
332 (traceTc (text "env4") `thenM_`
333 setLclEnv (env {tcl_env = le', tcl_tyvars = gtvs', tcl_rdr = rdr_env'}) thing_inside)
338 -----------------------
339 -- findGlobals looks at the value environment and finds values
340 -- whose types mention the offending type variable. It has to be
341 -- careful to zonk the Id's type first, so it has to be in the monad.
342 -- We must be careful to pass it a zonked type variable, too.
344 findGlobals :: TcTyVarSet
346 -> TcM (TidyEnv, [SDoc])
348 findGlobals tvs tidy_env
349 = getLclEnv `thenM` \ lcl_env ->
350 go tidy_env [] (lclEnvElts lcl_env)
352 go tidy_env acc [] = returnM (tidy_env, acc)
353 go tidy_env acc (thing : things)
354 = find_thing ignore_it tidy_env thing `thenM` \ (tidy_env1, maybe_doc) ->
356 Just d -> go tidy_env1 (d:acc) things
357 Nothing -> go tidy_env1 acc things
359 ignore_it ty = not (tvs `intersectsVarSet` tyVarsOfType ty)
361 -----------------------
362 find_thing ignore_it tidy_env (ATcId id _ _)
363 = zonkTcType (idType id) `thenM` \ id_ty ->
364 if ignore_it id_ty then
365 returnM (tidy_env, Nothing)
367 (tidy_env', tidy_ty) = tidyOpenType tidy_env id_ty
368 msg = sep [ppr id <+> dcolon <+> ppr tidy_ty,
369 nest 2 (parens (ptext SLIT("bound at") <+>
370 ppr (getSrcLoc id)))]
372 returnM (tidy_env', Just msg)
374 find_thing ignore_it tidy_env (ATyVar tv ty)
375 = zonkTcType ty `thenM` \ tv_ty ->
376 if ignore_it tv_ty then
377 returnM (tidy_env, Nothing)
379 -- The name tv is scoped, so we don't need to tidy it
380 (tidy_env1, tidy_ty) = tidyOpenType tidy_env tv_ty
381 msg = sep [ptext SLIT("Scoped type variable") <+> quotes (ppr tv) <+> eq_stuff, nest 2 bound_at]
383 eq_stuff | Just tv' <- Type.getTyVar_maybe tv_ty,
384 getOccName tv == getOccName tv' = empty
385 | otherwise = equals <+> ppr tidy_ty
386 -- It's ok to use Type.getTyVar_maybe because ty is zonked by now
387 bound_at = parens $ ptext SLIT("bound at:") <+> ppr (getSrcLoc tv)
389 returnM (tidy_env1, Just msg)
393 refineEnvironment :: TvSubst -> TcM a -> TcM a
394 refineEnvironment reft thing_inside
395 = do { env <- getLclEnv
396 ; let le' = mapNameEnv refine (tcl_env env)
397 ; gtvs' <- refineGlobalTyVars reft (tcl_tyvars env)
398 ; setLclEnv (env {tcl_env = le', tcl_tyvars = gtvs'}) thing_inside }
400 refine (ATcId id lvl True) = ATcId (setIdType id (substTy reft (idType id))) lvl True
401 refine (ATyVar tv ty) = ATyVar tv (substTy reft ty)
405 %************************************************************************
407 \subsection{The global tyvars}
409 %************************************************************************
412 tc_extend_gtvs gtvs extra_global_tvs
413 = readMutVar gtvs `thenM` \ global_tvs ->
414 newMutVar (global_tvs `unionVarSet` extra_global_tvs)
416 refineGlobalTyVars :: GadtRefinement -> TcRef TcTyVarSet -> TcM (TcRef TcTyVarSet)
417 refineGlobalTyVars reft gtv_var
418 = readMutVar gtv_var `thenM` \ gbl_tvs ->
419 newMutVar (tcTyVarsOfTypes (map (substTyVar reft) (varSetElems gbl_tvs)))
422 @tcGetGlobalTyVars@ returns a fully-zonked set of tyvars free in the environment.
423 To improve subsequent calls to the same function it writes the zonked set back into
427 tcGetGlobalTyVars :: TcM TcTyVarSet
429 = getLclEnv `thenM` \ (TcLclEnv {tcl_tyvars = gtv_var}) ->
430 readMutVar gtv_var `thenM` \ gbl_tvs ->
431 zonkTcTyVarsAndFV (varSetElems gbl_tvs) `thenM` \ gbl_tvs' ->
432 writeMutVar gtv_var gbl_tvs' `thenM_`
437 %************************************************************************
441 %************************************************************************
444 tcExtendRules :: [LRuleDecl Id] -> TcM a -> TcM a
445 -- Just pop the new rules into the EPS and envt resp
446 -- All the rules come from an interface file, not soruce
447 -- Nevertheless, some may be for this module, if we read
448 -- its interface instead of its source code
449 tcExtendRules lcl_rules thing_inside
450 = do { env <- getGblEnv
452 env' = env { tcg_rules = lcl_rules ++ tcg_rules env }
453 ; setGblEnv env' thing_inside }
457 %************************************************************************
461 %************************************************************************
464 instance Outputable ThStage where
465 ppr Comp = text "Comp"
466 ppr (Brack l _ _) = text "Brack" <+> int l
467 ppr (Splice l) = text "Splice" <+> int l
470 thLevel :: ThStage -> ThLevel
471 thLevel Comp = topLevel
472 thLevel (Splice l) = l
473 thLevel (Brack l _ _) = l
476 checkWellStaged :: SDoc -- What the stage check is for
477 -> ThLevel -- Binding level
478 -> ThStage -- Use stage
479 -> TcM () -- Fail if badly staged, adding an error
480 checkWellStaged pp_thing bind_lvl use_stage
481 | bind_lvl <= use_lvl -- OK!
484 | bind_lvl == topLevel -- GHC restriction on top level splices
486 sep [ptext SLIT("GHC stage restriction:") <+> pp_thing,
487 nest 2 (ptext SLIT("is used in a top-level splice, and must be imported, not defined locally"))]
489 | otherwise -- Badly staged
491 ptext SLIT("Stage error:") <+> pp_thing <+>
492 hsep [ptext SLIT("is bound at stage") <+> ppr bind_lvl,
493 ptext SLIT("but used at stage") <+> ppr use_lvl]
495 use_lvl = thLevel use_stage
498 topIdLvl :: Id -> ThLevel
499 -- Globals may either be imported, or may be from an earlier "chunk"
500 -- (separated by declaration splices) of this module. The former
501 -- *can* be used inside a top-level splice, but the latter cannot.
502 -- Hence we give the former impLevel, but the latter topLevel
506 -- By the time we are prcessing the $(f x), the binding for "x"
507 -- will be in the global env, not the local one.
508 topIdLvl id | isLocalId id = topLevel
509 | otherwise = impLevel
511 -- Indicates the legal transitions on bracket( [| |] ).
512 bracketOK :: ThStage -> Maybe ThLevel
513 bracketOK (Brack _ _ _) = Nothing -- Bracket illegal inside a bracket
514 bracketOK stage = Just (thLevel stage + 1)
516 -- Indicates the legal transitions on splice($).
517 spliceOK :: ThStage -> Maybe ThLevel
518 spliceOK (Splice _) = Nothing -- Splice illegal inside splice
519 spliceOK stage = Just (thLevel stage - 1)
521 tcMetaTy :: Name -> TcM Type
522 -- Given the name of a Template Haskell data type,
524 -- E.g. given the name "Expr" return the type "Expr"
526 = tcLookupTyCon tc_name `thenM` \ t ->
527 returnM (mkTyConApp t [])
531 %************************************************************************
533 \subsection{The InstInfo type}
535 %************************************************************************
537 The InstInfo type summarises the information in an instance declaration
539 instance c => k (t tvs) where b
541 It is used just for *local* instance decls (not ones from interface files).
542 But local instance decls includes
545 as well as explicit user written ones.
550 iSpec :: Instance, -- Includes the dfun id. Its forall'd type
551 iBinds :: InstBindings -- variables scope over the stuff in InstBindings!
554 iDFunId :: InstInfo -> DFunId
555 iDFunId info = instanceDFunId (iSpec info)
558 = VanillaInst -- The normal case
559 (LHsBinds Name) -- Bindings
560 [LSig Name] -- User pragmas recorded for generating
561 -- specialised instances
563 | NewTypeDerived -- Used for deriving instances of newtypes, where the
564 [Type] -- witness dictionary is identical to the argument
565 -- dictionary. Hence no bindings, no pragmas
566 -- The [Type] are the representation types
567 -- See notes in TcDeriv
569 pprInstInfo info = vcat [ptext SLIT("InstInfo:") <+> ppr (idType (iDFunId info))]
571 pprInstInfoDetails info = pprInstInfo info $$ nest 2 (details (iBinds info))
573 details (VanillaInst b _) = pprLHsBinds b
574 details (NewTypeDerived _) = text "Derived from the representation type"
576 simpleInstInfoClsTy :: InstInfo -> (Class, Type)
577 simpleInstInfoClsTy info = case instanceHead (iSpec info) of
578 (_, _, cls, [ty]) -> (cls, ty)
580 simpleInstInfoTy :: InstInfo -> Type
581 simpleInstInfoTy info = snd (simpleInstInfoClsTy info)
583 simpleInstInfoTyCon :: InstInfo -> TyCon
584 -- Gets the type constructor for a simple instance declaration,
585 -- i.e. one of the form instance (...) => C (T a b c) where ...
586 simpleInstInfoTyCon inst = tcTyConAppTyCon (simpleInstInfoTy inst)
589 Make a name for the dict fun for an instance decl. It's an *external*
590 name, like otber top-level names, and hence must be made with newGlobalBinder.
593 newDFunName :: Class -> [Type] -> SrcLoc -> TcM Name
594 newDFunName clas (ty:_) loc
595 = do { index <- nextDFunIndex
596 ; is_boot <- tcIsHsBoot
598 ; let info_string = occNameString (getOccName clas) ++
599 occNameString (getDFunTyKey ty)
600 dfun_occ = mkDFunOcc info_string is_boot index
602 ; newGlobalBinder mod dfun_occ Nothing loc }
604 newDFunName clas [] loc = pprPanic "newDFunName" (ppr clas <+> ppr loc)
608 %************************************************************************
612 %************************************************************************
615 pprBinders :: [Name] -> SDoc
616 -- Used in error messages
617 -- Use quotes for a single one; they look a bit "busy" for several
618 pprBinders [bndr] = quotes (ppr bndr)
619 pprBinders bndrs = pprWithCommas ppr bndrs
622 = failWithTc (ptext SLIT("GHC internal error:") <+> quotes (ppr name) <+>
623 ptext SLIT("is not in scope"))
625 wrongThingErr expected thing name
626 = failWithTc (pprTcTyThingCategory thing <+> quotes (ppr name) <+>
627 ptext SLIT("used as a") <+> text expected)