3 TyThing(..), TcTyThing(..), TcId,
5 -- Instance environment, and InstInfo type
6 InstInfo(..), pprInstInfo, pprInstInfoDetails,
7 simpleInstInfoTy, simpleInstInfoTyCon,
13 tcLookupLocatedGlobal, tcLookupGlobal,
14 tcLookupGlobalId, tcLookupTyCon, tcLookupClass, tcLookupDataCon,
15 tcLookupLocatedGlobalId, tcLookupLocatedTyCon,
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,
43 newLocalName, newDFunName
46 #include "HsVersions.h"
48 import HsSyn ( LRuleDecl, LHsBinds, LSig, pprLHsBinds )
49 import TcIface ( tcImportDecl )
50 import TcRnTypes ( pprTcTyThingCategory )
52 import TcMType ( zonkTcType, zonkTcTyVarsAndFV )
53 import TcType ( Type, TcKind, TcTyVar, TcTyVarSet, TcType,
54 tyVarsOfType, tyVarsOfTypes, tcSplitDFunTy, mkGenTyConApp,
55 getDFunTyKey, tcTyConAppTyCon, tcGetTyVar, mkTyVarTy,
58 import qualified Type ( getTyVar_maybe )
59 import Id ( idName, isLocalId )
60 import Var ( TyVar, Id, idType, tyVarName )
63 import RdrName ( extendLocalRdrEnv )
64 import DataCon ( DataCon )
65 import TyCon ( TyCon )
66 import Class ( Class )
67 import Name ( Name, NamedThing(..), getSrcLoc, mkInternalName, nameIsLocalOrFrom )
69 import OccName ( mkDFunOcc, occNameString )
70 import HscTypes ( DFunId, 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 = do { env <- getGblEnv
98 ; if nameIsLocalOrFrom (tcg_mod env) name
100 then -- It's defined in this module
101 case lookupNameEnv (tcg_type_env env) name of
102 Just thing -> return thing
103 Nothing -> notFound name -- Panic!
105 else do -- It's imported
106 { (eps,hpt) <- getEpsAndHpt
107 ; case lookupType hpt (eps_PTE eps) name of
108 Just thing -> return thing
109 Nothing -> tcImportDecl name
114 tcLookupGlobalId :: Name -> TcM Id
115 -- Never used for Haskell-source DataCons, hence no ADataCon case
116 tcLookupGlobalId name
117 = tcLookupGlobal name `thenM` \ thing ->
118 return (tyThingId thing)
120 tcLookupDataCon :: Name -> TcM DataCon
121 tcLookupDataCon con_name
122 = tcLookupGlobal con_name `thenM` \ thing ->
123 return (tyThingDataCon thing)
125 tcLookupClass :: Name -> TcM Class
127 = tcLookupGlobal name `thenM` \ thing ->
129 AClass cls -> return cls
130 other -> wrongThingErr "class" (AGlobal thing) name
132 tcLookupTyCon :: Name -> TcM TyCon
134 = tcLookupGlobal name `thenM` \ thing ->
136 ATyCon tc -> return tc
137 other -> wrongThingErr "type constructor" (AGlobal thing) name
139 tcLookupLocatedGlobalId :: Located Name -> TcM Id
140 tcLookupLocatedGlobalId = addLocM tcLookupId
142 tcLookupLocatedClass :: Located Name -> TcM Class
143 tcLookupLocatedClass = addLocM tcLookupClass
145 tcLookupLocatedTyCon :: Located Name -> TcM TyCon
146 tcLookupLocatedTyCon = addLocM tcLookupTyCon
149 %************************************************************************
151 Extending the global environment
153 %************************************************************************
157 tcExtendGlobalEnv :: [TyThing] -> TcM r -> TcM r
158 -- Given a mixture of Ids, TyCons, Classes, all from the
159 -- module being compiled, extend the global environment
160 tcExtendGlobalEnv things thing_inside
161 = do { env <- getGblEnv
162 ; let ge' = extendTypeEnvList (tcg_type_env env) things
163 ; setGblEnv (env {tcg_type_env = ge'}) thing_inside }
165 tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a
166 -- Same deal as tcExtendGlobalEnv, but for Ids
167 tcExtendGlobalValEnv ids thing_inside
168 = tcExtendGlobalEnv [AnId id | id <- ids] thing_inside
172 tcExtendRecEnv :: [(Name,TyThing)] -> TcM r -> TcM r
173 -- Extend the global environments for the type/class knot tying game
174 tcExtendRecEnv gbl_stuff thing_inside
175 = updGblEnv upd thing_inside
177 upd env = env { tcg_type_env = extend (tcg_type_env env) }
178 extend env = extendNameEnvList env gbl_stuff
182 %************************************************************************
184 \subsection{The local environment}
186 %************************************************************************
189 tcLookupLocated :: Located Name -> TcM TcTyThing
190 tcLookupLocated = addLocM tcLookup
192 tcLookup :: Name -> TcM TcTyThing
194 = getLclEnv `thenM` \ local_env ->
195 case lookupNameEnv (tcl_env local_env) name of
196 Just thing -> returnM thing
197 Nothing -> tcLookupGlobal name `thenM` \ thing ->
198 returnM (AGlobal thing)
200 tcLookupTyVar :: Name -> TcM TcTyVar
202 = tcLookup name `thenM` \ thing ->
204 ATyVar _ ty -> returnM (tcGetTyVar "tcLookupTyVar" ty)
205 other -> pprPanic "tcLookupTyVar" (ppr name)
207 tcLookupId :: Name -> TcM Id
208 -- Used when we aren't interested in the binding level
209 -- Never a DataCon. (Why does that matter? see TcExpr.tcId)
211 = tcLookup name `thenM` \ thing ->
213 ATcId tc_id _ _ -> returnM tc_id
214 AGlobal (AnId id) -> returnM id
215 other -> pprPanic "tcLookupId" (ppr name)
217 tcLookupLocalIds :: [Name] -> TcM [TcId]
218 -- We expect the variables to all be bound, and all at
219 -- the same level as the lookup. Only used in one place...
221 = getLclEnv `thenM` \ env ->
222 returnM (map (lookup (tcl_env env) (thLevel (tcl_th_ctxt env))) ns)
225 = case lookupNameEnv lenv name of
226 Just (ATcId id lvl1 _) -> ASSERT( lvl == lvl1 ) id
227 other -> pprPanic "tcLookupLocalIds" (ppr name)
229 lclEnvElts :: TcLclEnv -> [TcTyThing]
230 lclEnvElts env = nameEnvElts (tcl_env env)
232 getInLocalScope :: TcM (Name -> Bool)
234 getInLocalScope = getLclEnv `thenM` \ env ->
236 lcl_env = tcl_env env
238 return (`elemNameEnv` lcl_env)
242 tcExtendKindEnv :: [(Name, TcKind)] -> TcM r -> TcM r
243 tcExtendKindEnv things thing_inside
244 = updLclEnv upd thing_inside
246 upd lcl_env = lcl_env { tcl_env = extend (tcl_env lcl_env) }
247 extend env = extendNameEnvList env [(n, AThing k) | (n,k) <- things]
249 tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r
250 tcExtendTyVarEnv tvs thing_inside
251 = tcExtendTyVarEnv2 [(tyVarName tv, mkTyVarTy tv) | tv <- tvs] thing_inside
253 tcExtendTyVarEnv2 :: [(Name,TcType)] -> TcM r -> TcM r
254 tcExtendTyVarEnv2 binds thing_inside
255 = getLclEnv `thenM` \ env@(TcLclEnv {tcl_env = le,
257 tcl_rdr = rdr_env}) ->
259 rdr_env' = extendLocalRdrEnv rdr_env (map fst binds)
260 new_tv_set = tyVarsOfTypes (map snd binds)
261 le' = extendNameEnvList le [(name, ATyVar name ty) | (name, ty) <- binds]
263 -- It's important to add the in-scope tyvars to the global tyvar set
265 -- f (_::r) = let g y = y::r in ...
266 -- Here, g mustn't be generalised. This is also important during
267 -- class and instance decls, when we mustn't generalise the class tyvars
268 -- when typechecking the methods.
269 tc_extend_gtvs gtvs new_tv_set `thenM` \ gtvs' ->
270 setLclEnv (env {tcl_env = le', tcl_tyvars = gtvs', tcl_rdr = rdr_env'}) thing_inside
275 tcExtendIdEnv :: [TcId] -> TcM a -> TcM a
276 -- Invariant: the TcIds are fully zonked. Reasons:
277 -- (a) The kinds of the forall'd type variables are defaulted
278 -- (see Kind.defaultKind, done in zonkQuantifiedTyVar)
279 -- (b) There are no via-Indirect occurrences of the bound variables
280 -- in the types, because instantiation does not look through such things
281 -- (c) The call to tyVarsOfTypes is ok without looking through refs
282 tcExtendIdEnv ids thing_inside = tcExtendIdEnv2 [(idName id, id) | id <- ids] thing_inside
284 tcExtendIdEnv1 :: Name -> TcId -> TcM a -> TcM a
285 tcExtendIdEnv1 name id thing_inside = tcExtendIdEnv2 [(name,id)] thing_inside
287 tcExtendIdEnv2 :: [(Name,TcId)] -> TcM a -> TcM a
288 -- Invariant: the TcIds are fully zonked (see tcExtendIdEnv above)
289 tcExtendIdEnv2 names_w_ids thing_inside
290 = getLclEnv `thenM` \ env ->
292 extra_global_tyvars = tyVarsOfTypes [idType id | (name,id) <- names_w_ids]
293 th_lvl = thLevel (tcl_th_ctxt env)
294 proc_lvl = proc_level (tcl_arrow_ctxt env)
295 extra_env = [(name, ATcId id th_lvl proc_lvl) | (name,id) <- names_w_ids]
296 le' = extendNameEnvList (tcl_env env) extra_env
297 rdr_env' = extendLocalRdrEnv (tcl_rdr env) (map fst names_w_ids)
299 tc_extend_gtvs (tcl_tyvars env) extra_global_tyvars `thenM` \ gtvs' ->
300 setLclEnv (env {tcl_env = le', tcl_tyvars = gtvs', tcl_rdr = rdr_env'}) thing_inside
305 -----------------------
306 -- findGlobals looks at the value environment and finds values
307 -- whose types mention the offending type variable. It has to be
308 -- careful to zonk the Id's type first, so it has to be in the monad.
309 -- We must be careful to pass it a zonked type variable, too.
311 findGlobals :: TcTyVarSet
313 -> TcM (TidyEnv, [SDoc])
315 findGlobals tvs tidy_env
316 = getLclEnv `thenM` \ lcl_env ->
317 go tidy_env [] (lclEnvElts lcl_env)
319 go tidy_env acc [] = returnM (tidy_env, acc)
320 go tidy_env acc (thing : things)
321 = find_thing ignore_it tidy_env thing `thenM` \ (tidy_env1, maybe_doc) ->
323 Just d -> go tidy_env1 (d:acc) things
324 Nothing -> go tidy_env1 acc things
326 ignore_it ty = not (tvs `intersectsVarSet` tyVarsOfType ty)
328 -----------------------
329 find_thing ignore_it tidy_env (ATcId id _ _)
330 = zonkTcType (idType id) `thenM` \ id_ty ->
331 if ignore_it id_ty then
332 returnM (tidy_env, Nothing)
334 (tidy_env', tidy_ty) = tidyOpenType tidy_env id_ty
335 msg = sep [ppr id <+> dcolon <+> ppr tidy_ty,
336 nest 2 (parens (ptext SLIT("bound at") <+>
337 ppr (getSrcLoc id)))]
339 returnM (tidy_env', Just msg)
341 find_thing ignore_it tidy_env (ATyVar tv ty)
342 = zonkTcType ty `thenM` \ tv_ty ->
343 if ignore_it tv_ty then
344 returnM (tidy_env, Nothing)
346 -- The name tv is scoped, so we don't need to tidy it
347 (tidy_env1, tidy_ty) = tidyOpenType tidy_env tv_ty
348 msg = sep [ptext SLIT("Scoped type variable") <+> quotes (ppr tv) <+> eq_stuff, nest 2 bound_at]
350 eq_stuff | Just tv' <- Type.getTyVar_maybe tv_ty,
351 getOccName tv == getOccName tv' = empty
352 | otherwise = equals <+> ppr tidy_ty
353 -- It's ok to use Type.getTyVar_maybe because ty is zonked by now
354 bound_at = parens $ ptext SLIT("bound at:") <+> ppr (getSrcLoc tv)
356 returnM (tidy_env1, Just msg)
360 %************************************************************************
362 \subsection{The global tyvars}
364 %************************************************************************
367 tc_extend_gtvs gtvs extra_global_tvs
368 = readMutVar gtvs `thenM` \ global_tvs ->
369 newMutVar (global_tvs `unionVarSet` extra_global_tvs)
372 @tcGetGlobalTyVars@ returns a fully-zonked set of tyvars free in the environment.
373 To improve subsequent calls to the same function it writes the zonked set back into
377 tcGetGlobalTyVars :: TcM TcTyVarSet
379 = getLclEnv `thenM` \ (TcLclEnv {tcl_tyvars = gtv_var}) ->
380 readMutVar gtv_var `thenM` \ gbl_tvs ->
381 zonkTcTyVarsAndFV (varSetElems gbl_tvs) `thenM` \ gbl_tvs' ->
382 writeMutVar gtv_var gbl_tvs' `thenM_`
387 %************************************************************************
391 %************************************************************************
394 tcExtendRules :: [LRuleDecl Id] -> TcM a -> TcM a
395 -- Just pop the new rules into the EPS and envt resp
396 -- All the rules come from an interface file, not soruce
397 -- Nevertheless, some may be for this module, if we read
398 -- its interface instead of its source code
399 tcExtendRules lcl_rules thing_inside
400 = do { env <- getGblEnv
402 env' = env { tcg_rules = lcl_rules ++ tcg_rules env }
403 ; setGblEnv env' thing_inside }
407 %************************************************************************
409 Arrow notation proc levels
411 %************************************************************************
414 checkProcLevel :: TcId -> ProcLevel -> TcM ()
415 checkProcLevel id id_lvl
416 = do { banned <- getBannedProcLevels
417 ; checkTc (not (id_lvl `elem` banned))
418 (procLevelErr id id_lvl) }
420 procLevelErr id id_lvl
421 = hang (ptext SLIT("Command-bound variable") <+> quotes (ppr id) <+> ptext SLIT("is not in scope here"))
422 4 (ptext SLIT("Reason: it is used in the left argument of (-<)"))
426 %************************************************************************
430 %************************************************************************
433 instance Outputable ThStage where
434 ppr Comp = text "Comp"
435 ppr (Brack l _ _) = text "Brack" <+> int l
436 ppr (Splice l) = text "Splice" <+> int l
439 thLevel :: ThStage -> ThLevel
440 thLevel Comp = topLevel
441 thLevel (Splice l) = l
442 thLevel (Brack l _ _) = l
445 checkWellStaged :: SDoc -- What the stage check is for
446 -> ThLevel -- Binding level
447 -> ThStage -- Use stage
448 -> TcM () -- Fail if badly staged, adding an error
449 checkWellStaged pp_thing bind_lvl use_stage
450 | bind_lvl <= use_lvl -- OK!
453 | bind_lvl == topLevel -- GHC restriction on top level splices
455 sep [ptext SLIT("GHC stage restriction:") <+> pp_thing,
456 nest 2 (ptext SLIT("is used in a top-level splice, and must be imported, not defined locally"))]
458 | otherwise -- Badly staged
460 ptext SLIT("Stage error:") <+> pp_thing <+>
461 hsep [ptext SLIT("is bound at stage") <+> ppr bind_lvl,
462 ptext SLIT("but used at stage") <+> ppr use_lvl]
464 use_lvl = thLevel use_stage
467 topIdLvl :: Id -> ThLevel
468 -- Globals may either be imported, or may be from an earlier "chunk"
469 -- (separated by declaration splices) of this module. The former
470 -- *can* be used inside a top-level splice, but the latter cannot.
471 -- Hence we give the former impLevel, but the latter topLevel
475 -- By the time we are prcessing the $(f x), the binding for "x"
476 -- will be in the global env, not the local one.
477 topIdLvl id | isLocalId id = topLevel
478 | otherwise = impLevel
480 -- Indicates the legal transitions on bracket( [| |] ).
481 bracketOK :: ThStage -> Maybe ThLevel
482 bracketOK (Brack _ _ _) = Nothing -- Bracket illegal inside a bracket
483 bracketOK stage = Just (thLevel stage + 1)
485 -- Indicates the legal transitions on splice($).
486 spliceOK :: ThStage -> Maybe ThLevel
487 spliceOK (Splice _) = Nothing -- Splice illegal inside splice
488 spliceOK stage = Just (thLevel stage - 1)
490 tcMetaTy :: Name -> TcM Type
491 -- Given the name of a Template Haskell data type,
493 -- E.g. given the name "Expr" return the type "Expr"
495 = tcLookupTyCon tc_name `thenM` \ t ->
496 returnM (mkGenTyConApp t [])
497 -- Use mkGenTyConApp because it might be a synonym
501 %************************************************************************
503 \subsection{Making new Ids}
505 %************************************************************************
510 newLocalName :: Name -> TcM Name
511 newLocalName name -- Make a clone
512 = newUnique `thenM` \ uniq ->
513 returnM (mkInternalName uniq (getOccName name) (getSrcLoc name))
516 Make a name for the dict fun for an instance decl. It's a *local*
517 name for the moment. The CoreTidy pass will externalise it. Even in
518 --make and ghci stuff, we rebuild the instance environment each time,
519 so the dfun id is internal to begin with, and external when compiling
523 newDFunName :: Class -> [Type] -> SrcLoc -> TcM Name
524 newDFunName clas (ty:_) loc
525 = newUnique `thenM` \ uniq ->
526 returnM (mkInternalName uniq (mkDFunOcc dfun_string) loc)
528 -- Any string that is somewhat unique will do
529 dfun_string = occNameString (getOccName clas) ++ occNameString (getDFunTyKey ty)
531 newDFunName clas [] loc = pprPanic "newDFunName" (ppr clas <+> ppr loc)
535 %************************************************************************
537 \subsection{The InstInfo type}
539 %************************************************************************
541 The InstInfo type summarises the information in an instance declaration
543 instance c => k (t tvs) where b
545 It is used just for *local* instance decls (not ones from interface files).
546 But local instance decls includes
549 as well as explicit user written ones.
554 iDFunId :: DFunId, -- The dfun id. Its forall'd type variables
555 iBinds :: InstBindings -- scope over the stuff in InstBindings!
559 = VanillaInst -- The normal case
560 (LHsBinds Name) -- Bindings
561 [LSig Name] -- User pragmas recorded for generating
562 -- specialised instances
564 | NewTypeDerived -- Used for deriving instances of newtypes, where the
565 [Type] -- witness dictionary is identical to the argument
566 -- dictionary. Hence no bindings, no pragmas
567 -- The [Type] are the representation types
568 -- See notes in TcDeriv
570 pprInstInfo info = vcat [ptext SLIT("InstInfo:") <+> ppr (idType (iDFunId info))]
572 pprInstInfoDetails info = pprInstInfo info $$ nest 2 (details (iBinds info))
574 details (VanillaInst b _) = pprLHsBinds b
575 details (NewTypeDerived _) = text "Derived from the representation type"
577 simpleInstInfoTy :: InstInfo -> Type
578 simpleInstInfoTy info = case tcSplitDFunTy (idType (iDFunId info)) of
579 (_, _, _, [ty]) -> ty
581 simpleInstInfoTyCon :: InstInfo -> TyCon
582 -- Gets the type constructor for a simple instance declaration,
583 -- i.e. one of the form instance (...) => C (T a b c) where ...
584 simpleInstInfoTyCon inst = tcTyConAppTyCon (simpleInstInfoTy inst)
588 %************************************************************************
592 %************************************************************************
595 pprBinders :: [Name] -> SDoc
596 -- Used in error messages
597 -- Use quotes for a single one; they look a bit "busy" for several
598 pprBinders [bndr] = quotes (ppr bndr)
599 pprBinders bndrs = pprWithCommas ppr bndrs
602 = failWithTc (ptext SLIT("GHC internal error:") <+> quotes (ppr name) <+>
603 ptext SLIT("is not in scope"))
605 wrongThingErr expected thing name
606 = failWithTc (pprTcTyThingCategory thing <+> quotes (ppr name) <+>
607 ptext SLIT("used as a") <+> text expected)