X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcEnv.lhs;h=0192bbabe9ad8f9bb4d6cb710b8e31876e6f833a;hb=0aa61e36c7baf3bb001049d495a46f0fdc330952;hp=feb9442c4695658e128fae66f0216229d3226bc0;hpb=ea659be5faea43df1b2c113d2f22947dff23367e;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs index feb9442..0192bba 100644 --- a/ghc/compiler/typecheck/TcEnv.lhs +++ b/ghc/compiler/typecheck/TcEnv.lhs @@ -16,22 +16,22 @@ module TcEnv( -- Global environment tcExtendGlobalEnv, tcExtendGlobalValEnv, tcLookupTyCon, tcLookupClass, tcLookupGlobalId, tcLookupDataCon, - tcLookupGlobal_maybe, tcLookupGlobal, + tcLookupGlobal_maybe, tcLookupGlobal, tcLookupSyntaxId, tcLookupSyntaxName, -- Local environment - tcExtendKindEnv, + tcExtendKindEnv, tcLookupLocalIds, tcExtendTyVarEnv, tcExtendTyVarEnvForMeths, - tcExtendLocalValEnv, tcLookup, + tcExtendLocalValEnv, tcLookup, tcLookup_maybe, -- Global type variables tcGetGlobalTyVars, tcExtendGlobalTyVars, -- Random useful things - RecTcEnv, tcAddImportedIdInfo, tcLookupRecId, tcInstId, + RecTcEnv, tcAddImportedIdInfo, tcLookupRecId, tcLookupRecId_maybe, -- New Ids newLocalId, newSpecPragmaId, - newDefaultMethodName, newDFunName, + newDFunName, -- Misc isLocalThing, tcSetEnv @@ -41,8 +41,8 @@ module TcEnv( import RnHsSyn ( RenamedMonoBinds, RenamedSig ) import TcMonad -import TcType ( TcKind, TcType, TcTyVar, TcTyVarSet, TcThetaType, - tcInstTyVars, zonkTcTyVars, +import TcType ( TcKind, TcType, TcTyVar, TcTyVarSet, + zonkTcTyVarsAndFV ) import Id ( idName, mkUserLocal, isDataConWrapId_maybe ) import IdInfo ( constantIdInfo ) @@ -51,25 +51,24 @@ import Var ( TyVar, Id, idType, lazySetIdInfo, idInfo ) import VarSet import Type ( Type, tyVarsOfTypes, splitDFunTy, - splitForAllTys, splitRhoTy, getDFunTyKey, tyConAppTyCon ) import DataCon ( DataCon ) import TyCon ( TyCon ) import Class ( Class, ClassOpItem, ClassContext ) -import Subst ( substTy ) import Name ( Name, OccName, NamedThing(..), - nameOccName, nameModule, getSrcLoc, mkGlobalName, + nameOccName, getSrcLoc, mkLocalName, isLocalName, nameModule_maybe ) import Name ( NameEnv, lookupNameEnv, nameEnvElts, extendNameEnvList, emptyNameEnv ) -import OccName ( mkDFunOcc, mkDefaultMethodOcc, occNameString ) +import OccName ( mkDFunOcc, occNameString ) import HscTypes ( DFunId, TypeEnv, HomeSymbolTable, PackageTypeEnv ) 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 ) @@ -87,6 +86,8 @@ 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) @@ -140,10 +141,11 @@ 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 :: HomeSymbolTable -> PackageTypeEnv -> IO TcEnv -initTcEnv hst pte +initTcEnv :: PrelNames.SyntaxMap -> HomeSymbolTable -> PackageTypeEnv -> IO TcEnv +initTcEnv syntax_map hst pte = do { gtv_var <- newIORef emptyVarSet ; - return (TcEnv { tcGST = lookup, + return (TcEnv { tcSyntaxMap = syntax_map, + tcGST = lookup, tcGEnv = emptyNameEnv, tcInsts = emptyInstEnv, tcLEnv = emptyNameEnv, @@ -165,7 +167,7 @@ getTcGEnv (TcEnv { tcGEnv = genv }) = genv -- This data type is used to help tie the knot -- when type checking type and class declarations data TyThingDetails = SynTyDetails Type - | DataTyDetails ClassContext [DataCon] + | DataTyDetails ClassContext [DataCon] [Id] | ClassDetails ClassContext [Id] [ClassOpItem] DataCon \end{code} @@ -205,45 +207,22 @@ tcAddImportedIdInfo env id = id `lazySetIdInfo` new_info -- The Id must be returned without a data dependency on maybe_id where - new_info = case tcLookupRecId env (idName id) of - Nothing -> constantIdInfo + new_info = case tcLookupRecId_maybe env (idName id) of + Nothing -> pprTrace "tcAddIdInfo" (ppr id) constantIdInfo Just imported_id -> idInfo imported_id -- ToDo: could check that types are the same -tcLookupRecId :: RecTcEnv -> Name -> Maybe Id -tcLookupRecId env name = case lookup_global env name of - Just (AnId id) -> Just id - other -> Nothing - -\end{code} - -%************************************************************************ -%* * -\subsection{Random useful functions} -%* * -%************************************************************************ - +tcLookupRecId_maybe :: RecTcEnv -> Name -> Maybe Id +tcLookupRecId_maybe env name = case lookup_global env name of + Just (AnId id) -> Just id + other -> Nothing -\begin{code} --- A useful function that takes an occurrence of a global thing --- and instantiates its type with fresh type variables -tcInstId :: Id - -> NF_TcM ([TcTyVar], -- It's instantiated type - TcThetaType, -- - TcType) -- -tcInstId id - = let - (tyvars, rho) = splitForAllTys (idType id) - in - tcInstTyVars tyvars `thenNF_Tc` \ (tyvars', arg_tys, tenv) -> - let - rho' = substTy tenv rho - (theta', tau') = splitRhoTy rho' - in - returnNF_Tc (tyvars', theta', tau') +tcLookupRecId :: RecTcEnv -> Name -> Id +tcLookupRecId env name = case lookup_global env name of + Just (AnId id) -> id + Nothing -> pprPanic "tcLookupRecId" (ppr name) \end{code} - %************************************************************************ %* * \subsection{Making new Ids} @@ -264,28 +243,20 @@ newSpecPragmaId name ty returnNF_Tc (mkSpecPragmaId (nameOccName name) uniq ty (getSrcLoc name)) \end{code} -Make a name for the dict fun for an instance decl +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. \begin{code} -newDFunName :: Module -> Class -> [Type] -> SrcLoc -> NF_TcM Name -newDFunName mod clas (ty:_) loc - = tcGetDFunUniq dfun_string `thenNF_Tc` \ inst_uniq -> - tcGetUnique `thenNF_Tc` \ uniq -> - returnNF_Tc (mkGlobalName uniq mod - (mkDFunOcc dfun_string inst_uniq) - loc) +newDFunName :: Class -> [Type] -> SrcLoc -> NF_TcM Name +newDFunName clas (ty:_) loc + = tcGetUnique `thenNF_Tc` \ uniq -> + returnNF_Tc (mkLocalName uniq (mkDFunOcc dfun_string) loc) where -- Any string that is somewhat unique will do dfun_string = occNameString (getOccName clas) ++ occNameString (getDFunTyKey ty) -newDFunName mod clas [] loc = pprPanic "newDFunName" (ppr mod <+> ppr clas <+> ppr loc) - -newDefaultMethodName :: Name -> SrcLoc -> NF_TcM Name -newDefaultMethodName op_name loc - = tcGetUnique `thenNF_Tc` \ uniq -> - returnNF_Tc (mkGlobalName uniq (nameModule op_name) - (mkDefaultMethodOcc (getOccName op_name)) - loc) +newDFunName clas [] loc = pprPanic "newDFunName" (ppr clas <+> ppr loc) \end{code} \begin{code} @@ -304,17 +275,21 @@ isLocalThing mod thing = case nameModule_maybe (getName thing) of %************************************************************************ \begin{code} -tcExtendGlobalEnv :: [(Name, TyThing)] -> TcM r -> TcM r -tcExtendGlobalEnv bindings thing_inside +tcExtendGlobalEnv :: [TyThing] -> TcM r -> TcM r +tcExtendGlobalEnv things thing_inside = tcGetEnv `thenNF_Tc` \ env -> let - ge' = extendNameEnvList (tcGEnv env) bindings + ge' = extendNameEnvList (tcGEnv env) [(getName thing, thing) | thing <- things] in tcSetEnv (env {tcGEnv = ge'}) thing_inside tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a tcExtendGlobalValEnv ids thing_inside - = tcExtendGlobalEnv [(getName id, AnId id) | id <- ids] thing_inside + = tcGetEnv `thenNF_Tc` \ env -> + let + ge' = extendNameEnvList (tcGEnv env) [(getName id, AnId id) | id <- ids] + in + tcSetEnv (env {tcGEnv = ge'}) thing_inside \end{code} @@ -339,8 +314,8 @@ tcLookupGlobalId :: Name -> NF_TcM Id tcLookupGlobalId name = tcLookupGlobal_maybe name `thenNF_Tc` \ maybe_id -> case maybe_id of - Just (AnId clas) -> returnNF_Tc clas - other -> notFound "tcLookupGlobalId" name + Just (AnId id) -> returnNF_Tc id + other -> notFound "tcLookupGlobalId" name tcLookupDataCon :: Name -> TcM DataCon tcLookupDataCon con_name @@ -363,6 +338,30 @@ tcLookupTyCon name case maybe_tc of Just (ATyCon tc) -> returnNF_Tc tc other -> notFound "tcLookupTyCon" name + +tcLookupLocalIds :: [Name] -> NF_TcM [TcId] +tcLookupLocalIds ns + = tcGetEnv `thenNF_Tc` \ env -> + returnNF_Tc (map (lookup (tcLEnv env)) ns) + where + 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.fromInt +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} @@ -472,13 +471,10 @@ the environment. tcGetGlobalTyVars :: NF_TcM TcTyVarSet tcGetGlobalTyVars = tcGetEnv `thenNF_Tc` \ (TcEnv {tcTyVars = gtv_var}) -> - tcReadMutVar gtv_var `thenNF_Tc` \ global_tvs -> - zonkTcTyVars (varSetElems global_tvs) `thenNF_Tc` \ global_tys' -> - let - global_tvs' = (tyVarsOfTypes global_tys') - in - tcWriteMutVar gtv_var global_tvs' `thenNF_Tc_` - returnNF_Tc global_tvs' + tcReadMutVar gtv_var `thenNF_Tc` \ gbl_tvs -> + zonkTcTyVarsAndFV (varSetElems gbl_tvs) `thenNF_Tc` \ gbl_tvs' -> + tcWriteMutVar gtv_var gbl_tvs' `thenNF_Tc_` + returnNF_Tc gbl_tvs' \end{code}