3 TyThing(..), TcTyThing(..), TcId,
5 -- Instance environment, and InstInfo type
6 InstInfo(..), pprInstInfo, pprInstInfoDetails,
7 simpleInstInfoTy, simpleInstInfoTyCon,
14 tcLookupGlobalId, tcLookupTyCon, tcLookupClass, tcLookupDataCon,
20 tcExtendTyVarEnv, tcExtendTyVarEnv2,
21 tcExtendLocalValEnv, tcExtendLocalValEnv2,
22 tcLookup, tcLookupLocalIds,
23 tcLookupId, tcLookupTyVar,
24 lclEnvElts, getInLocalScope, findGlobals,
26 tcExtendRecEnv, -- For knot-tying
31 -- Global type variables
34 -- Template Haskell stuff
35 checkWellStaged, spliceOK, bracketOK, tcMetaTy, thLevel,
42 newLocalName, newDFunName
45 #include "HsVersions.h"
47 import RnHsSyn ( RenamedMonoBinds, RenamedSig )
48 import HsSyn ( RuleDecl(..), , HsTyVarBndr(..) )
49 import TcIface ( tcImportDecl )
51 import TcMType ( zonkTcType, zonkTcTyVar, zonkTcTyVarsAndFV )
52 import TcType ( Type, TcTyVar, TcTyVarSet,
53 tyVarsOfType, tyVarsOfTypes, tcSplitDFunTy, mkGenTyConApp,
54 getDFunTyKey, tcTyConAppTyCon, tyVarBindingInfo,
55 tidyOpenType, tidyOpenTyVar
57 import qualified Type ( getTyVar_maybe )
58 import Id ( idName, isLocalId )
59 import Var ( TyVar, Id, mkTyVar, idType )
62 import DataCon ( DataCon )
63 import TyCon ( TyCon )
64 import Class ( Class )
65 import Name ( Name, NamedThing(..),
66 getSrcLoc, mkInternalName, nameIsLocalOrFrom
69 import OccName ( mkDFunOcc, occNameString )
70 import HscTypes ( DFunId, extendTypeEnvList, lookupType,
71 TyThing(..), tyThingId, tyThingTyCon, tyThingClass, tyThingDataCon,
72 ExternalPackageState(..) )
74 import SrcLoc ( SrcLoc )
76 import Maybe ( isJust )
80 %************************************************************************
84 %************************************************************************
87 tcLookupGlobal :: Name -> TcM TyThing
88 -- c.f. IfaceEnvEnv.tcIfaceGlobal
90 = do { env <- getGblEnv
91 ; if nameIsLocalOrFrom (tcg_mod env) name
93 then -- It's defined in this module
94 case lookupNameEnv (tcg_type_env env) name of
95 Just thing -> return thing
96 Nothing -> notFound "tcLookupGlobal" name
98 else do -- It's imported
101 ; case lookupType hpt (eps_PTE eps) name of
102 Just thing -> return thing
103 Nothing -> do { traceIf (text "tcLookupGlobal" <+> ppr name)
104 ; initIfaceTcRn (tcImportDecl name) }
109 tcLookupGlobalId :: Name -> TcM Id
110 -- Never used for Haskell-source DataCons, hence no ADataCon case
111 tcLookupGlobalId name
112 = tcLookupGlobal name `thenM` \ thing ->
113 return (tyThingId thing)
115 tcLookupDataCon :: Name -> TcM DataCon
116 tcLookupDataCon con_name
117 = tcLookupGlobal con_name `thenM` \ thing ->
118 return (tyThingDataCon thing)
120 tcLookupClass :: Name -> TcM Class
122 = tcLookupGlobal name `thenM` \ thing ->
123 return (tyThingClass thing)
125 tcLookupTyCon :: Name -> TcM TyCon
127 = tcLookupGlobal name `thenM` \ thing ->
128 return (tyThingTyCon thing)
131 %************************************************************************
133 Extending the global environment
135 %************************************************************************
139 tcExtendGlobalEnv :: [TyThing] -> TcM r -> TcM r
140 -- Given a mixture of Ids, TyCons, Classes, all from the
141 -- module being compiled, extend the global environment
142 tcExtendGlobalEnv things thing_inside
143 = do { env <- getGblEnv
144 ; let ge' = extendTypeEnvList (tcg_type_env env) things
145 ; setGblEnv (env {tcg_type_env = ge'}) thing_inside }
147 tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a
148 -- Same deal as tcExtendGlobalEnv, but for Ids
149 tcExtendGlobalValEnv ids thing_inside
150 = tcExtendGlobalEnv [AnId id | id <- ids] thing_inside
153 A variety of global lookups, when we know what we are looking for.
156 getInGlobalScope :: TcM (Name -> Bool)
157 -- Get all things in the global environment; used for deciding what
158 -- rules to suck in. Anything defined in this module (nameIsLocalOrFrom)
159 -- is certainly in the envt, so we don't bother to look.
161 = do { mod <- getModule
164 ; return (\n -> nameIsLocalOrFrom mod n ||
165 isJust (lookupType hpt (eps_PTE eps) n)) }
170 tcExtendRecEnv :: [(Name,TyThing)] -- Global bindings
171 -> [(Name,TcTyThing)] -- Local bindings
173 -- Extend both local and global environments for the type/class knot tying game
174 tcExtendRecEnv gbl_stuff lcl_stuff thing_inside
175 = do { (gbl_env, lcl_env) <- getEnvs
176 ; let { ge' = extendNameEnvList (tcg_type_env gbl_env) gbl_stuff
177 ; le' = extendNameEnvList (tcl_env lcl_env) lcl_stuff }
178 ; setEnvs (gbl_env {tcg_type_env = ge'}, lcl_env {tcl_env = le'})
183 %************************************************************************
185 \subsection{The local environment}
187 %************************************************************************
190 tcLookup :: Name -> TcM TcTyThing
192 = getLclEnv `thenM` \ local_env ->
193 case lookupNameEnv (tcl_env local_env) name of
194 Just thing -> returnM thing
195 Nothing -> tcLookupGlobal name `thenM` \ thing ->
196 returnM (AGlobal thing)
198 tcLookupTyVar :: Name -> TcM Id
200 = tcLookup name `thenM` \ thing ->
202 ATyVar tv -> returnM tv
203 other -> pprPanic "tcLookupTyVar" (ppr name)
205 tcLookupId :: Name -> TcM Id
206 -- Used when we aren't interested in the binding level
207 -- Never a DataCon. (Why does that matter? see TcExpr.tcId)
209 = tcLookup name `thenM` \ thing ->
211 ATcId tc_id _ _ -> returnM tc_id
212 AGlobal (AnId id) -> returnM id
213 other -> pprPanic "tcLookupId" (ppr name)
215 tcLookupLocalIds :: [Name] -> TcM [TcId]
216 -- We expect the variables to all be bound, and all at
217 -- the same level as the lookup. Only used in one place...
219 = getLclEnv `thenM` \ env ->
220 returnM (map (lookup (tcl_env env) (thLevel (tcl_th_ctxt env))) ns)
223 = case lookupNameEnv lenv name of
224 Just (ATcId id lvl1 _) -> ASSERT( lvl == lvl1 ) id
225 other -> pprPanic "tcLookupLocalIds" (ppr name)
227 lclEnvElts :: TcLclEnv -> [TcTyThing]
228 lclEnvElts env = nameEnvElts (tcl_env env)
230 getInLocalScope :: TcM (Name -> Bool)
232 getInLocalScope = getLclEnv `thenM` \ env ->
234 lcl_env = tcl_env env
236 return (`elemNameEnv` lcl_env)
240 tcExtendTyVarKindEnv :: [HsTyVarBndr Name] -> TcM r -> TcM r
241 -- The tyvars are all kinded
242 tcExtendTyVarKindEnv tvs thing_inside
243 = updLclEnv upd thing_inside
245 upd lcl_env = lcl_env { tcl_env = extend (tcl_env lcl_env) }
246 extend env = extendNameEnvList env [(n, ATyVar (mkTyVar n k))
247 | KindedTyVar n k <- tvs]
248 -- No need to extend global tyvars for kind checking
250 tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r
251 tcExtendTyVarEnv tvs thing_inside
252 = tc_extend_tv_env [(getName tv, ATyVar tv) | tv <- tvs] tvs thing_inside
254 tcExtendTyVarEnv2 :: [(TyVar,TcTyVar)] -> TcM r -> TcM r
255 tcExtendTyVarEnv2 tv_pairs thing_inside
256 = tc_extend_tv_env [(getName tv1, ATyVar tv2) | (tv1,tv2) <- tv_pairs]
257 [tv | (_,tv) <- tv_pairs]
260 tc_extend_tv_env binds tyvars thing_inside
261 = getLclEnv `thenM` \ env@(TcLclEnv {tcl_env = le, tcl_tyvars = gtvs}) ->
263 le' = extendNameEnvList le binds
264 new_tv_set = mkVarSet tyvars
266 -- It's important to add the in-scope tyvars to the global tyvar set
268 -- f (_::r) = let g y = y::r in ...
269 -- Here, g mustn't be generalised. This is also important during
270 -- class and instance decls, when we mustn't generalise the class tyvars
271 -- when typechecking the methods.
272 tc_extend_gtvs gtvs new_tv_set `thenM` \ gtvs' ->
273 setLclEnv (env {tcl_env = le', tcl_tyvars = gtvs'}) thing_inside
278 tcExtendLocalValEnv :: [TcId] -> TcM a -> TcM a
279 tcExtendLocalValEnv ids thing_inside
280 = getLclEnv `thenM` \ env ->
282 extra_global_tyvars = tyVarsOfTypes [idType id | id <- ids]
283 th_lvl = thLevel (tcl_th_ctxt env)
284 proc_lvl = proc_level (tcl_arrow_ctxt env)
285 extra_env = [(idName id, ATcId id th_lvl proc_lvl) | id <- ids]
286 le' = extendNameEnvList (tcl_env env) extra_env
288 tc_extend_gtvs (tcl_tyvars env) extra_global_tyvars `thenM` \ gtvs' ->
289 setLclEnv (env {tcl_env = le', tcl_tyvars = gtvs'}) thing_inside
291 tcExtendLocalValEnv2 :: [(Name,TcId)] -> TcM a -> TcM a
292 tcExtendLocalValEnv2 names_w_ids thing_inside
293 = getLclEnv `thenM` \ env ->
295 extra_global_tyvars = tyVarsOfTypes [idType id | (name,id) <- names_w_ids]
296 th_lvl = thLevel (tcl_th_ctxt env)
297 proc_lvl = proc_level (tcl_arrow_ctxt env)
298 extra_env = [(name, ATcId id th_lvl proc_lvl) | (name,id) <- names_w_ids]
299 le' = extendNameEnvList (tcl_env env) extra_env
301 tc_extend_gtvs (tcl_tyvars env) extra_global_tyvars `thenM` \ gtvs' ->
302 setLclEnv (env {tcl_env = le', tcl_tyvars = gtvs'}) thing_inside
307 -----------------------
308 -- findGlobals looks at the value environment and finds values
309 -- whose types mention the offending type variable. It has to be
310 -- careful to zonk the Id's type first, so it has to be in the monad.
311 -- We must be careful to pass it a zonked type variable, too.
313 findGlobals :: TcTyVarSet
315 -> TcM (TidyEnv, [SDoc])
317 findGlobals tvs tidy_env
318 = getLclEnv `thenM` \ lcl_env ->
319 go tidy_env [] (lclEnvElts lcl_env)
321 go tidy_env acc [] = returnM (tidy_env, acc)
322 go tidy_env acc (thing : things)
323 = find_thing ignore_it tidy_env thing `thenM` \ (tidy_env1, maybe_doc) ->
325 Just d -> go tidy_env1 (d:acc) things
326 Nothing -> go tidy_env1 acc things
328 ignore_it ty = not (tvs `intersectsVarSet` tyVarsOfType ty)
330 -----------------------
331 find_thing ignore_it tidy_env (ATcId id _ _)
332 = zonkTcType (idType id) `thenM` \ id_ty ->
333 if ignore_it id_ty then
334 returnM (tidy_env, Nothing)
336 (tidy_env', tidy_ty) = tidyOpenType tidy_env id_ty
337 msg = sep [ppr id <+> dcolon <+> ppr tidy_ty,
338 nest 2 (parens (ptext SLIT("bound at") <+>
339 ppr (getSrcLoc id)))]
341 returnM (tidy_env', Just msg)
343 find_thing ignore_it tidy_env (ATyVar tv)
344 = zonkTcTyVar tv `thenM` \ tv_ty ->
345 if ignore_it tv_ty then
346 returnM (tidy_env, Nothing)
348 (tidy_env1, tv1) = tidyOpenTyVar tidy_env tv
349 (tidy_env2, tidy_ty) = tidyOpenType tidy_env1 tv_ty
350 msg = sep [ppr tv1 <+> eq_stuff, nest 2 bound_at]
352 eq_stuff | Just tv' <- Type.getTyVar_maybe tv_ty,
354 | otherwise = equals <+> ppr tidy_ty
355 -- It's ok to use Type.getTyVar_maybe because ty is zonked by now
357 bound_at = tyVarBindingInfo tv
359 returnM (tidy_env2, Just msg)
363 %************************************************************************
365 \subsection{The global tyvars}
367 %************************************************************************
370 tc_extend_gtvs gtvs extra_global_tvs
371 = readMutVar gtvs `thenM` \ global_tvs ->
372 newMutVar (global_tvs `unionVarSet` extra_global_tvs)
375 @tcGetGlobalTyVars@ returns a fully-zonked set of tyvars free in the environment.
376 To improve subsequent calls to the same function it writes the zonked set back into
380 tcGetGlobalTyVars :: TcM TcTyVarSet
382 = getLclEnv `thenM` \ (TcLclEnv {tcl_tyvars = gtv_var}) ->
383 readMutVar gtv_var `thenM` \ gbl_tvs ->
384 zonkTcTyVarsAndFV (varSetElems gbl_tvs) `thenM` \ gbl_tvs' ->
385 writeMutVar gtv_var gbl_tvs' `thenM_`
390 %************************************************************************
394 %************************************************************************
397 tcExtendRules :: [RuleDecl Id] -> TcM a -> TcM a
398 -- Just pop the new rules into the EPS and envt resp
399 -- All the rules come from an interface file, not soruce
400 -- Nevertheless, some may be for this module, if we read
401 -- its interface instead of its source code
402 tcExtendRules lcl_rules thing_inside
403 = do { env <- getGblEnv
405 env' = env { tcg_rules = lcl_rules ++ tcg_rules env }
406 ; setGblEnv env' thing_inside }
410 %************************************************************************
412 Arrow notation proc levels
414 %************************************************************************
417 checkProcLevel :: TcId -> ProcLevel -> TcM ()
418 checkProcLevel id id_lvl
419 = do { banned <- getBannedProcLevels
420 ; checkTc (not (id_lvl `elem` banned))
421 (procLevelErr id id_lvl) }
423 procLevelErr id id_lvl
424 = hang (ptext SLIT("Command-bound variable") <+> quotes (ppr id) <+> ptext SLIT("is not in scope here"))
425 4 (ptext SLIT("Reason: it is used in the left argument of (-<)"))
429 %************************************************************************
433 %************************************************************************
436 instance Outputable ThStage where
437 ppr Comp = text "Comp"
438 ppr (Brack l _ _) = text "Brack" <+> int l
439 ppr (Splice l) = text "Splice" <+> int l
442 thLevel :: ThStage -> ThLevel
443 thLevel Comp = topLevel
444 thLevel (Splice l) = l
445 thLevel (Brack l _ _) = l
448 checkWellStaged :: SDoc -- What the stage check is for
449 -> ThLevel -- Binding level
450 -> ThStage -- Use stage
451 -> TcM () -- Fail if badly staged, adding an error
452 checkWellStaged pp_thing bind_lvl use_stage
453 | bind_lvl <= use_lvl -- OK!
456 | bind_lvl == topLevel -- GHC restriction on top level splices
458 sep [ptext SLIT("GHC stage restriction:") <+> pp_thing,
459 nest 2 (ptext SLIT("is used in a top-level splice, and must be imported, not defined locally"))]
461 | otherwise -- Badly staged
463 ptext SLIT("Stage error:") <+> pp_thing <+>
464 hsep [ptext SLIT("is bound at stage") <+> ppr bind_lvl,
465 ptext SLIT("but used at stage") <+> ppr use_lvl]
467 use_lvl = thLevel use_stage
470 topIdLvl :: Id -> ThLevel
471 -- Globals may either be imported, or may be from an earlier "chunk"
472 -- (separated by declaration splices) of this module. The former
473 -- *can* be used inside a top-level splice, but the latter cannot.
474 -- Hence we give the former impLevel, but the latter topLevel
478 -- By the time we are prcessing the $(f x), the binding for "x"
479 -- will be in the global env, not the local one.
480 topIdLvl id | isLocalId id = topLevel
481 | otherwise = impLevel
483 -- Indicates the legal transitions on bracket( [| |] ).
484 bracketOK :: ThStage -> Maybe ThLevel
485 bracketOK (Brack _ _ _) = Nothing -- Bracket illegal inside a bracket
486 bracketOK stage = (Just (thLevel stage + 1))
488 -- Indicates the legal transitions on splice($).
489 spliceOK :: ThStage -> Maybe ThLevel
490 spliceOK (Splice _) = Nothing -- Splice illegal inside splice
491 spliceOK stage = Just (thLevel stage - 1)
493 tcMetaTy :: Name -> TcM Type
494 -- Given the name of a Template Haskell data type,
496 -- E.g. given the name "Expr" return the type "Expr"
498 = tcLookupTyCon tc_name `thenM` \ t ->
499 returnM (mkGenTyConApp t [])
500 -- Use mkGenTyConApp because it might be a synonym
504 %************************************************************************
506 \subsection{Making new Ids}
508 %************************************************************************
513 newLocalName :: Name -> TcM Name
514 newLocalName name -- Make a clone
515 = newUnique `thenM` \ uniq ->
516 returnM (mkInternalName uniq (getOccName name) (getSrcLoc name))
519 Make a name for the dict fun for an instance decl. It's a *local*
520 name for the moment. The CoreTidy pass will externalise it. Even in
521 --make and ghci stuff, we rebuild the instance environment each time,
522 so the dfun id is internal to begin with, and external when compiling
526 newDFunName :: Class -> [Type] -> SrcLoc -> TcM Name
527 newDFunName clas (ty:_) loc
528 = newUnique `thenM` \ uniq ->
529 returnM (mkInternalName uniq (mkDFunOcc dfun_string) loc)
531 -- Any string that is somewhat unique will do
532 dfun_string = occNameString (getOccName clas) ++ occNameString (getDFunTyKey ty)
534 newDFunName clas [] loc = pprPanic "newDFunName" (ppr clas <+> ppr loc)
538 %************************************************************************
540 \subsection{The InstInfo type}
542 %************************************************************************
544 The InstInfo type summarises the information in an instance declaration
546 instance c => k (t tvs) where b
548 It is used just for *local* instance decls (not ones from interface files).
549 But local instance decls includes
552 as well as explicit user written ones.
557 iDFunId :: DFunId, -- The dfun id
558 iBinds :: InstBindings
562 = VanillaInst -- The normal case
563 RenamedMonoBinds -- Bindings
564 [RenamedSig] -- User pragmas recorded for generating
565 -- specialised instances
567 | NewTypeDerived -- Used for deriving instances of newtypes, where the
568 [Type] -- witness dictionary is identical to the argument
569 -- dictionary. Hence no bindings, no pragmas
570 -- The [Type] are the representation types
571 -- See notes in TcDeriv
573 pprInstInfo info = vcat [ptext SLIT("InstInfo:") <+> ppr (idType (iDFunId info))]
575 pprInstInfoDetails (InstInfo { iBinds = VanillaInst b _ }) = ppr b
576 pprInstInfoDetails (InstInfo { iBinds = NewTypeDerived _}) = text "Derived from the representation type"
578 simpleInstInfoTy :: InstInfo -> Type
579 simpleInstInfoTy info = case tcSplitDFunTy (idType (iDFunId info)) of
580 (_, _, _, [ty]) -> ty
582 simpleInstInfoTyCon :: InstInfo -> TyCon
583 -- Gets the type constructor for a simple instance declaration,
584 -- i.e. one of the form instance (...) => C (T a b c) where ...
585 simpleInstInfoTyCon inst = tcTyConAppTyCon (simpleInstInfoTy inst)
589 %************************************************************************
593 %************************************************************************
596 notFound wheRe name = failWithTc (text wheRe <> colon <+> quotes (ppr name) <+>
597 ptext SLIT("is not in scope"))