3 TyThing(..), TyThingDetails(..), TcTyThing(..), TcId,
5 -- Instance environment, and InstInfo type
6 tcGetInstEnv, tcSetInstEnv,
7 InstInfo(..), pprInstInfo, pprInstInfoDetails,
8 simpleInstInfoTy, simpleInstInfoTyCon,
14 tcExtendGlobalTypeEnv,
15 tcLookupTyCon, tcLookupClass, tcLookupDataCon,
16 tcLookupGlobal_maybe, tcLookupGlobal, tcLookupGlobalId,
21 tcExtendTyVarEnv, tcExtendTyVarEnv2,
22 tcExtendLocalValEnv, tcExtendLocalValEnv2,
23 tcLookup, tcLookupLocalIds, tcLookup_maybe,
24 tcLookupId, tcLookupIdLvl,
25 lclEnvElts, getInLocalScope, findGlobals,
27 -- Instance environment
28 tcExtendLocalInstEnv, tcExtendInstEnv,
33 -- Global type variables
36 -- Random useful things
37 RecTcGblEnv, tcLookupRecId_maybe,
39 -- Template Haskell stuff
40 wellStaged, spliceOK, bracketOK, tcMetaTy, metaLevel,
43 newLocalName, newDFunName,
49 #include "HsVersions.h"
51 import RnHsSyn ( RenamedMonoBinds, RenamedSig )
52 import HsSyn ( RuleDecl(..), ifaceRuleDeclName )
54 import TcMType ( zonkTcType, zonkTcTyVar, zonkTcTyVarsAndFV )
55 import TcType ( Type, ThetaType, TcKind, TcTyVar, TcTyVarSet,
56 tyVarsOfType, tyVarsOfTypes, tcSplitDFunTy, mkGenTyConApp,
57 getDFunTyKey, tcTyConAppTyCon, tyVarBindingInfo,
58 tidyOpenType, tidyOpenTyVar
60 import qualified Type ( getTyVar_maybe )
61 import Rules ( extendRuleBase )
62 import Id ( idName, isLocalId, isDataConWrapId_maybe )
63 import Var ( TyVar, Id, idType )
66 import CoreSyn ( IdCoreRule )
67 import DataCon ( DataCon )
68 import TyCon ( TyCon, DataConDetails )
69 import Class ( Class, ClassOpItem )
70 import Name ( Name, NamedThing(..),
71 getSrcLoc, mkInternalName, nameIsLocalOrFrom
74 import OccName ( mkDFunOcc, occNameString )
75 import HscTypes ( DFunId, TypeEnv, extendTypeEnvList,
76 TyThing(..), ExternalPackageState(..) )
77 import Rules ( RuleBase )
78 import BasicTypes ( EP )
79 import Module ( Module )
80 import InstEnv ( InstEnv, extendInstEnv )
81 import Maybes ( seqMaybe )
82 import SrcLoc ( SrcLoc )
84 import Maybe ( isJust )
85 import List ( partition )
89 %************************************************************************
93 %************************************************************************
96 instance Outputable Stage where
97 ppr Comp = text "Comp"
98 ppr (Brack l _ _) = text "Brack" <+> int l
99 ppr (Splice l) = text "Splice" <+> int l
102 metaLevel :: Stage -> Level
103 metaLevel Comp = topLevel
104 metaLevel (Splice l) = l
105 metaLevel (Brack l _ _) = l
107 wellStaged :: Level -- Binding level
108 -> Level -- Use level
110 wellStaged bind_stage use_stage
111 = bind_stage <= use_stage
113 -- Indicates the legal transitions on bracket( [| |] ).
114 bracketOK :: Stage -> Maybe Level
115 bracketOK (Brack _ _ _) = Nothing -- Bracket illegal inside a bracket
116 bracketOK stage = (Just (metaLevel stage + 1))
118 -- Indicates the legal transitions on splice($).
119 spliceOK :: Stage -> Maybe Level
120 spliceOK (Splice _) = Nothing -- Splice illegal inside splice
121 spliceOK stage = Just (metaLevel stage - 1)
123 tcMetaTy :: Name -> TcM Type
124 -- Given the name of a Template Haskell data type,
126 -- E.g. given the name "Expr" return the type "Expr"
128 = tcLookupTyCon tc_name `thenM` \ t ->
129 returnM (mkGenTyConApp t [])
130 -- Use mkGenTyConApp because it might be a synonym
134 %************************************************************************
136 \subsection{TyThingDetails}
138 %************************************************************************
140 This data type is used to help tie the knot
141 when type checking type and class declarations
144 data TyThingDetails = SynTyDetails Type
145 | DataTyDetails ThetaType (DataConDetails DataCon) [Id] (Maybe (EP Id))
146 | ClassDetails ThetaType [Id] [ClassOpItem] DataCon Name
147 -- The Name is the Name of the implicit TyCon for the class
148 | ForeignTyDetails -- Nothing yet
152 %************************************************************************
154 \subsection{Basic lookups}
156 %************************************************************************
159 type RecTcGblEnv = TcGblEnv
160 -- This environment is used for getting the 'right' IdInfo
161 -- on imported things and for looking up Ids in unfoldings
162 -- The environment doesn't have any local Ids in it
164 tcLookupRecId_maybe :: RecTcGblEnv -> Name -> Maybe Id
165 tcLookupRecId_maybe env name = case lookup_global env name of
166 Just (AnId id) -> Just id
170 %************************************************************************
172 \subsection{Making new Ids}
174 %************************************************************************
179 newLocalName :: Name -> TcM Name
180 newLocalName name -- Make a clone
181 = newUnique `thenM` \ uniq ->
182 returnM (mkInternalName uniq (getOccName name) (getSrcLoc name))
185 Make a name for the dict fun for an instance decl.
186 It's a *local* name for the moment. The CoreTidy pass
190 newDFunName :: Class -> [Type] -> SrcLoc -> TcM Name
191 newDFunName clas (ty:_) loc
192 = newUnique `thenM` \ uniq ->
193 returnM (mkInternalName uniq (mkDFunOcc dfun_string) loc)
195 -- Any string that is somewhat unique will do
196 dfun_string = occNameString (getOccName clas) ++ occNameString (getDFunTyKey ty)
198 newDFunName clas [] loc = pprPanic "newDFunName" (ppr clas <+> ppr loc)
202 isLocalThing :: NamedThing a => Module -> a -> Bool
203 isLocalThing mod thing = nameIsLocalOrFrom mod (getName thing)
206 %************************************************************************
208 \subsection{The global environment}
210 %************************************************************************
213 tcExtendGlobalEnv :: [TyThing] -> TcM r -> TcM r
214 -- Given a mixture of Ids, TyCons, Classes, perhaps from the
215 -- module being compiled, perhaps from a package module,
216 -- extend the global environment, and update the EPS
217 tcExtendGlobalEnv things thing_inside
221 ; let mod = tcg_mod env
222 (lcl_things, pkg_things) = partition (isLocalThing mod) things
223 ge' = extendTypeEnvList (tcg_type_env env) lcl_things
224 eps' = eps { eps_PTE = extendTypeEnvList (eps_PTE eps) pkg_things }
225 ist' = mkImpTypeEnv eps' hpt
227 ; setGblEnv (env {tcg_type_env = ge', tcg_ist = ist'}) thing_inside }
229 tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a
230 -- Same deal as tcExtendGlobalEnv, but for Ids
231 tcExtendGlobalValEnv ids thing_inside
232 = tcExtendGlobalEnv [AnId id | id <- ids] thing_inside
234 tcExtendGlobalTypeEnv :: TypeEnv -> TcM r -> TcM r
235 -- Top-level things of the interactive context
236 -- No need to extend the package env
237 tcExtendGlobalTypeEnv extra_env thing_inside
238 = do { env <- getGblEnv
239 ; let ge' = tcg_type_env env `plusNameEnv` extra_env
240 ; setGblEnv (env {tcg_type_env = ge'}) thing_inside }
245 lookup_global :: TcGblEnv -> Name -> Maybe TyThing
246 -- Try the global envt and then the global symbol table
247 lookup_global env name
248 = lookupNameEnv (tcg_type_env env) name
252 tcLookupGlobal_maybe :: Name -> TcRn m (Maybe TyThing)
253 tcLookupGlobal_maybe name
254 = getGblEnv `thenM` \ env ->
255 returnM (lookup_global env name)
258 A variety of global lookups, when we know what we are looking for.
261 tcLookupGlobal :: Name -> TcM TyThing
263 = tcLookupGlobal_maybe name `thenM` \ maybe_thing ->
265 Just thing -> returnM thing
266 other -> notFound "tcLookupGlobal" name
268 tcLookupGlobalId :: Name -> TcM Id
269 tcLookupGlobalId name
270 = tcLookupGlobal_maybe name `thenM` \ maybe_thing ->
272 Just (AnId id) -> returnM id
273 other -> notFound "tcLookupGlobal" name
275 tcLookupDataCon :: Name -> TcM DataCon
276 tcLookupDataCon con_name
277 = tcLookupGlobalId con_name `thenM` \ con_id ->
278 case isDataConWrapId_maybe con_id of
279 Just data_con -> returnM data_con
280 Nothing -> failWithTc (badCon con_id)
282 tcLookupClass :: Name -> TcM Class
284 = tcLookupGlobal_maybe name `thenM` \ maybe_clas ->
286 Just (AClass clas) -> returnM clas
287 other -> notFound "tcLookupClass" name
289 tcLookupTyCon :: Name -> TcM TyCon
291 = tcLookupGlobal_maybe name `thenM` \ maybe_tc ->
293 Just (ATyCon tc) -> returnM tc
294 other -> notFound "tcLookupTyCon" name
297 getInGlobalScope :: TcRn m (Name -> Bool)
298 getInGlobalScope = do { gbl_env <- getGblEnv ;
299 return (\n -> isJust (lookup_global gbl_env n)) }
303 %************************************************************************
305 \subsection{The local environment}
307 %************************************************************************
310 tcLookup_maybe :: Name -> TcM (Maybe TcTyThing)
312 = getLclEnv `thenM` \ local_env ->
313 case lookupNameEnv (tcl_env local_env) name of
314 Just thing -> returnM (Just thing)
315 Nothing -> tcLookupGlobal_maybe name `thenM` \ mb_res ->
316 returnM (case mb_res of
317 Just thing -> Just (AGlobal thing)
320 tcLookup :: Name -> TcM TcTyThing
322 = tcLookup_maybe name `thenM` \ maybe_thing ->
324 Just thing -> returnM thing
325 other -> notFound "tcLookup" name
326 -- Extract the IdInfo from an IfaceSig imported from an interface file
328 tcLookupId :: Name -> TcM Id
329 -- Used when we aren't interested in the binding level
331 = tcLookup name `thenM` \ thing ->
333 ATcId tc_id lvl -> returnM tc_id
334 AGlobal (AnId id) -> returnM id
335 other -> pprPanic "tcLookupId" (ppr name)
337 tcLookupIdLvl :: Name -> TcM (Id, Level)
339 = tcLookup name `thenM` \ thing ->
341 ATcId tc_id lvl -> returnM (tc_id, lvl)
342 AGlobal (AnId id) -- See [Note: Levels]
343 | isLocalId id -> returnM (id, topLevel)
344 | otherwise -> returnM (id, impLevel)
345 other -> pprPanic "tcLookupIdLvl" (ppr name)
348 -- Globals may either be imported, or may be from an earlier "chunk"
349 -- (separated by declaration splices) of this module. The former
350 -- *can* be used inside a top-level splice, but the latter cannot.
351 -- Hence we give the former impLevel, but the latter topLevel
355 -- By the time we are prcessing the $(f x), the binding for "x"
356 -- will be in the global env, not the local one.
358 tcLookupLocalIds :: [Name] -> TcM [TcId]
359 -- We expect the variables to all be bound, and all at
360 -- the same level as the lookup. Only used in one place...
362 = getLclEnv `thenM` \ env ->
363 returnM (map (lookup (tcl_env env) (metaLevel (tcl_level env))) ns)
366 = case lookupNameEnv lenv name of
367 Just (ATcId id lvl1) -> ASSERT( lvl == lvl1 ) id
368 other -> pprPanic "tcLookupLocalIds" (ppr name)
370 lclEnvElts :: TcLclEnv -> [TcTyThing]
371 lclEnvElts env = nameEnvElts (tcl_env env)
373 getInLocalScope :: TcM (Name -> Bool)
375 getInLocalScope = getLclEnv `thenM` \ env ->
377 lcl_env = tcl_env env
379 return (`elemNameEnv` lcl_env)
383 tcExtendKindEnv :: [(Name,TcKind)] -> TcM r -> TcM r
384 tcExtendKindEnv pairs thing_inside
385 = updLclEnv upd thing_inside
387 upd lcl_env = lcl_env { tcl_env = extend (tcl_env lcl_env) }
388 extend env = extendNameEnvList env [(n, AThing k) | (n,k) <- pairs]
389 -- No need to extend global tyvars for kind checking
391 tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r
392 tcExtendTyVarEnv tvs thing_inside
393 = tc_extend_tv_env [(getName tv, ATyVar tv) | tv <- tvs] tvs thing_inside
395 tcExtendTyVarEnv2 :: [(TyVar,TcTyVar)] -> TcM r -> TcM r
396 tcExtendTyVarEnv2 tv_pairs thing_inside
397 = tc_extend_tv_env [(getName tv1, ATyVar tv2) | (tv1,tv2) <- tv_pairs]
398 [tv | (_,tv) <- tv_pairs]
401 tc_extend_tv_env binds tyvars thing_inside
402 = getLclEnv `thenM` \ env@(TcLclEnv {tcl_env = le, tcl_tyvars = gtvs}) ->
404 le' = extendNameEnvList le binds
405 new_tv_set = mkVarSet tyvars
407 -- It's important to add the in-scope tyvars to the global tyvar set
409 -- f (x::r) = let g y = y::r in ...
410 -- Here, g mustn't be generalised. This is also important during
411 -- class and instance decls, when we mustn't generalise the class tyvars
412 -- when typechecking the methods.
413 tc_extend_gtvs gtvs new_tv_set `thenM` \ gtvs' ->
414 setLclEnv (env {tcl_env = le', tcl_tyvars = gtvs'}) thing_inside
419 tcExtendLocalValEnv :: [TcId] -> TcM a -> TcM a
420 tcExtendLocalValEnv ids thing_inside
421 = getLclEnv `thenM` \ env ->
423 extra_global_tyvars = tyVarsOfTypes [idType id | id <- ids]
424 lvl = metaLevel (tcl_level env)
425 extra_env = [(idName id, ATcId id lvl) | id <- ids]
426 le' = extendNameEnvList (tcl_env env) extra_env
428 tc_extend_gtvs (tcl_tyvars env) extra_global_tyvars `thenM` \ gtvs' ->
429 setLclEnv (env {tcl_env = le', tcl_tyvars = gtvs'}) thing_inside
431 tcExtendLocalValEnv2 :: [(Name,TcId)] -> TcM a -> TcM a
432 tcExtendLocalValEnv2 names_w_ids thing_inside
433 = getLclEnv `thenM` \ env ->
435 extra_global_tyvars = tyVarsOfTypes [idType id | (name,id) <- names_w_ids]
436 lvl = metaLevel (tcl_level env)
437 extra_env = [(name, ATcId id lvl) | (name,id) <- names_w_ids]
438 le' = extendNameEnvList (tcl_env env) extra_env
440 tc_extend_gtvs (tcl_tyvars env) extra_global_tyvars `thenM` \ gtvs' ->
441 setLclEnv (env {tcl_env = le', tcl_tyvars = gtvs'}) thing_inside
446 -----------------------
447 -- findGlobals looks at the value environment and finds values
448 -- whose types mention the offending type variable. It has to be
449 -- careful to zonk the Id's type first, so it has to be in the monad.
450 -- We must be careful to pass it a zonked type variable, too.
452 findGlobals :: TcTyVarSet
454 -> TcM (TidyEnv, [SDoc])
456 findGlobals tvs tidy_env
457 = getLclEnv `thenM` \ lcl_env ->
458 go tidy_env [] (lclEnvElts lcl_env)
460 go tidy_env acc [] = returnM (tidy_env, acc)
461 go tidy_env acc (thing : things)
462 = find_thing ignore_it tidy_env thing `thenM` \ (tidy_env1, maybe_doc) ->
464 Just d -> go tidy_env1 (d:acc) things
465 Nothing -> go tidy_env1 acc things
467 ignore_it ty = not (tvs `intersectsVarSet` tyVarsOfType ty)
469 -----------------------
470 find_thing ignore_it tidy_env (ATcId id _)
471 = zonkTcType (idType id) `thenM` \ id_ty ->
472 if ignore_it id_ty then
473 returnM (tidy_env, Nothing)
475 (tidy_env', tidy_ty) = tidyOpenType tidy_env id_ty
476 msg = sep [ppr id <+> dcolon <+> ppr tidy_ty,
477 nest 2 (parens (ptext SLIT("bound at") <+>
478 ppr (getSrcLoc id)))]
480 returnM (tidy_env', Just msg)
482 find_thing ignore_it tidy_env (ATyVar tv)
483 = zonkTcTyVar tv `thenM` \ tv_ty ->
484 if ignore_it tv_ty then
485 returnM (tidy_env, Nothing)
487 (tidy_env1, tv1) = tidyOpenTyVar tidy_env tv
488 (tidy_env2, tidy_ty) = tidyOpenType tidy_env1 tv_ty
489 msg = sep [ppr tv1 <+> eq_stuff, nest 2 bound_at]
491 eq_stuff | Just tv' <- Type.getTyVar_maybe tv_ty, tv == tv' = empty
492 | otherwise = equals <+> ppr tv_ty
493 -- It's ok to use Type.getTyVar_maybe because ty is zonked by now
495 bound_at = tyVarBindingInfo tv
497 returnM (tidy_env2, Just msg)
501 %************************************************************************
503 \subsection{The global tyvars}
505 %************************************************************************
508 tc_extend_gtvs gtvs extra_global_tvs
509 = readMutVar gtvs `thenM` \ global_tvs ->
510 newMutVar (global_tvs `unionVarSet` extra_global_tvs)
513 @tcGetGlobalTyVars@ returns a fully-zonked set of tyvars free in the environment.
514 To improve subsequent calls to the same function it writes the zonked set back into
518 tcGetGlobalTyVars :: TcM TcTyVarSet
520 = getLclEnv `thenM` \ (TcLclEnv {tcl_tyvars = gtv_var}) ->
521 readMutVar gtv_var `thenM` \ gbl_tvs ->
522 zonkTcTyVarsAndFV (varSetElems gbl_tvs) `thenM` \ gbl_tvs' ->
523 writeMutVar gtv_var gbl_tvs' `thenM_`
528 %************************************************************************
530 \subsection{The instance environment}
532 %************************************************************************
535 tcGetInstEnv :: TcM InstEnv
536 tcGetInstEnv = getGblEnv `thenM` \ env ->
537 returnM (tcg_inst_env env)
539 tcSetInstEnv :: InstEnv -> TcM a -> TcM a
540 tcSetInstEnv ie thing_inside
541 = getGblEnv `thenM` \ env ->
542 setGblEnv (env {tcg_inst_env = ie}) thing_inside
544 tcExtendInstEnv :: [DFunId] -> TcM a -> TcM a
545 -- Add instances from local or imported
546 -- instances, and refresh the instance-env cache
547 tcExtendInstEnv dfuns thing_inside
548 = do { dflags <- getDOpts
552 -- Extend the total inst-env with the new dfuns
553 (inst_env', errs) = extendInstEnv dflags (tcg_inst_env env) dfuns
555 -- Sort the ones from this module from the others
556 (lcl_dfuns, pkg_dfuns) = partition (isLocalThing mod) dfuns
559 -- And add the pieces to the right places
560 (eps_inst_env', _) = extendInstEnv dflags (eps_inst_env eps) pkg_dfuns
561 eps' = eps { eps_inst_env = eps_inst_env' }
563 env' = env { tcg_inst_env = inst_env',
564 tcg_insts = lcl_dfuns ++ tcg_insts env }
569 ; setGblEnv env' thing_inside }
571 tcExtendLocalInstEnv :: [InstInfo] -> TcM a -> TcM a
572 -- Special case for local instance decls
573 tcExtendLocalInstEnv infos thing_inside
574 = do { dflags <- getDOpts
577 dfuns = map iDFunId infos
578 (inst_env', errs) = extendInstEnv dflags (tcg_inst_env env) dfuns
579 env' = env { tcg_inst_env = inst_env',
580 tcg_insts = dfuns ++ tcg_insts env }
583 ; setGblEnv env' thing_inside }
586 = traceTc (text "Adding instances:" <+> vcat (map pp dfuns))
588 pp dfun = ppr dfun <+> dcolon <+> ppr (idType dfun)
592 %************************************************************************
596 %************************************************************************
599 tcExtendRules :: [RuleDecl Id] -> TcM a -> TcM a
600 -- Just pop the new rules into the EPS and envt resp
601 -- All the rules come from an interface file, not soruce
602 -- Nevertheless, some may be for this module, if we read
603 -- its interface instead of its source code
604 tcExtendRules rules thing_inside
608 (lcl_rules, pkg_rules) = partition is_local_rule rules
609 is_local_rule = isLocalThing mod . ifaceRuleDeclName
612 core_rules = [(id,rule) | IfaceRuleOut id rule <- pkg_rules]
613 eps' = eps { eps_rule_base = addIfaceRules (eps_rule_base eps) core_rules }
614 -- All the rules from an interface are of the IfaceRuleOut form
616 env' = env { tcg_rules = lcl_rules ++ tcg_rules env }
619 ; setGblEnv env' thing_inside }
621 addIfaceRules :: RuleBase -> [IdCoreRule] -> RuleBase
622 addIfaceRules rule_base rules
623 = foldl extendRuleBase rule_base rules
627 %************************************************************************
629 \subsection{The InstInfo type}
631 %************************************************************************
633 The InstInfo type summarises the information in an instance declaration
635 instance c => k (t tvs) where b
637 It is used just for *local* instance decls (not ones from interface files).
638 But local instance decls includes
641 as well as explicit user written ones.
646 iDFunId :: DFunId, -- The dfun id
647 iBinds :: InstBindings
651 = VanillaInst -- The normal case
652 RenamedMonoBinds -- Bindings
653 [RenamedSig] -- User pragmas recorded for generating
654 -- specialised instances
656 | NewTypeDerived -- Used for deriving instances of newtypes, where the
657 [Type] -- witness dictionary is identical to the argument
658 -- dictionary. Hence no bindings, no pragmas
659 -- The [Type] are the representation types
660 -- See notes in TcDeriv
662 pprInstInfo info = vcat [ptext SLIT("InstInfo:") <+> ppr (idType (iDFunId info))]
664 pprInstInfoDetails (InstInfo { iBinds = VanillaInst b _ }) = ppr b
665 pprInstInfoDetails (InstInfo { iBinds = NewTypeDerived _}) = text "Derived from the representation type"
667 simpleInstInfoTy :: InstInfo -> Type
668 simpleInstInfoTy info = case tcSplitDFunTy (idType (iDFunId info)) of
669 (_, _, _, [ty]) -> ty
671 simpleInstInfoTyCon :: InstInfo -> TyCon
672 -- Gets the type constructor for a simple instance declaration,
673 -- i.e. one of the form instance (...) => C (T a b c) where ...
674 simpleInstInfoTyCon inst = tcTyConAppTyCon (simpleInstInfoTy inst)
678 %************************************************************************
682 %************************************************************************
685 badCon con_id = quotes (ppr con_id) <+> ptext SLIT("is not a data constructor")
687 notFound wheRe name = failWithTc (text wheRe <> colon <+> quotes (ppr name) <+>
688 ptext SLIT("is not in scope"))