X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcEnv.lhs;h=f80e2dbca243f5dfb5ec888b725b2016188c2a25;hb=1553c7788e7f663bfc55813158325d695a21a229;hp=c08e43b8382f018151bed931952b0f4a756b52b6;hpb=e66018084e22615311828b7a221d5df25cdf09ea;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs index c08e43b..f80e2db 100644 --- a/ghc/compiler/typecheck/TcEnv.lhs +++ b/ghc/compiler/typecheck/TcEnv.lhs @@ -19,12 +19,13 @@ module TcEnv( tcLookupGlobal_maybe, tcLookupGlobal, -- Local environment - tcExtendKindEnv, tcLookupLocalIds, tcInLocalScope, - tcExtendTyVarEnv, tcExtendTyVarEnvForMeths, - tcExtendLocalValEnv, tcLookup, tcLookup_maybe, tcLookupId, + tcExtendKindEnv, tcInLocalScope, + tcExtendTyVarEnv, tcExtendTyVarEnv2, + tcExtendLocalValEnv, tcExtendLocalValEnv2, + tcLookup, tcLookupLocalIds, tcLookup_maybe, tcLookupId, -- Global type variables - tcGetGlobalTyVars, tcExtendGlobalTyVars, + tcGetGlobalTyVars, -- Random useful things RecTcEnv, tcLookupRecId, tcLookupRecId_maybe, @@ -45,14 +46,14 @@ import TcType ( Type, ThetaType, TcKind, TcTyVar, TcTyVarSet, tyVarsOfTypes, tcSplitDFunTy, getDFunTyKey, tcTyConAppTyCon ) -import Id ( isDataConWrapId_maybe ) +import Id ( idName, isDataConWrapId_maybe ) import Var ( TyVar, Id, idType ) import VarSet import DataCon ( DataCon ) -import TyCon ( TyCon ) +import TyCon ( TyCon, DataConDetails ) import Class ( Class, ClassOpItem ) import Name ( Name, NamedThing(..), - getSrcLoc, mkLocalName, isLocalName, nameIsLocalOrFrom + getSrcLoc, mkInternalName, isInternalName, nameIsLocalOrFrom ) import NameEnv ( NameEnv, lookupNameEnv, nameEnvElts, elemNameEnv, extendNameEnvList, emptyNameEnv, plusNameEnv ) @@ -66,7 +67,6 @@ import HscTypes ( DFunId, import Module ( Module ) import InstEnv ( InstEnv, emptyInstEnv ) import HscTypes ( lookupType, TyThing(..) ) -import Util ( zipEqual ) import SrcLoc ( SrcLoc ) import Outputable @@ -137,8 +137,8 @@ initTcEnv hst pte tcTyVars = gtv_var })} where - lookup name | isLocalName name = Nothing - | otherwise = lookupType hst pte name + lookup name | isInternalName name = Nothing + | otherwise = lookupType hst pte name tcEnvClasses env = typeEnvClasses (tcGEnv env) @@ -172,7 +172,7 @@ This data type is used to help tie the knot \begin{code} data TyThingDetails = SynTyDetails Type - | DataTyDetails ThetaType [DataCon] [Id] + | DataTyDetails ThetaType (DataConDetails DataCon) [Id] | ClassDetails ThetaType [Id] [ClassOpItem] DataCon | ForeignTyDetails -- Nothing yet \end{code} @@ -230,18 +230,18 @@ Constructing new Ids newLocalName :: Name -> NF_TcM Name newLocalName name -- Make a clone = tcGetUnique `thenNF_Tc` \ uniq -> - returnNF_Tc (mkLocalName uniq (getOccName name) (getSrcLoc name)) + returnNF_Tc (mkInternalName uniq (getOccName name) (getSrcLoc name)) \end{code} Make a name for the dict fun for an instance decl. It's a *local* name for the moment. The CoreTidy pass -will globalise it. +will externalise it. \begin{code} newDFunName :: Class -> [Type] -> SrcLoc -> NF_TcM Name newDFunName clas (ty:_) loc = tcGetUnique `thenNF_Tc` \ uniq -> - returnNF_Tc (mkLocalName uniq (mkDFunOcc dfun_string) loc) + returnNF_Tc (mkInternalName uniq (mkDFunOcc dfun_string) loc) where -- Any string that is somewhat unique will do dfun_string = occNameString (getOccName clas) ++ occNameString (getDFunTyKey ty) @@ -386,10 +386,19 @@ tcExtendKindEnv pairs thing_inside tcSetEnv (env {tcLEnv = le'}) thing_inside tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r -tcExtendTyVarEnv tyvars thing_inside +tcExtendTyVarEnv tvs thing_inside + = tc_extend_tv_env [(getName tv, ATyVar tv) | tv <- tvs] tvs thing_inside + +tcExtendTyVarEnv2 :: [(TyVar,TcTyVar)] -> TcM r -> TcM r +tcExtendTyVarEnv2 tv_pairs thing_inside + = tc_extend_tv_env [(getName tv1, ATyVar tv2) | (tv1,tv2) <- tv_pairs] + [tv | (_,tv) <- tv_pairs] + thing_inside + +tc_extend_tv_env binds tyvars thing_inside = tcGetEnv `thenNF_Tc` \ env@(TcEnv {tcLEnv = le, tcTyVars = gtvs}) -> let - le' = extendNameEnvList le [ (getName tv, ATyVar tv) | tv <- tyvars] + le' = extendNameEnvList le binds new_tv_set = mkVarSet tyvars in -- It's important to add the in-scope tyvars to the global tyvar set @@ -400,29 +409,23 @@ tcExtendTyVarEnv tyvars thing_inside -- when typechecking the methods. tc_extend_gtvs gtvs new_tv_set `thenNF_Tc` \ gtvs' -> tcSetEnv (env {tcLEnv = le', tcTyVars = gtvs'}) thing_inside +\end{code} --- This variant, tcExtendTyVarEnvForMeths, takes *two* bunches of tyvars: --- the signature tyvars contain the original names --- the instance tyvars are what those names should be mapped to --- It's needed when typechecking the method bindings of class and instance decls --- It does *not* extend the global tyvars; tcMethodBind does that for itself -tcExtendTyVarEnvForMeths :: [TyVar] -> [TcTyVar] -> TcM r -> TcM r -tcExtendTyVarEnvForMeths sig_tyvars inst_tyvars thing_inside - = tcGetEnv `thenNF_Tc` \ env -> +\begin{code} +tcExtendLocalValEnv :: [TcId] -> TcM a -> TcM a +tcExtendLocalValEnv ids thing_inside + = tcGetEnv `thenNF_Tc` \ env -> let - le' = extendNameEnvList (tcLEnv env) stuff - stuff = [ (getName sig_tv, ATyVar inst_tv) - | (sig_tv, inst_tv) <- zipEqual "tcMeth" sig_tyvars inst_tyvars - ] + extra_global_tyvars = tyVarsOfTypes [idType id | id <- ids] + extra_env = [(idName id, ATcId id) | id <- ids] + le' = extendNameEnvList (tcLEnv env) extra_env in - tcSetEnv (env {tcLEnv = le'}) thing_inside -\end{code} - + tc_extend_gtvs (tcTyVars env) extra_global_tyvars `thenNF_Tc` \ gtvs' -> + tcSetEnv (env {tcLEnv = le', tcTyVars = gtvs'}) thing_inside -\begin{code} -tcExtendLocalValEnv :: [(Name,TcId)] -> TcM a -> TcM a -tcExtendLocalValEnv names_w_ids thing_inside +tcExtendLocalValEnv2 :: [(Name,TcId)] -> TcM a -> TcM a +tcExtendLocalValEnv2 names_w_ids thing_inside = tcGetEnv `thenNF_Tc` \ env -> let extra_global_tyvars = tyVarsOfTypes [idType id | (name,id) <- names_w_ids] @@ -441,11 +444,6 @@ tcExtendLocalValEnv names_w_ids thing_inside %************************************************************************ \begin{code} -tcExtendGlobalTyVars extra_global_tvs thing_inside - = tcGetEnv `thenNF_Tc` \ env -> - tc_extend_gtvs (tcTyVars env) extra_global_tvs `thenNF_Tc` \ gtvs' -> - tcSetEnv (env {tcTyVars = gtvs'}) thing_inside - tc_extend_gtvs gtvs extra_global_tvs = tcReadMutVar gtvs `thenNF_Tc` \ global_tvs -> tcNewMutVar (global_tvs `unionVarSet` extra_global_tvs)