X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcEnv.lhs;h=9b281edf862d96c2f586c1ebf64f338201786fcf;hb=87aae97c8e345c559dd3c74474bec39851b97765;hp=ac92dc3c245025c0ea61d8988af4d921aaf8780a;hpb=be2c67eb19565e8d0d9ca5a53f526ce49acf1d92;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs index ac92dc3..9b281ed 100644 --- a/ghc/compiler/typecheck/TcEnv.lhs +++ b/ghc/compiler/typecheck/TcEnv.lhs @@ -14,14 +14,14 @@ module TcEnv( simpleInstInfoTy, simpleInstInfoTyCon, -- Global environment - tcExtendGlobalEnv, tcExtendGlobalValEnv, + tcExtendGlobalEnv, tcExtendGlobalValEnv, tcExtendGlobalTypeEnv, tcLookupTyCon, tcLookupClass, tcLookupGlobalId, tcLookupDataCon, - tcLookupGlobal_maybe, tcLookupGlobal, tcLookupSyntaxId, tcLookupSyntaxName, + tcLookupGlobal_maybe, tcLookupGlobal, -- Local environment - tcExtendKindEnv, tcLookupLocalIds, + tcExtendKindEnv, tcLookupLocalIds, tcInLocalScope, tcExtendTyVarEnv, tcExtendTyVarEnvForMeths, - tcExtendLocalValEnv, tcLookup, tcLookup_maybe, + tcExtendLocalValEnv, tcLookup, tcLookup_maybe, tcLookupId, -- Global type variables tcGetGlobalTyVars, tcExtendGlobalTyVars, @@ -41,34 +41,36 @@ module TcEnv( import RnHsSyn ( RenamedMonoBinds, RenamedSig ) import TcMonad -import TcType ( TcKind, TcType, TcTyVar, TcTyVarSet, - zonkTcTyVarsAndFV +import TcMType ( zonkTcTyVarsAndFV ) +import TcType ( Type, ThetaType, + tyVarsOfTypes, tcSplitDFunTy, + getDFunTyKey, tcTyConAppTyCon ) -import Id ( idName, mkUserLocal, isDataConWrapId_maybe ) -import IdInfo ( constantIdInfo ) -import MkId ( mkSpecPragmaId ) +import Id ( idName, mkSpecPragmaId, mkUserLocal, isDataConWrapId_maybe ) +import IdInfo ( vanillaIdInfo ) import Var ( TyVar, Id, idType, lazySetIdInfo, idInfo ) import VarSet -import Type ( Type, - tyVarsOfTypes, splitDFunTy, - getDFunTyKey, tyConAppTyCon - ) import DataCon ( DataCon ) import TyCon ( TyCon ) -import Class ( Class, ClassOpItem, ClassContext ) +import Class ( Class, ClassOpItem ) import Name ( Name, OccName, NamedThing(..), - nameOccName, getSrcLoc, mkLocalName, - isLocalName, nameModule_maybe + nameOccName, getSrcLoc, mkLocalName, isLocalName, + nameIsLocalOrFrom ) -import Name ( NameEnv, lookupNameEnv, nameEnvElts, extendNameEnvList, emptyNameEnv ) +import NameEnv ( NameEnv, lookupNameEnv, nameEnvElts, elemNameEnv, + extendNameEnvList, emptyNameEnv, plusNameEnv ) import OccName ( mkDFunOcc, occNameString ) -import HscTypes ( DFunId, TypeEnv, HomeSymbolTable, PackageTypeEnv ) +import HscTypes ( DFunId, + PackageTypeEnv, TypeEnv, + extendTypeEnvList, extendTypeEnvWithIds, + typeEnvTyCons, typeEnvClasses, typeEnvIds, + HomeSymbolTable + ) 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 ) @@ -86,8 +88,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) @@ -96,7 +96,8 @@ data TcEnv {- NameEnv TyThing-} -- compiling this module: -- types and classes (both imported and local) -- imported Ids - -- (Ids defined in this module are in the local envt) + -- (Ids defined in this module start in the local envt, + -- though they move to the global envt during zonking) tcLEnv :: NameEnv TcTyThing, -- The local type environment: Ids and TyVars -- defined in this module @@ -141,11 +142,10 @@ data TcTyThing -- 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, @@ -156,19 +156,23 @@ initTcEnv syntax_map hst pte | otherwise = lookupType hst pte name -tcEnvClasses env = [cl | AClass cl <- nameEnvElts (tcGEnv env)] -tcEnvTyCons env = [tc | ATyCon tc <- nameEnvElts (tcGEnv env)] -tcEnvIds env = [id | AnId id <- nameEnvElts (tcGEnv env)] +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)] getTcGEnv (TcEnv { tcGEnv = genv }) = genv +tcInLocalScope :: TcEnv -> Name -> Bool +tcInLocalScope env v = v `elemNameEnv` (tcLEnv env) + -- This data type is used to help tie the knot -- when type checking type and class declarations data TyThingDetails = SynTyDetails Type - | DataTyDetails ClassContext [DataCon] [Id] - | ClassDetails ClassContext [Id] [ClassOpItem] DataCon + | DataTyDetails ThetaType [DataCon] [Id] + | ClassDetails ThetaType [Id] [ClassOpItem] DataCon + | ForeignTyDetails -- Nothing yet \end{code} @@ -208,7 +212,7 @@ tcAddImportedIdInfo env id -- 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) constantIdInfo + Nothing -> pprTrace "tcAddIdInfo" (ppr id) vanillaIdInfo Just imported_id -> idInfo imported_id -- ToDo: could check that types are the same @@ -261,11 +265,7 @@ newDFunName clas [] loc = pprPanic "newDFunName" (ppr clas <+> ppr loc) \begin{code} isLocalThing :: NamedThing a => Module -> a -> Bool - -- True if the thing has a Local name, - -- or a Global name from the specified module -isLocalThing mod thing = case nameModule_maybe (getName thing) of - Nothing -> True -- A local name - Just m -> m == mod -- A global thing +isLocalThing mod thing = nameIsLocalOrFrom mod (getName thing) \end{code} %************************************************************************ @@ -279,7 +279,16 @@ tcExtendGlobalEnv :: [TyThing] -> TcM r -> TcM r tcExtendGlobalEnv things thing_inside = tcGetEnv `thenNF_Tc` \ env -> let - ge' = extendNameEnvList (tcGEnv env) [(getName thing, thing) | thing <- things] + ge' = extendTypeEnvList (tcGEnv env) things + in + tcSetEnv (env {tcGEnv = ge'}) thing_inside + + +tcExtendGlobalTypeEnv :: TypeEnv -> TcM r -> TcM r +tcExtendGlobalTypeEnv extra_env thing_inside + = tcGetEnv `thenNF_Tc` \ env -> + let + ge' = tcGEnv env `plusNameEnv` extra_env in tcSetEnv (env {tcGEnv = ge'}) thing_inside @@ -287,7 +296,7 @@ tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a tcExtendGlobalValEnv ids thing_inside = tcGetEnv `thenNF_Tc` \ env -> let - ge' = extendNameEnvList (tcGEnv env) [(getName id, AnId id) | id <- ids] + ge' = extendTypeEnvWithIds (tcGEnv env) ids in tcSetEnv (env {tcGEnv = ge'}) thing_inside \end{code} @@ -339,6 +348,14 @@ tcLookupTyCon name Just (ATyCon tc) -> returnNF_Tc tc other -> notFound "tcLookupTyCon" name +tcLookupId :: Name -> NF_TcM Id +tcLookupId name + = tcLookup name `thenNF_Tc` \ thing -> + case thing of + ATcId tc_id -> returnNF_Tc tc_id + AGlobal (AnId id) -> returnNF_Tc id + other -> pprPanic "tcLookupId" (ppr name) + tcLookupLocalIds :: [Name] -> NF_TcM [TcId] tcLookupLocalIds ns = tcGetEnv `thenNF_Tc` \ env -> @@ -347,21 +364,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} @@ -509,7 +511,6 @@ The InstInfo type summarises the information in an instance declaration \begin{code} data InstInfo = InstInfo { - iLocal :: Bool, -- True <=> it's defined in this module iDFunId :: DFunId, -- The dfun id iBinds :: RenamedMonoBinds, -- Bindings, b iPrags :: [RenamedSig] -- User pragmas recorded for generating specialised instances @@ -519,13 +520,13 @@ pprInstInfo info = vcat [ptext SLIT("InstInfo:") <+> ppr (idType (iDFunId info)) nest 4 (ppr (iBinds 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}