X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcEnv.lhs;h=d0388456e7ad153fdf1e3e84ae32f25d871e278b;hp=1f9d3050eff2fd7094b829ee8ace3e4949b43511;hb=61bcd16d4f3d4cf84b26bf7bb92f16f0440b7071;hpb=1c9ffbe64003cef8a686ff1e29aae160e314775e diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs index 1f9d305..d038845 100644 --- a/compiler/typecheck/TcEnv.lhs +++ b/compiler/typecheck/TcEnv.lhs @@ -3,13 +3,6 @@ % \begin{code} -{-# OPTIONS -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details - module TcEnv( TyThing(..), TcTyThing(..), TcId, @@ -19,7 +12,7 @@ module TcEnv( InstBindings(..), -- Global environment - tcExtendGlobalEnv, + tcExtendGlobalEnv, setGlobalTypeEnv, tcExtendGlobalValEnv, tcLookupLocatedGlobal, tcLookupGlobal, tcLookupField, tcLookupTyCon, tcLookupClass, tcLookupDataCon, @@ -46,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" @@ -62,6 +56,7 @@ import TcMType import TcType -- import TcSuspension import qualified Type +import Id import Var import VarSet import VarEnv @@ -71,16 +66,15 @@ import FamInstEnv import DataCon import TyCon import TypeRep -import Coercion import Class import Name -import PrelNames import NameEnv import OccName import HscTypes import SrcLoc import Outputable import Maybes +import Unique import FastString \end{code} @@ -114,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 @@ -126,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 }}}}} @@ -148,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 @@ -156,21 +148,21 @@ tcLookupDataCon name = do thing <- tcLookupGlobal name case thing of ADataCon con -> return con - other -> wrongThingErr "data constructor" (AGlobal thing) name + _ -> wrongThingErr "data constructor" (AGlobal thing) name tcLookupClass :: Name -> TcM Class tcLookupClass name = do thing <- tcLookupGlobal name case thing of AClass cls -> return cls - other -> wrongThingErr "class" (AGlobal thing) name - + _ -> wrongThingErr "class" (AGlobal thing) name + tcLookupTyCon :: Name -> TcM TyCon tcLookupTyCon name = do thing <- tcLookupGlobal name case thing of ATyCon tc -> return tc - other -> wrongThingErr "type constructor" (AGlobal thing) name + _ -> wrongThingErr "type constructor" (AGlobal thing) name tcLookupLocatedGlobalId :: Located Name -> TcM Id tcLookupLocatedGlobalId = addLocM tcLookupId @@ -208,7 +200,7 @@ tcLookupFamInst tycon tys ; case lookupFamInstEnv instEnv tycon tys of [(fam_inst, rep_tys)] -> return $ Just (famInstTyCon fam_inst, rep_tys) - other -> return Nothing + _ -> return Nothing } \end{code} @@ -220,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} @@ -267,7 +268,7 @@ tcLookupTyVar name = do thing <- tcLookup name case thing of ATyVar _ ty -> return (tcGetTyVar "tcLookupTyVar" ty) - other -> pprPanic "tcLookupTyVar" (ppr name) + _ -> pprPanic "tcLookupTyVar" (ppr name) tcLookupId :: Name -> TcM Id -- Used when we aren't interested in the binding level, nor refinement. @@ -279,7 +280,7 @@ tcLookupId name = do case thing of ATcId { tct_id = id} -> return id AGlobal (AnId id) -> return id - other -> pprPanic "tcLookupId" (ppr name) + _ -> pprPanic "tcLookupId" (ppr name) tcLookupLocalIds :: [Name] -> TcM [TcId] -- We expect the variables to all be bound, and all at @@ -292,7 +293,7 @@ tcLookupLocalIds ns = do = case lookupNameEnv lenv name of Just (ATcId { tct_id = id, tct_level = lvl1 }) -> ASSERT( lvl == lvl1 ) id - other -> pprPanic "tcLookupLocalIds" (ppr name) + _ -> pprPanic "tcLookupLocalIds" (ppr name) lclEnvElts :: TcLclEnv -> [TcTyThing] lclEnvElts env = nameEnvElts (tcl_env env) @@ -431,6 +432,8 @@ findGlobals tvs tidy_env = do ignore_it ty = tvs `disjointVarSet` tyVarsOfType ty ----------------------- +find_thing :: (TcType -> Bool) -> TidyEnv -> TcTyThing + -> TcM (TidyEnv, Maybe SDoc) find_thing ignore_it tidy_env (ATcId { tct_id = id }) = do id_ty <- zonkTcType (idType id) if ignore_it id_ty then @@ -438,7 +441,7 @@ find_thing ignore_it tidy_env (ATcId { tct_id = id }) = do else let (tidy_env', tidy_ty) = tidyOpenType tidy_env id_ty msg = sep [ppr id <+> dcolon <+> ppr tidy_ty, - nest 2 (parens (ptext SLIT("bound at") <+> + nest 2 (parens (ptext (sLit "bound at") <+> ppr (getSrcLoc id)))] in return (tidy_env', Just msg) @@ -450,13 +453,13 @@ find_thing ignore_it tidy_env (ATyVar tv ty) = do else let -- The name tv is scoped, so we don't need to tidy it (tidy_env1, tidy_ty) = tidyOpenType tidy_env tv_ty - msg = sep [ptext SLIT("Scoped type variable") <+> quotes (ppr tv) <+> eq_stuff, nest 2 bound_at] + msg = sep [ptext (sLit "Scoped type variable") <+> quotes (ppr tv) <+> eq_stuff, nest 2 bound_at] eq_stuff | Just tv' <- Type.getTyVar_maybe tv_ty, getOccName tv == getOccName tv' = empty | otherwise = equals <+> ppr tidy_ty -- It's ok to use Type.getTyVar_maybe because ty is zonked by now - bound_at = parens $ ptext SLIT("bound at:") <+> ppr (getSrcLoc tv) + bound_at = parens $ ptext (sLit "bound at:") <+> ppr (getSrcLoc tv) in return (tidy_env1, Just msg) @@ -470,6 +473,7 @@ find_thing _ _ thing = pprPanic "find_thing" (ppr thing) %************************************************************************ \begin{code} +tc_extend_gtvs :: IORef VarSet -> VarSet -> TcM (IORef VarSet) tc_extend_gtvs gtvs extra_global_tvs = do global_tvs <- readMutVar gtvs newMutVar (global_tvs `unionVarSet` extra_global_tvs) @@ -539,14 +543,14 @@ checkWellStaged pp_thing bind_lvl use_stage | bind_lvl == topLevel -- GHC restriction on top level splices = failWithTc $ - sep [ptext SLIT("GHC stage restriction:") <+> pp_thing, - nest 2 (ptext SLIT("is used in a top-level splice, and must be imported, not defined locally"))] + sep [ptext (sLit "GHC stage restriction:") <+> pp_thing, + nest 2 (ptext (sLit "is used in a top-level splice, and must be imported, not defined locally"))] | otherwise -- Badly staged = failWithTc $ -- E.g. \x -> $(f x) - ptext SLIT("Stage error:") <+> pp_thing <+> - hsep [ptext SLIT("is bound at stage") <+> ppr bind_lvl, - ptext SLIT("but used at stage") <+> ppr use_lvl] + ptext (sLit "Stage error:") <+> pp_thing <+> + hsep [ptext (sLit "is bound at stage") <+> ppr bind_lvl, + ptext (sLit "but used at stage") <+> ppr use_lvl] where use_lvl = thLevel use_stage @@ -582,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) @@ -605,40 +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 info = vcat [ptext SLIT("InstInfo:") <+> ppr (idType (iDFunId info))] +pprInstInfo :: InstInfo a -> SDoc +pprInstInfo info = vcat [ptext (sLit "InstInfo:") <+> ppr (idType (iDFunId info))] +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) + (_, _, 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) @@ -675,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} %************************************************************************ %* * @@ -689,13 +727,15 @@ pprBinders :: [Name] -> SDoc pprBinders [bndr] = quotes (ppr bndr) pprBinders bndrs = pprWithCommas ppr bndrs +notFound :: Name -> TcGblEnv -> TcM TyThing notFound name env - = failWithTc (vcat[ptext SLIT("GHC internal error:") <+> quotes (ppr name) <+> - ptext SLIT("is not in scope during type checking, but it passed the renamer"), - ptext SLIT("tcg_type_env of environment:") <+> ppr (tcg_type_env env)] + = failWithTc (vcat[ptext (sLit "GHC internal error:") <+> quotes (ppr name) <+> + ptext (sLit "is not in scope during type checking, but it passed the renamer"), + ptext (sLit "tcg_type_env of environment:") <+> ppr (tcg_type_env env)] ) +wrongThingErr :: String -> TcTyThing -> Name -> TcM a wrongThingErr expected thing name = failWithTc (pprTcTyThingCategory thing <+> quotes (ppr name) <+> - ptext SLIT("used as a") <+> text expected) + ptext (sLit "used as a") <+> text expected) \end{code}