X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcEnv.lhs;h=d0388456e7ad153fdf1e3e84ae32f25d871e278b;hp=74eb195ca93b9ac8f95187910194b75459837a04;hb=61bcd16d4f3d4cf84b26bf7bb92f16f0440b7071;hpb=a364279dac70162e4e22f7673c01642de6afaf6f diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs index 74eb195..d038845 100644 --- a/compiler/typecheck/TcEnv.lhs +++ b/compiler/typecheck/TcEnv.lhs @@ -12,7 +12,7 @@ module TcEnv( InstBindings(..), -- Global environment - tcExtendGlobalEnv, + tcExtendGlobalEnv, setGlobalTypeEnv, tcExtendGlobalValEnv, tcLookupLocatedGlobal, tcLookupGlobal, tcLookupField, tcLookupTyCon, tcLookupClass, tcLookupDataCon, @@ -39,10 +39,11 @@ module TcEnv( -- Template Haskell stuff checkWellStaged, spliceOK, bracketOK, tcMetaTy, thLevel, - topIdLvl, thTopLevelId, + topIdLvl, thTopLevelId, thRnBrack, isBrackStage, -- New Ids - newLocalName, newDFunName, newFamInstTyConName, + newLocalName, newDFunName, newFamInstTyConName, + mkStableIdFromString, mkStableIdFromName ) where #include "HsVersions.h" @@ -55,6 +56,7 @@ import TcMType import TcType -- import TcSuspension import qualified Type +import Id import Var import VarSet import VarEnv @@ -66,13 +68,13 @@ import TyCon import TypeRep import Class import Name -import PrelNames import NameEnv import OccName import HscTypes import SrcLoc import Outputable import Maybes +import Unique import FastString \end{code} @@ -106,9 +108,9 @@ tcLookupGlobal name Nothing -> do -- Try global envt - { (eps,hpt) <- getEpsAndHpt - ; dflags <- getDOpts - ; case lookupType dflags hpt (eps_PTE eps) name of { + { hsc_env <- getTopEnv + ; mb_thing <- liftIO (lookupTypeHscEnv hsc_env name) + ; case mb_thing of { Just thing -> return thing ; Nothing -> do @@ -118,8 +120,6 @@ tcLookupGlobal name Just mod | mod == tcg_mod env -- Names from this module -> notFound name env -- should be in tcg_type_env - | mod == thFAKE -- Names bound in TH declaration brackets - -> notFound name env -- should be in tcg_env | otherwise -> tcImportDecl name -- Go find it in an interface }}}}} @@ -140,7 +140,7 @@ Then the renamer (which does not keep track of what is a record selector and what is not) will rename the definition thus f_7 = e { f_7 = True } Now the type checker will find f_7 in the *local* type environment, not -the global one. It's wrong, of course, but we want to report a tidy +the global (imported) one. It's wrong, of course, but we want to report a tidy error, not in TcEnv.notFound. -} tcLookupDataCon :: Name -> TcM DataCon @@ -212,28 +212,37 @@ tcLookupFamInst tycon tys \begin{code} +setGlobalTypeEnv :: TcGblEnv -> TypeEnv -> TcM TcGblEnv +-- Use this to update the global type env +-- It updates both * the normal tcg_type_env field +-- * the tcg_type_env_var field seen by interface files +setGlobalTypeEnv tcg_env new_type_env + = do { -- Sync the type-envt variable seen by interface files + writeMutVar (tcg_type_env_var tcg_env) new_type_env + ; return (tcg_env { tcg_type_env = new_type_env }) } + tcExtendGlobalEnv :: [TyThing] -> TcM r -> TcM r -- Given a mixture of Ids, TyCons, Classes, all from the -- module being compiled, extend the global environment tcExtendGlobalEnv things thing_inside - = do { env <- getGblEnv - ; let ge' = extendTypeEnvList (tcg_type_env env) things - ; setGblEnv (env {tcg_type_env = ge'}) thing_inside } + = do { tcg_env <- getGblEnv + ; let ge' = extendTypeEnvList (tcg_type_env tcg_env) things + ; tcg_env' <- setGlobalTypeEnv tcg_env ge' + ; setGblEnv tcg_env' thing_inside } tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a -- Same deal as tcExtendGlobalEnv, but for Ids tcExtendGlobalValEnv ids thing_inside = tcExtendGlobalEnv [AnId id | id <- ids] thing_inside -\end{code} -\begin{code} tcExtendRecEnv :: [(Name,TyThing)] -> TcM r -> TcM r -- Extend the global environments for the type/class knot tying game +-- Just like tcExtendGlobalEnv, except the argument is a list of pairs tcExtendRecEnv gbl_stuff thing_inside - = updGblEnv upd thing_inside - where - upd env = env { tcg_type_env = extend (tcg_type_env env) } - extend env = extendNameEnvList env gbl_stuff + = do { tcg_env <- getGblEnv + ; let ge' = extendNameEnvList (tcg_type_env tcg_env) gbl_stuff + ; tcg_env' <- setGlobalTypeEnv tcg_env ge' + ; setGblEnv tcg_env' thing_inside } \end{code} @@ -577,6 +586,16 @@ tcMetaTy tc_name = do t <- tcLookupTyCon tc_name return (mkTyConApp t []) +thRnBrack :: ThStage +-- Used *only* to indicate that we are inside a TH bracket during renaming +-- Tested by TcEnv.isBrackStage +-- See Note [Top-level Names in Template Haskell decl quotes] +thRnBrack = Brack (panic "thRnBrack1") (panic "thRnBrack2") (panic "thRnBrack3") + +isBrackStage :: ThStage -> Bool +isBrackStage (Brack {}) = True +isBrackStage _other = False + thTopLevelId :: Id -> Bool -- See Note [What is a top-level Id?] in TcSplice thTopLevelId id = isGlobalId id || isExternalName (idName id) @@ -600,43 +619,43 @@ But local instance decls includes as well as explicit user written ones. \begin{code} -data InstInfo +data InstInfo a = InstInfo { iSpec :: Instance, -- Includes the dfun id. Its forall'd type - iBinds :: InstBindings -- variables scope over the stuff in InstBindings! + iBinds :: InstBindings a -- variables scope over the stuff in InstBindings! } -iDFunId :: InstInfo -> DFunId +iDFunId :: InstInfo a -> DFunId iDFunId info = instanceDFunId (iSpec info) -data InstBindings +data InstBindings a = VanillaInst -- The normal case - (LHsBinds Name) -- Bindings for the instance methods - [LSig Name] -- User pragmas recorded for generating + (LHsBinds a) -- Bindings for the instance methods + [LSig a] -- User pragmas recorded for generating -- specialised instances | NewTypeDerived -- Used for deriving instances of newtypes, where the -- witness dictionary is identical to the argument -- dictionary. Hence no bindings, no pragmas. -pprInstInfo :: InstInfo -> SDoc +pprInstInfo :: InstInfo a -> SDoc pprInstInfo info = vcat [ptext (sLit "InstInfo:") <+> ppr (idType (iDFunId info))] -pprInstInfoDetails :: InstInfo -> SDoc +pprInstInfoDetails :: OutputableBndr a => InstInfo a -> SDoc pprInstInfoDetails info = pprInstInfo info $$ nest 2 (details (iBinds info)) where details (VanillaInst b _) = pprLHsBinds b details NewTypeDerived = text "Derived from the representation type" -simpleInstInfoClsTy :: InstInfo -> (Class, Type) +simpleInstInfoClsTy :: InstInfo a -> (Class, Type) simpleInstInfoClsTy info = case instanceHead (iSpec info) of (_, _, cls, [ty]) -> (cls, ty) _ -> panic "simpleInstInfoClsTy" -simpleInstInfoTy :: InstInfo -> Type +simpleInstInfoTy :: InstInfo a -> Type simpleInstInfoTy info = snd (simpleInstInfoClsTy info) -simpleInstInfoTyCon :: InstInfo -> TyCon +simpleInstInfoTyCon :: InstInfo a -> 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 = tcTyConAppTyCon (simpleInstInfoTy inst) @@ -673,6 +692,27 @@ newFamInstTyConName tc_name loc ; newGlobalBinder mod (mkInstTyTcOcc index occ) loc } \end{code} +Stable names used for foreign exports and annotations. +For stable names, the name must be unique (see #1533). If the +same thing has several stable Ids based on it, the +top-level bindings generated must not have the same name. +Hence we create an External name (doesn't change), and we +append a Unique to the string right here. + +\begin{code} +mkStableIdFromString :: String -> Type -> SrcSpan -> (OccName -> OccName) -> TcM TcId +mkStableIdFromString str sig_ty loc occ_wrapper = do + uniq <- newUnique + mod <- getModule + let uniq_str = showSDoc (pprUnique uniq) :: String + occ = mkVarOcc (str ++ '_' : uniq_str) :: OccName + gnm = mkExternalName uniq mod (occ_wrapper occ) loc :: Name + id = mkExportedLocalId gnm sig_ty :: Id + return id + +mkStableIdFromName :: Name -> Type -> SrcSpan -> (OccName -> OccName) -> TcM TcId +mkStableIdFromName nm = mkStableIdFromString (getOccString nm) +\end{code} %************************************************************************ %* *