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 getLclEnvElts, getInLocalScope,
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 ( zonkTcTyVarsAndFV )
55 import TcType ( Type, ThetaType, TcKind, TcTyVar, TcTyVarSet,
56 tyVarsOfTypes, tcSplitDFunTy, mkGenTyConApp,
57 getDFunTyKey, tcTyConAppTyCon,
59 import Rules ( extendRuleBase )
60 import Id ( idName, isDataConWrapId_maybe )
61 import Var ( TyVar, Id, idType )
63 import CoreSyn ( IdCoreRule )
64 import DataCon ( DataCon )
65 import TyCon ( TyCon, DataConDetails )
66 import Class ( Class, ClassOpItem )
67 import Name ( Name, NamedThing(..),
68 getSrcLoc, mkInternalName, nameIsLocalOrFrom
71 import OccName ( mkDFunOcc, occNameString )
72 import HscTypes ( DFunId, TypeEnv, extendTypeEnvList,
73 TyThing(..), ExternalPackageState(..) )
74 import Rules ( RuleBase )
75 import BasicTypes ( EP )
76 import Module ( Module )
77 import InstEnv ( InstEnv, extendInstEnv )
78 import Maybes ( seqMaybe )
79 import SrcLoc ( SrcLoc )
81 import Maybe ( isJust )
82 import List ( partition )
86 %************************************************************************
90 %************************************************************************
93 instance Outputable Stage where
94 ppr Comp = text "Comp"
95 ppr (Brack l _ _) = text "Brack" <+> int l
96 ppr (Splice l) = text "Splice" <+> int l
99 metaLevel :: Stage -> Level
100 metaLevel Comp = topLevel
101 metaLevel (Splice l) = l
102 metaLevel (Brack l _ _) = l
104 wellStaged :: Level -- Binding level
105 -> Level -- Use level
107 wellStaged bind_stage use_stage
108 = bind_stage <= use_stage
110 -- Indicates the legal transitions on bracket( [| |] ).
111 bracketOK :: Stage -> Maybe Level
112 bracketOK (Brack _ _ _) = Nothing -- Bracket illegal inside a bracket
113 bracketOK stage = (Just (metaLevel stage + 1))
115 -- Indicates the legal transitions on splice($).
116 spliceOK :: Stage -> Maybe Level
117 spliceOK (Splice _) = Nothing -- Splice illegal inside splice
118 spliceOK stage = Just (metaLevel stage - 1)
120 tcMetaTy :: Name -> TcM Type
121 -- Given the name of a Template Haskell data type,
123 -- E.g. given the name "Expr" return the type "Expr"
125 = tcLookupTyCon tc_name `thenM` \ t ->
126 returnM (mkGenTyConApp t [])
127 -- Use mkGenTyConApp because it might be a synonym
131 %************************************************************************
133 \subsection{TyThingDetails}
135 %************************************************************************
137 This data type is used to help tie the knot
138 when type checking type and class declarations
141 data TyThingDetails = SynTyDetails Type
142 | DataTyDetails ThetaType (DataConDetails DataCon) [Id] (Maybe (EP Id))
143 | ClassDetails ThetaType [Id] [ClassOpItem] DataCon Name
144 -- The Name is the Name of the implicit TyCon for the class
145 | ForeignTyDetails -- Nothing yet
149 %************************************************************************
151 \subsection{Basic lookups}
153 %************************************************************************
156 type RecTcGblEnv = TcGblEnv
157 -- This environment is used for getting the 'right' IdInfo
158 -- on imported things and for looking up Ids in unfoldings
159 -- The environment doesn't have any local Ids in it
161 tcLookupRecId_maybe :: RecTcGblEnv -> Name -> Maybe Id
162 tcLookupRecId_maybe env name = case lookup_global env name of
163 Just (AnId id) -> Just id
167 %************************************************************************
169 \subsection{Making new Ids}
171 %************************************************************************
176 newLocalName :: Name -> TcM Name
177 newLocalName name -- Make a clone
178 = newUnique `thenM` \ uniq ->
179 returnM (mkInternalName uniq (getOccName name) (getSrcLoc name))
182 Make a name for the dict fun for an instance decl.
183 It's a *local* name for the moment. The CoreTidy pass
187 newDFunName :: Class -> [Type] -> SrcLoc -> TcM Name
188 newDFunName clas (ty:_) loc
189 = newUnique `thenM` \ uniq ->
190 returnM (mkInternalName uniq (mkDFunOcc dfun_string) loc)
192 -- Any string that is somewhat unique will do
193 dfun_string = occNameString (getOccName clas) ++ occNameString (getDFunTyKey ty)
195 newDFunName clas [] loc = pprPanic "newDFunName" (ppr clas <+> ppr loc)
199 isLocalThing :: NamedThing a => Module -> a -> Bool
200 isLocalThing mod thing = nameIsLocalOrFrom mod (getName thing)
203 %************************************************************************
205 \subsection{The global environment}
207 %************************************************************************
210 tcExtendGlobalEnv :: [TyThing] -> TcM r -> TcM r
211 -- Given a mixture of Ids, TyCons, Classes, perhaps from the
212 -- module being compiled, perhaps from a package module,
213 -- extend the global environment, and update the EPS
214 tcExtendGlobalEnv things thing_inside
218 ; let mod = tcg_mod env
219 (lcl_things, pkg_things) = partition (isLocalThing mod) things
220 ge' = extendTypeEnvList (tcg_type_env env) lcl_things
221 eps' = eps { eps_PTE = extendTypeEnvList (eps_PTE eps) pkg_things }
222 ist' = mkImpTypeEnv eps' hpt
224 ; setGblEnv (env {tcg_type_env = ge', tcg_ist = ist'}) thing_inside }
226 tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a
227 -- Same deal as tcExtendGlobalEnv, but for Ids
228 tcExtendGlobalValEnv ids thing_inside
229 = tcExtendGlobalEnv [AnId id | id <- ids] thing_inside
231 tcExtendGlobalTypeEnv :: TypeEnv -> TcM r -> TcM r
232 -- Top-level things of the interactive context
233 -- No need to extend the package env
234 tcExtendGlobalTypeEnv extra_env thing_inside
235 = do { env <- getGblEnv
236 ; let ge' = tcg_type_env env `plusNameEnv` extra_env
237 ; setGblEnv (env {tcg_type_env = ge'}) thing_inside }
242 lookup_global :: TcGblEnv -> Name -> Maybe TyThing
243 -- Try the global envt and then the global symbol table
244 lookup_global env name
245 = lookupNameEnv (tcg_type_env env) name
249 tcLookupGlobal_maybe :: Name -> TcRn m (Maybe TyThing)
250 tcLookupGlobal_maybe name
251 = getGblEnv `thenM` \ env ->
252 returnM (lookup_global env name)
255 A variety of global lookups, when we know what we are looking for.
258 tcLookupGlobal :: Name -> TcM TyThing
260 = tcLookupGlobal_maybe name `thenM` \ maybe_thing ->
262 Just thing -> returnM thing
263 other -> notFound "tcLookupGlobal" name
265 tcLookupGlobalId :: Name -> TcM Id
266 tcLookupGlobalId name
267 = tcLookupGlobal_maybe name `thenM` \ maybe_thing ->
269 Just (AnId id) -> returnM id
270 other -> notFound "tcLookupGlobal" name
272 tcLookupDataCon :: Name -> TcM DataCon
273 tcLookupDataCon con_name
274 = tcLookupGlobalId con_name `thenM` \ con_id ->
275 case isDataConWrapId_maybe con_id of
276 Just data_con -> returnM data_con
277 Nothing -> failWithTc (badCon con_id)
279 tcLookupClass :: Name -> TcM Class
281 = tcLookupGlobal_maybe name `thenM` \ maybe_clas ->
283 Just (AClass clas) -> returnM clas
284 other -> notFound "tcLookupClass" name
286 tcLookupTyCon :: Name -> TcM TyCon
288 = tcLookupGlobal_maybe name `thenM` \ maybe_tc ->
290 Just (ATyCon tc) -> returnM tc
291 other -> notFound "tcLookupTyCon" name
294 getInGlobalScope :: TcRn m (Name -> Bool)
295 getInGlobalScope = do { gbl_env <- getGblEnv ;
296 return (\n -> isJust (lookup_global gbl_env n)) }
300 %************************************************************************
302 \subsection{The local environment}
304 %************************************************************************
307 tcLookup_maybe :: Name -> TcM (Maybe TcTyThing)
309 = getLclEnv `thenM` \ local_env ->
310 case lookupNameEnv (tcl_env local_env) name of
311 Just thing -> returnM (Just thing)
312 Nothing -> tcLookupGlobal_maybe name `thenM` \ mb_res ->
313 returnM (case mb_res of
314 Just thing -> Just (AGlobal thing)
317 tcLookup :: Name -> TcM TcTyThing
319 = tcLookup_maybe name `thenM` \ maybe_thing ->
321 Just thing -> returnM thing
322 other -> notFound "tcLookup" name
323 -- Extract the IdInfo from an IfaceSig imported from an interface file
325 tcLookupId :: Name -> TcM Id
326 -- Used when we aren't interested in the binding level
328 = tcLookup name `thenM` \ thing ->
330 ATcId tc_id lvl -> returnM tc_id
331 AGlobal (AnId id) -> returnM id
332 other -> pprPanic "tcLookupId" (ppr name)
334 tcLookupIdLvl :: Name -> TcM (Id, Level)
336 = tcLookup name `thenM` \ thing ->
338 ATcId tc_id lvl -> returnM (tc_id, lvl)
339 AGlobal (AnId id) -> returnM (id, impLevel)
340 other -> pprPanic "tcLookupIdLvl" (ppr name)
342 tcLookupLocalIds :: [Name] -> TcM [TcId]
343 -- We expect the variables to all be bound, and all at
344 -- the same level as the lookup. Only used in one place...
346 = getLclEnv `thenM` \ env ->
347 returnM (map (lookup (tcl_env env) (metaLevel (tcl_level env))) ns)
350 = case lookupNameEnv lenv name of
351 Just (ATcId id lvl1) -> ASSERT( lvl == lvl1 ) id
352 other -> pprPanic "tcLookupLocalIds" (ppr name)
354 getLclEnvElts :: TcM [TcTyThing]
355 getLclEnvElts = getLclEnv `thenM` \ env ->
356 return (nameEnvElts (tcl_env env))
358 getInLocalScope :: TcM (Name -> Bool)
360 getInLocalScope = getLclEnv `thenM` \ env ->
362 lcl_env = tcl_env env
364 return (`elemNameEnv` lcl_env)
368 tcExtendKindEnv :: [(Name,TcKind)] -> TcM r -> TcM r
369 tcExtendKindEnv pairs thing_inside
370 = updLclEnv upd thing_inside
372 upd lcl_env = lcl_env { tcl_env = extend (tcl_env lcl_env) }
373 extend env = extendNameEnvList env [(n, AThing k) | (n,k) <- pairs]
374 -- No need to extend global tyvars for kind checking
376 tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r
377 tcExtendTyVarEnv tvs thing_inside
378 = tc_extend_tv_env [(getName tv, ATyVar tv) | tv <- tvs] tvs thing_inside
380 tcExtendTyVarEnv2 :: [(TyVar,TcTyVar)] -> TcM r -> TcM r
381 tcExtendTyVarEnv2 tv_pairs thing_inside
382 = tc_extend_tv_env [(getName tv1, ATyVar tv2) | (tv1,tv2) <- tv_pairs]
383 [tv | (_,tv) <- tv_pairs]
386 tc_extend_tv_env binds tyvars thing_inside
387 = getLclEnv `thenM` \ env@(TcLclEnv {tcl_env = le, tcl_tyvars = gtvs}) ->
389 le' = extendNameEnvList le binds
390 new_tv_set = mkVarSet tyvars
392 -- It's important to add the in-scope tyvars to the global tyvar set
394 -- f (x::r) = let g y = y::r in ...
395 -- Here, g mustn't be generalised. This is also important during
396 -- class and instance decls, when we mustn't generalise the class tyvars
397 -- when typechecking the methods.
398 tc_extend_gtvs gtvs new_tv_set `thenM` \ gtvs' ->
399 setLclEnv (env {tcl_env = le', tcl_tyvars = gtvs'}) thing_inside
404 tcExtendLocalValEnv :: [TcId] -> TcM a -> TcM a
405 tcExtendLocalValEnv ids thing_inside
406 = getLclEnv `thenM` \ env ->
408 extra_global_tyvars = tyVarsOfTypes [idType id | id <- ids]
409 lvl = metaLevel (tcl_level env)
410 extra_env = [(idName id, ATcId id lvl) | id <- ids]
411 le' = extendNameEnvList (tcl_env env) extra_env
413 tc_extend_gtvs (tcl_tyvars env) extra_global_tyvars `thenM` \ gtvs' ->
414 setLclEnv (env {tcl_env = le', tcl_tyvars = gtvs'}) thing_inside
416 tcExtendLocalValEnv2 :: [(Name,TcId)] -> TcM a -> TcM a
417 tcExtendLocalValEnv2 names_w_ids thing_inside
418 = getLclEnv `thenM` \ env ->
420 extra_global_tyvars = tyVarsOfTypes [idType id | (name,id) <- names_w_ids]
421 lvl = metaLevel (tcl_level env)
422 extra_env = [(name, ATcId id lvl) | (name,id) <- names_w_ids]
423 le' = extendNameEnvList (tcl_env env) extra_env
425 tc_extend_gtvs (tcl_tyvars env) extra_global_tyvars `thenM` \ gtvs' ->
426 setLclEnv (env {tcl_env = le', tcl_tyvars = gtvs'}) thing_inside
430 %************************************************************************
432 \subsection{The global tyvars}
434 %************************************************************************
437 tc_extend_gtvs gtvs extra_global_tvs
438 = readMutVar gtvs `thenM` \ global_tvs ->
439 newMutVar (global_tvs `unionVarSet` extra_global_tvs)
442 @tcGetGlobalTyVars@ returns a fully-zonked set of tyvars free in the environment.
443 To improve subsequent calls to the same function it writes the zonked set back into
447 tcGetGlobalTyVars :: TcM TcTyVarSet
449 = getLclEnv `thenM` \ (TcLclEnv {tcl_tyvars = gtv_var}) ->
450 readMutVar gtv_var `thenM` \ gbl_tvs ->
451 zonkTcTyVarsAndFV (varSetElems gbl_tvs) `thenM` \ gbl_tvs' ->
452 writeMutVar gtv_var gbl_tvs' `thenM_`
457 %************************************************************************
459 \subsection{The instance environment}
461 %************************************************************************
464 tcGetInstEnv :: TcM InstEnv
465 tcGetInstEnv = getGblEnv `thenM` \ env ->
466 returnM (tcg_inst_env env)
468 tcSetInstEnv :: InstEnv -> TcM a -> TcM a
469 tcSetInstEnv ie thing_inside
470 = getGblEnv `thenM` \ env ->
471 setGblEnv (env {tcg_inst_env = ie}) thing_inside
473 tcExtendInstEnv :: [DFunId] -> TcM a -> TcM a
474 -- Add instances from local or imported
475 -- instances, and refresh the instance-env cache
476 tcExtendInstEnv dfuns thing_inside
477 = do { dflags <- getDOpts
481 -- Extend the total inst-env with the new dfuns
482 (inst_env', errs) = extendInstEnv dflags (tcg_inst_env env) dfuns
484 -- Sort the ones from this module from the others
485 (lcl_dfuns, pkg_dfuns) = partition (isLocalThing mod) dfuns
488 -- And add the pieces to the right places
489 (eps_inst_env', _) = extendInstEnv dflags (eps_inst_env eps) pkg_dfuns
490 eps' = eps { eps_inst_env = eps_inst_env' }
492 env' = env { tcg_inst_env = inst_env',
493 tcg_insts = lcl_dfuns ++ tcg_insts env }
498 ; setGblEnv env' thing_inside }
500 tcExtendLocalInstEnv :: [InstInfo] -> TcM a -> TcM a
501 -- Special case for local instance decls
502 tcExtendLocalInstEnv infos thing_inside
503 = do { dflags <- getDOpts
506 dfuns = map iDFunId infos
507 (inst_env', errs) = extendInstEnv dflags (tcg_inst_env env) dfuns
508 env' = env { tcg_inst_env = inst_env',
509 tcg_insts = dfuns ++ tcg_insts env }
512 ; setGblEnv env' thing_inside }
515 = traceTc (text "Adding instances:" <+> vcat (map pp dfuns))
517 pp dfun = ppr dfun <+> dcolon <+> ppr (idType dfun)
521 %************************************************************************
525 %************************************************************************
528 tcExtendRules :: [RuleDecl Id] -> TcM a -> TcM a
529 -- Just pop the new rules into the EPS and envt resp
530 -- All the rules come from an interface file, not soruce
531 -- Nevertheless, some may be for this module, if we read
532 -- its interface instead of its source code
533 tcExtendRules rules thing_inside
537 (lcl_rules, pkg_rules) = partition is_local_rule rules
538 is_local_rule = isLocalThing mod . ifaceRuleDeclName
541 core_rules = [(id,rule) | IfaceRuleOut id rule <- pkg_rules]
542 eps' = eps { eps_rule_base = addIfaceRules (eps_rule_base eps) core_rules }
543 -- All the rules from an interface are of the IfaceRuleOut form
545 env' = env { tcg_rules = lcl_rules ++ tcg_rules env }
548 ; setGblEnv env' thing_inside }
550 addIfaceRules :: RuleBase -> [IdCoreRule] -> RuleBase
551 addIfaceRules rule_base rules
552 = foldl extendRuleBase rule_base rules
556 %************************************************************************
558 \subsection{The InstInfo type}
560 %************************************************************************
562 The InstInfo type summarises the information in an instance declaration
564 instance c => k (t tvs) where b
566 It is used just for *local* instance decls (not ones from interface files).
567 But local instance decls includes
570 as well as explicit user written ones.
575 iDFunId :: DFunId, -- The dfun id
576 iBinds :: InstBindings
580 = VanillaInst -- The normal case
581 RenamedMonoBinds -- Bindings
582 [RenamedSig] -- User pragmas recorded for generating
583 -- specialised instances
585 | NewTypeDerived -- Used for deriving instances of newtypes, where the
586 [Type] -- witness dictionary is identical to the argument
587 -- dictionary. Hence no bindings, no pragmas
588 -- The [Type] are the representation types
589 -- See notes in TcDeriv
591 pprInstInfo info = vcat [ptext SLIT("InstInfo:") <+> ppr (idType (iDFunId info))]
593 pprInstInfoDetails (InstInfo { iBinds = VanillaInst b _ }) = ppr b
594 pprInstInfoDetails (InstInfo { iBinds = NewTypeDerived _}) = text "Derived from the representation type"
596 simpleInstInfoTy :: InstInfo -> Type
597 simpleInstInfoTy info = case tcSplitDFunTy (idType (iDFunId info)) of
598 (_, _, _, [ty]) -> ty
600 simpleInstInfoTyCon :: InstInfo -> TyCon
601 -- Gets the type constructor for a simple instance declaration,
602 -- i.e. one of the form instance (...) => C (T a b c) where ...
603 simpleInstInfoTyCon inst = tcTyConAppTyCon (simpleInstInfoTy inst)
607 %************************************************************************
611 %************************************************************************
614 badCon con_id = quotes (ppr con_id) <+> ptext SLIT("is not a data constructor")
616 notFound wheRe name = failWithTc (text wheRe <> colon <+> quotes (ppr name) <+>
617 ptext SLIT("is not in scope"))