3 TyThing(..), TyThingDetails(..), TcTyThing(..), TcId,
5 -- Instance environment, and InstInfo type
6 tcGetInstEnv, tcSetInstEnv,
7 InstInfo(..), pprInstInfo, pprInstInfoDetails,
8 simpleInstInfoTy, simpleInstInfoTyCon,
13 tcExtendGlobalTypeEnv,
14 tcLookupTyCon, tcLookupClass, tcLookupDataCon,
15 tcLookupGlobal_maybe, tcLookupGlobal, tcLookupGlobalId,
20 tcExtendTyVarEnv, tcExtendTyVarEnv2,
21 tcExtendLocalValEnv, tcExtendLocalValEnv2,
22 tcLookup, tcLookupLocalIds, tcLookup_maybe,
23 tcLookupId, tcLookupIdLvl,
24 getLclEnvElts, getInLocalScope,
26 -- Instance environment
27 tcExtendLocalInstEnv, tcExtendInstEnv,
32 -- Global type variables
35 -- Random useful things
36 RecTcGblEnv, tcLookupRecId_maybe,
38 -- Template Haskell stuff
39 wellStaged, spliceOK, bracketOK, tcMetaTy, metaLevel,
42 newLocalName, newDFunName,
48 #include "HsVersions.h"
50 import RnHsSyn ( RenamedMonoBinds, RenamedSig )
51 import HsSyn ( RuleDecl(..), ifaceRuleDeclName )
53 import TcMType ( zonkTcTyVarsAndFV )
54 import TcType ( Type, ThetaType, TcKind, TcTyVar, TcTyVarSet,
55 tyVarsOfTypes, tcSplitDFunTy, mkGenTyConApp,
56 getDFunTyKey, tcTyConAppTyCon,
58 import Rules ( extendRuleBase )
59 import Id ( idName, isDataConWrapId_maybe )
60 import Var ( TyVar, Id, idType )
62 import CoreSyn ( IdCoreRule )
63 import DataCon ( DataCon )
64 import TyCon ( TyCon, DataConDetails )
65 import Class ( Class, ClassOpItem )
66 import Name ( Name, NamedThing(..),
67 getSrcLoc, mkInternalName, nameIsLocalOrFrom
70 import OccName ( mkDFunOcc, occNameString )
71 import HscTypes ( DFunId, TypeEnv, extendTypeEnvList,
72 TyThing(..), ExternalPackageState(..) )
73 import Rules ( RuleBase )
74 import BasicTypes ( EP )
75 import Module ( Module )
76 import InstEnv ( InstEnv, extendInstEnv )
77 import Maybes ( seqMaybe )
78 import SrcLoc ( SrcLoc )
80 import Maybe ( isJust )
81 import List ( partition )
85 %************************************************************************
89 %************************************************************************
92 instance Outputable Stage where
93 ppr Comp = text "Comp"
94 ppr (Brack l _ _) = text "Brack" <+> int l
95 ppr (Splice l) = text "Splice" <+> int l
98 metaLevel :: Stage -> Level
99 metaLevel Comp = topLevel
100 metaLevel (Splice l) = l
101 metaLevel (Brack l _ _) = l
103 wellStaged :: Level -- Binding level
104 -> Level -- Use level
106 wellStaged bind_stage use_stage
107 = bind_stage <= use_stage
109 -- Indicates the legal transitions on bracket( [| |] ).
110 bracketOK :: Stage -> Maybe Level
111 bracketOK (Brack _ _ _) = Nothing -- Bracket illegal inside a bracket
112 bracketOK stage = (Just (metaLevel stage + 1))
114 -- Indicates the legal transitions on splice($).
115 spliceOK :: Stage -> Maybe Level
116 spliceOK (Splice _) = Nothing -- Splice illegal inside splice
117 spliceOK stage = Just (metaLevel stage - 1)
119 tcMetaTy :: Name -> TcM Type
120 -- Given the name of a Template Haskell data type,
122 -- E.g. given the name "Expr" return the type "Expr"
124 = tcLookupTyCon tc_name `thenM` \ t ->
125 returnM (mkGenTyConApp t [])
126 -- Use mkGenTyConApp because it might be a synonym
130 %************************************************************************
132 \subsection{TyThingDetails}
134 %************************************************************************
136 This data type is used to help tie the knot
137 when type checking type and class declarations
140 data TyThingDetails = SynTyDetails Type
141 | DataTyDetails ThetaType (DataConDetails DataCon) [Id] (Maybe (EP Id))
142 | ClassDetails ThetaType [Id] [ClassOpItem] DataCon Name
143 -- The Name is the Name of the implicit TyCon for the class
144 | ForeignTyDetails -- Nothing yet
148 %************************************************************************
150 \subsection{Basic lookups}
152 %************************************************************************
155 type RecTcGblEnv = TcGblEnv
156 -- This environment is used for getting the 'right' IdInfo
157 -- on imported things and for looking up Ids in unfoldings
158 -- The environment doesn't have any local Ids in it
160 tcLookupRecId_maybe :: RecTcGblEnv -> Name -> Maybe Id
161 tcLookupRecId_maybe env name = case lookup_global env name of
162 Just (AnId id) -> Just id
166 %************************************************************************
168 \subsection{Making new Ids}
170 %************************************************************************
175 newLocalName :: Name -> TcM Name
176 newLocalName name -- Make a clone
177 = newUnique `thenM` \ uniq ->
178 returnM (mkInternalName uniq (getOccName name) (getSrcLoc name))
181 Make a name for the dict fun for an instance decl.
182 It's a *local* name for the moment. The CoreTidy pass
186 newDFunName :: Class -> [Type] -> SrcLoc -> TcM Name
187 newDFunName clas (ty:_) loc
188 = newUnique `thenM` \ uniq ->
189 returnM (mkInternalName uniq (mkDFunOcc dfun_string) loc)
191 -- Any string that is somewhat unique will do
192 dfun_string = occNameString (getOccName clas) ++ occNameString (getDFunTyKey ty)
194 newDFunName clas [] loc = pprPanic "newDFunName" (ppr clas <+> ppr loc)
198 isLocalThing :: NamedThing a => Module -> a -> Bool
199 isLocalThing mod thing = nameIsLocalOrFrom mod (getName thing)
202 %************************************************************************
204 \subsection{The global environment}
206 %************************************************************************
209 tcExtendGlobalEnv :: [TyThing] -> TcM r -> TcM r
210 -- Given a mixture of Ids, TyCons, Classes, perhaps from the
211 -- module being compiled, perhaps from a package module,
212 -- extend the global environment, and update the EPS
213 tcExtendGlobalEnv things thing_inside
217 ; let mod = tcg_mod env
218 (lcl_things, pkg_things) = partition (isLocalThing mod) things
219 ge' = extendTypeEnvList (tcg_type_env env) lcl_things
220 eps' = eps { eps_PTE = extendTypeEnvList (eps_PTE eps) pkg_things }
221 ist' = mkImpTypeEnv eps' hpt
223 ; setGblEnv (env {tcg_type_env = ge', tcg_ist = ist'}) thing_inside }
225 tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a
226 -- Same deal as tcExtendGlobalEnv, but for Ids
227 tcExtendGlobalValEnv ids thing_inside
228 = tcExtendGlobalEnv [AnId id | id <- ids] thing_inside
230 tcExtendGlobalTypeEnv :: TypeEnv -> TcM r -> TcM r
231 -- Top-level things of the interactive context
232 -- No need to extend the package env
233 tcExtendGlobalTypeEnv extra_env thing_inside
234 = do { env <- getGblEnv
235 ; let ge' = tcg_type_env env `plusNameEnv` extra_env
236 ; setGblEnv (env {tcg_type_env = ge'}) thing_inside }
241 lookup_global :: TcGblEnv -> Name -> Maybe TyThing
242 -- Try the global envt and then the global symbol table
243 lookup_global env name
244 = lookupNameEnv (tcg_type_env env) name
248 tcLookupGlobal_maybe :: Name -> TcRn m (Maybe TyThing)
249 tcLookupGlobal_maybe name
250 = getGblEnv `thenM` \ env ->
251 returnM (lookup_global env name)
254 A variety of global lookups, when we know what we are looking for.
257 tcLookupGlobal :: Name -> TcM TyThing
259 = tcLookupGlobal_maybe name `thenM` \ maybe_thing ->
261 Just thing -> returnM thing
262 other -> notFound "tcLookupGlobal" name
264 tcLookupGlobalId :: Name -> TcM Id
265 tcLookupGlobalId name
266 = tcLookupGlobal_maybe name `thenM` \ maybe_thing ->
268 Just (AnId id) -> returnM id
269 other -> notFound "tcLookupGlobal" name
271 tcLookupDataCon :: Name -> TcM DataCon
272 tcLookupDataCon con_name
273 = tcLookupGlobalId con_name `thenM` \ con_id ->
274 case isDataConWrapId_maybe con_id of
275 Just data_con -> returnM data_con
276 Nothing -> failWithTc (badCon con_id)
278 tcLookupClass :: Name -> TcM Class
280 = tcLookupGlobal_maybe name `thenM` \ maybe_clas ->
282 Just (AClass clas) -> returnM clas
283 other -> notFound "tcLookupClass" name
285 tcLookupTyCon :: Name -> TcM TyCon
287 = tcLookupGlobal_maybe name `thenM` \ maybe_tc ->
289 Just (ATyCon tc) -> returnM tc
290 other -> notFound "tcLookupTyCon" name
293 getInGlobalScope :: TcRn m (Name -> Bool)
294 getInGlobalScope = do { gbl_env <- getGblEnv ;
295 return (\n -> isJust (lookup_global gbl_env n)) }
299 %************************************************************************
301 \subsection{The local environment}
303 %************************************************************************
306 tcLookup_maybe :: Name -> TcM (Maybe TcTyThing)
308 = getLclEnv `thenM` \ local_env ->
309 case lookupNameEnv (tcl_env local_env) name of
310 Just thing -> returnM (Just thing)
311 Nothing -> tcLookupGlobal_maybe name `thenM` \ mb_res ->
312 returnM (case mb_res of
313 Just thing -> Just (AGlobal thing)
316 tcLookup :: Name -> TcM TcTyThing
318 = tcLookup_maybe name `thenM` \ maybe_thing ->
320 Just thing -> returnM thing
321 other -> notFound "tcLookup" name
322 -- Extract the IdInfo from an IfaceSig imported from an interface file
324 tcLookupId :: Name -> TcM Id
325 -- Used when we aren't interested in the binding level
327 = tcLookup name `thenM` \ thing ->
329 ATcId tc_id lvl -> returnM tc_id
330 AGlobal (AnId id) -> returnM id
331 other -> pprPanic "tcLookupId" (ppr name)
333 tcLookupIdLvl :: Name -> TcM (Id, Level)
335 = tcLookup name `thenM` \ thing ->
337 ATcId tc_id lvl -> returnM (tc_id, lvl)
338 AGlobal (AnId id) -> returnM (id, impLevel)
339 other -> pprPanic "tcLookupIdLvl" (ppr name)
341 tcLookupLocalIds :: [Name] -> TcM [TcId]
342 -- We expect the variables to all be bound, and all at
343 -- the same level as the lookup. Only used in one place...
345 = getLclEnv `thenM` \ env ->
346 returnM (map (lookup (tcl_env env) (metaLevel (tcl_level env))) ns)
349 = case lookupNameEnv lenv name of
350 Just (ATcId id lvl1) -> ASSERT( lvl == lvl1 ) id
351 other -> pprPanic "tcLookupLocalIds" (ppr name)
353 getLclEnvElts :: TcM [TcTyThing]
354 getLclEnvElts = getLclEnv `thenM` \ env ->
355 return (nameEnvElts (tcl_env env))
357 getInLocalScope :: TcM (Name -> Bool)
359 getInLocalScope = getLclEnv `thenM` \ env ->
361 lcl_env = tcl_env env
363 return (`elemNameEnv` lcl_env)
367 tcExtendKindEnv :: [(Name,TcKind)] -> TcM r -> TcM r
368 tcExtendKindEnv pairs thing_inside
369 = updLclEnv upd thing_inside
371 upd lcl_env = lcl_env { tcl_env = extend (tcl_env lcl_env) }
372 extend env = extendNameEnvList env [(n, AThing k) | (n,k) <- pairs]
373 -- No need to extend global tyvars for kind checking
375 tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r
376 tcExtendTyVarEnv tvs thing_inside
377 = tc_extend_tv_env [(getName tv, ATyVar tv) | tv <- tvs] tvs thing_inside
379 tcExtendTyVarEnv2 :: [(TyVar,TcTyVar)] -> TcM r -> TcM r
380 tcExtendTyVarEnv2 tv_pairs thing_inside
381 = tc_extend_tv_env [(getName tv1, ATyVar tv2) | (tv1,tv2) <- tv_pairs]
382 [tv | (_,tv) <- tv_pairs]
385 tc_extend_tv_env binds tyvars thing_inside
386 = getLclEnv `thenM` \ env@(TcLclEnv {tcl_env = le, tcl_tyvars = gtvs}) ->
388 le' = extendNameEnvList le binds
389 new_tv_set = mkVarSet tyvars
391 -- It's important to add the in-scope tyvars to the global tyvar set
393 -- f (x::r) = let g y = y::r in ...
394 -- Here, g mustn't be generalised. This is also important during
395 -- class and instance decls, when we mustn't generalise the class tyvars
396 -- when typechecking the methods.
397 tc_extend_gtvs gtvs new_tv_set `thenM` \ gtvs' ->
398 setLclEnv (env {tcl_env = le', tcl_tyvars = gtvs'}) thing_inside
403 tcExtendLocalValEnv :: [TcId] -> TcM a -> TcM a
404 tcExtendLocalValEnv ids thing_inside
405 = getLclEnv `thenM` \ env ->
407 extra_global_tyvars = tyVarsOfTypes [idType id | id <- ids]
408 lvl = metaLevel (tcl_level env)
409 extra_env = [(idName id, ATcId id lvl) | id <- ids]
410 le' = extendNameEnvList (tcl_env env) extra_env
412 tc_extend_gtvs (tcl_tyvars env) extra_global_tyvars `thenM` \ gtvs' ->
413 setLclEnv (env {tcl_env = le', tcl_tyvars = gtvs'}) thing_inside
415 tcExtendLocalValEnv2 :: [(Name,TcId)] -> TcM a -> TcM a
416 tcExtendLocalValEnv2 names_w_ids thing_inside
417 = getLclEnv `thenM` \ env ->
419 extra_global_tyvars = tyVarsOfTypes [idType id | (name,id) <- names_w_ids]
420 lvl = metaLevel (tcl_level env)
421 extra_env = [(name, ATcId id lvl) | (name,id) <- names_w_ids]
422 le' = extendNameEnvList (tcl_env env) extra_env
424 tc_extend_gtvs (tcl_tyvars env) extra_global_tyvars `thenM` \ gtvs' ->
425 setLclEnv (env {tcl_env = le', tcl_tyvars = gtvs'}) thing_inside
429 %************************************************************************
431 \subsection{The global tyvars}
433 %************************************************************************
436 tc_extend_gtvs gtvs extra_global_tvs
437 = readMutVar gtvs `thenM` \ global_tvs ->
438 newMutVar (global_tvs `unionVarSet` extra_global_tvs)
441 @tcGetGlobalTyVars@ returns a fully-zonked set of tyvars free in the environment.
442 To improve subsequent calls to the same function it writes the zonked set back into
446 tcGetGlobalTyVars :: TcM TcTyVarSet
448 = getLclEnv `thenM` \ (TcLclEnv {tcl_tyvars = gtv_var}) ->
449 readMutVar gtv_var `thenM` \ gbl_tvs ->
450 zonkTcTyVarsAndFV (varSetElems gbl_tvs) `thenM` \ gbl_tvs' ->
451 writeMutVar gtv_var gbl_tvs' `thenM_`
456 %************************************************************************
458 \subsection{The instance environment}
460 %************************************************************************
463 tcGetInstEnv :: TcM InstEnv
464 tcGetInstEnv = getGblEnv `thenM` \ env ->
465 returnM (tcg_inst_env env)
467 tcSetInstEnv :: InstEnv -> TcM a -> TcM a
468 tcSetInstEnv ie thing_inside
469 = getGblEnv `thenM` \ env ->
470 setGblEnv (env {tcg_inst_env = ie}) thing_inside
472 tcExtendInstEnv :: [DFunId] -> TcM a -> TcM a
473 -- Add instances from local or imported
474 -- instances, and refresh the instance-env cache
475 tcExtendInstEnv dfuns thing_inside
476 = do { dflags <- getDOpts
480 -- Extend the total inst-env with the new dfuns
481 (inst_env', errs) = extendInstEnv dflags (tcg_inst_env env) dfuns
483 -- Sort the ones from this module from the others
484 (lcl_dfuns, pkg_dfuns) = partition (isLocalThing mod) dfuns
487 -- And add the pieces to the right places
488 (eps_inst_env', _) = extendInstEnv dflags (eps_inst_env eps) pkg_dfuns
489 eps' = eps { eps_inst_env = eps_inst_env' }
491 env' = env { tcg_inst_env = inst_env',
492 tcg_insts = lcl_dfuns ++ tcg_insts env }
497 ; setGblEnv env' thing_inside }
499 tcExtendLocalInstEnv :: [InstInfo] -> TcM a -> TcM a
500 -- Special case for local instance decls
501 tcExtendLocalInstEnv infos thing_inside
502 = do { dflags <- getDOpts
505 dfuns = map iDFunId infos
506 (inst_env', errs) = extendInstEnv dflags (tcg_inst_env env) dfuns
507 env' = env { tcg_inst_env = inst_env',
508 tcg_insts = dfuns ++ tcg_insts env }
511 ; setGblEnv env' thing_inside }
514 = traceTc (text "Adding instances:" <+> vcat (map pp dfuns))
516 pp dfun = ppr dfun <+> dcolon <+> ppr (idType dfun)
520 %************************************************************************
524 %************************************************************************
527 tcExtendRules :: [RuleDecl Id] -> TcM a -> TcM a
528 -- Just pop the new rules into the EPS and envt resp
529 -- All the rules come from an interface file, not soruce
530 -- Nevertheless, some may be for this module, if we read
531 -- its interface instead of its source code
532 tcExtendRules rules thing_inside
536 (lcl_rules, pkg_rules) = partition is_local_rule rules
537 is_local_rule = isLocalThing mod . ifaceRuleDeclName
540 core_rules = [(id,rule) | IfaceRuleOut id rule <- pkg_rules]
541 eps' = eps { eps_rule_base = addIfaceRules (eps_rule_base eps) core_rules }
542 -- All the rules from an interface are of the IfaceRuleOut form
544 env' = env { tcg_rules = lcl_rules ++ tcg_rules env }
547 ; setGblEnv env' thing_inside }
549 addIfaceRules :: RuleBase -> [IdCoreRule] -> RuleBase
550 addIfaceRules rule_base rules
551 = foldl extendRuleBase rule_base rules
555 %************************************************************************
557 \subsection{The InstInfo type}
559 %************************************************************************
561 The InstInfo type summarises the information in an instance declaration
563 instance c => k (t tvs) where b
565 It is used just for *local* instance decls (not ones from interface files).
566 But local instance decls includes
569 as well as explicit user written ones.
574 iDFunId :: DFunId, -- The dfun id
575 iBinds :: RenamedMonoBinds, -- Bindings, b
576 iPrags :: [RenamedSig] -- User pragmas recorded for generating specialised instances
579 | NewTypeDerived { -- Used for deriving instances of newtypes, where the
580 -- witness dictionary is identical to the argument dictionary
581 -- Hence no bindings.
582 iDFunId :: DFunId -- The dfun id
585 pprInstInfo info = vcat [ptext SLIT("InstInfo:") <+> ppr (idType (iDFunId info))]
586 pprInstInfoDetails (InstInfo { iBinds = b }) = ppr b
587 pprInstInfoDetails (NewTypeDerived _) = text "Derived from the represenation type"
589 simpleInstInfoTy :: InstInfo -> Type
590 simpleInstInfoTy info = case tcSplitDFunTy (idType (iDFunId info)) of
591 (_, _, _, [ty]) -> ty
593 simpleInstInfoTyCon :: InstInfo -> TyCon
594 -- Gets the type constructor for a simple instance declaration,
595 -- i.e. one of the form instance (...) => C (T a b c) where ...
596 simpleInstInfoTyCon inst = tcTyConAppTyCon (simpleInstInfoTy inst)
600 %************************************************************************
604 %************************************************************************
607 badCon con_id = quotes (ppr con_id) <+> ptext SLIT("is not a data constructor")
609 notFound wheRe name = failWithTc (text wheRe <> colon <+> quotes (ppr name) <+>
610 ptext SLIT("is not in scope"))