X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcEnv.lhs;h=f80e2dbca243f5dfb5ec888b725b2016188c2a25;hb=1553c7788e7f663bfc55813158325d695a21a229;hp=cbc20ffc1a4dbe804703980c9c120c993b4ae986;hpb=cbdeae8fc8a1c72d20d89241acae8a313214b51c;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs index cbc20ff..f80e2db 100644 --- a/ghc/compiler/typecheck/TcEnv.lhs +++ b/ghc/compiler/typecheck/TcEnv.lhs @@ -5,7 +5,7 @@ module TcEnv( -- Getting stuff from the environment TcEnv, initTcEnv, - tcEnvTyCons, tcEnvClasses, tcEnvIds, tcEnvTcIds, tcEnvTyVars, + tcEnvTyCons, tcEnvClasses, tcEnvIds, tcLEnvElts, getTcGEnv, -- Instance environment, and InstInfo type @@ -16,22 +16,22 @@ module TcEnv( -- Global environment tcExtendGlobalEnv, tcExtendGlobalValEnv, tcExtendGlobalTypeEnv, tcLookupTyCon, tcLookupClass, tcLookupGlobalId, tcLookupDataCon, - tcLookupGlobal_maybe, tcLookupGlobal, tcLookupSyntaxId, tcLookupSyntaxName, + 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, tcAddImportedIdInfo, tcLookupRecId, tcLookupRecId_maybe, + RecTcEnv, tcLookupRecId, tcLookupRecId_maybe, -- New Ids - newLocalId, newSpecPragmaId, - newDFunName, + newLocalName, newDFunName, -- Misc isLocalThing, tcSetEnv @@ -41,23 +41,19 @@ module TcEnv( import RnHsSyn ( RenamedMonoBinds, RenamedSig ) import TcMonad -import TcType ( TcKind, TcType, TcTyVar, TcTyVarSet, - zonkTcTyVarsAndFV +import TcMType ( zonkTcTyVarsAndFV ) +import TcType ( Type, ThetaType, TcKind, TcTyVar, TcTyVarSet, + tyVarsOfTypes, tcSplitDFunTy, + getDFunTyKey, tcTyConAppTyCon ) -import Id ( idName, mkSpecPragmaId, mkUserLocal, isDataConWrapId_maybe ) -import IdInfo ( vanillaIdInfo ) -import Var ( TyVar, Id, idType, lazySetIdInfo, idInfo ) +import Id ( idName, isDataConWrapId_maybe ) +import Var ( TyVar, Id, idType ) import VarSet -import Type ( Type, ThetaType, - tyVarsOfTypes, splitDFunTy, - getDFunTyKey, tyConAppTyCon - ) import DataCon ( DataCon ) -import TyCon ( TyCon ) +import TyCon ( TyCon, DataConDetails ) import Class ( Class, ClassOpItem ) -import Name ( Name, OccName, NamedThing(..), - nameOccName, getSrcLoc, mkLocalName, isLocalName, - nameIsLocalOrFrom +import Name ( Name, NamedThing(..), + getSrcLoc, mkInternalName, isInternalName, nameIsLocalOrFrom ) import NameEnv ( NameEnv, lookupNameEnv, nameEnvElts, elemNameEnv, extendNameEnvList, emptyNameEnv, plusNameEnv ) @@ -71,9 +67,7 @@ import HscTypes ( DFunId, import Module ( Module ) import InstEnv ( InstEnv, emptyInstEnv ) import HscTypes ( lookupType, TyThing(..) ) -import Util ( zipEqual ) import SrcLoc ( SrcLoc ) -import qualified PrelNames import Outputable import IOExts ( newIORef ) @@ -91,8 +85,6 @@ type TcIdSet = IdSet data TcEnv = TcEnv { - tcSyntaxMap :: PrelNames.SyntaxMap, -- The syntax map (usually the identity) - tcGST :: Name -> Maybe TyThing, -- The type environment at the moment we began this compilation tcInsts :: InstEnv, -- All instances (both imported and in this module) @@ -135,53 +127,56 @@ used thus: \begin{code} -data TcTyThing - = AGlobal TyThing -- Used only in the return type of a lookup - | ATcId TcId -- Ids defined in this module - | ATyVar TyVar -- Type variables - | AThing TcKind -- Used temporarily, during kind checking --- Here's an example of how the AThing guy is used --- Suppose we are checking (forall a. T a Int): --- 1. We first bind (a -> AThink kv), where kv is a kind variable. --- 2. Then we kind-check the (T a Int) part. --- 3. Then we zonk the kind variable. --- 4. Now we know the kind for 'a', and we add (a -> ATyVar a::K) to the environment - -initTcEnv :: PrelNames.SyntaxMap -> HomeSymbolTable -> PackageTypeEnv -> IO TcEnv -initTcEnv syntax_map hst pte +initTcEnv :: HomeSymbolTable -> PackageTypeEnv -> IO TcEnv +initTcEnv hst pte = do { gtv_var <- newIORef emptyVarSet ; - return (TcEnv { tcSyntaxMap = syntax_map, - tcGST = lookup, + return (TcEnv { tcGST = lookup, tcGEnv = emptyNameEnv, tcInsts = emptyInstEnv, tcLEnv = emptyNameEnv, 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) tcEnvTyCons env = typeEnvTyCons (tcGEnv env) tcEnvIds env = typeEnvIds (tcGEnv env) -tcEnvTyVars env = [tv | ATyVar tv <- nameEnvElts (tcLEnv env)] -tcEnvTcIds env = [id | ATcId id <- nameEnvElts (tcLEnv env)] +tcLEnvElts env = nameEnvElts (tcLEnv env) getTcGEnv (TcEnv { tcGEnv = genv }) = genv tcInLocalScope :: TcEnv -> Name -> Bool tcInLocalScope env v = v `elemNameEnv` (tcLEnv env) +\end{code} --- This data type is used to help tie the knot --- when type checking type and class declarations +\begin{code} +data TcTyThing + = AGlobal TyThing -- Used only in the return type of a lookup + | ATcId TcId -- Ids defined in this module + | ATyVar TyVar -- Type variables + | AThing TcKind -- Used temporarily, during kind checking +-- Here's an example of how the AThing guy is used +-- Suppose we are checking (forall a. T a Int): +-- 1. We first bind (a -> AThink kv), where kv is a kind variable. +-- 2. Then we kind-check the (T a Int) part. +-- 3. Then we zonk the kind variable. +-- 4. Now we know the kind for 'a', and we add (a -> ATyVar a::K) to the environment + +\end{code} + +This data type is used to help tie the knot + when type checking type and class declarations + +\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} - %************************************************************************ %* * \subsection{Basic lookups} @@ -212,16 +207,6 @@ type RecTcEnv = TcEnv -- on imported things and for looking up Ids in unfoldings -- The environment doesn't have any local Ids in it -tcAddImportedIdInfo :: RecTcEnv -> Id -> Id -tcAddImportedIdInfo env id - = id `lazySetIdInfo` new_info - -- The Id must be returned without a data dependency on maybe_id - where - new_info = case tcLookupRecId_maybe env (idName id) of - Nothing -> pprTrace "tcAddIdInfo" (ppr id) vanillaIdInfo - Just imported_id -> idInfo imported_id - -- ToDo: could check that types are the same - tcLookupRecId_maybe :: RecTcEnv -> Name -> Maybe Id tcLookupRecId_maybe env name = case lookup_global env name of Just (AnId id) -> Just id @@ -242,26 +227,21 @@ tcLookupRecId env name = case lookup_global env name of Constructing new Ids \begin{code} -newLocalId :: OccName -> TcType -> SrcLoc -> NF_TcM TcId -newLocalId name ty loc - = tcGetUnique `thenNF_Tc` \ uniq -> - returnNF_Tc (mkUserLocal name uniq ty loc) - -newSpecPragmaId :: Name -> TcType -> NF_TcM TcId -newSpecPragmaId name ty +newLocalName :: Name -> NF_TcM Name +newLocalName name -- Make a clone = tcGetUnique `thenNF_Tc` \ uniq -> - returnNF_Tc (mkSpecPragmaId (nameOccName name) uniq ty (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) @@ -370,21 +350,6 @@ tcLookupLocalIds ns lookup lenv name = case lookupNameEnv lenv name of Just (ATcId id) -> id other -> pprPanic "tcLookupLocalIds" (ppr name) - -tcLookupSyntaxId :: Name -> NF_TcM Id --- Lookup a name like PrelNum.fromInt, and return the corresponding Id, --- after mapping through the SyntaxMap. This may give us the Id for --- (say) MyPrelude.fromInteger -tcLookupSyntaxId name - = tcGetEnv `thenNF_Tc` \ env -> - returnNF_Tc (case lookup_global env (tcSyntaxMap env name) of - Just (AnId id) -> id - other -> pprPanic "tcLookupSyntaxId" (ppr name)) - -tcLookupSyntaxName :: Name -> NF_TcM Name -tcLookupSyntaxName name - = tcGetEnv `thenNF_Tc` \ env -> - returnNF_Tc (tcSyntaxMap env name) \end{code} @@ -421,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 @@ -435,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] @@ -476,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) @@ -529,6 +492,12 @@ The InstInfo type summarises the information in an instance declaration instance c => k (t tvs) where b +It is used just for *local* instance decls (not ones from interface files). +But local instance decls includes + - derived ones + - generic ones +as well as explicit user written ones. + \begin{code} data InstInfo = InstInfo { @@ -537,17 +506,22 @@ data InstInfo iPrags :: [RenamedSig] -- User pragmas recorded for generating specialised instances } -pprInstInfo info = vcat [ptext SLIT("InstInfo:") <+> ppr (idType (iDFunId info)), - nest 4 (ppr (iBinds info))] + | NewTypeDerived { -- Used for deriving instances of newtypes, where the + -- witness dictionary is identical to the argument dictionary + -- Hence no bindings. + iDFunId :: DFunId -- The dfun id + } + +pprInstInfo info = vcat [ptext SLIT("InstInfo:") <+> ppr (idType (iDFunId info))] simpleInstInfoTy :: InstInfo -> Type -simpleInstInfoTy info = case splitDFunTy (idType (iDFunId info)) of +simpleInstInfoTy info = case tcSplitDFunTy (idType (iDFunId info)) of (_, _, _, [ty]) -> ty simpleInstInfoTyCon :: InstInfo -> TyCon -- Gets the type constructor for a simple instance declaration, -- i.e. one of the form instance (...) => C (T a b c) where ... -simpleInstInfoTyCon inst = tyConAppTyCon (simpleInstInfoTy inst) +simpleInstInfoTyCon inst = tcTyConAppTyCon (simpleInstInfoTy inst) \end{code}