X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcEnv.lhs;h=1c77e4d12903d84dd05dd2e2255cef888f15e548;hb=4e3255388e8b99ccdae290bfcb6cd666b8c93d4a;hp=466819929a5ccdeb98d1f89537485711f6a24ac5;hpb=6195332e01b8b6e6ddfa109af36e4f0798c1ea6a;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs index 4668199..1c77e4d 100644 --- a/ghc/compiler/typecheck/TcEnv.lhs +++ b/ghc/compiler/typecheck/TcEnv.lhs @@ -10,18 +10,19 @@ module TcEnv( -- Global environment tcExtendGlobalEnv, tcExtendGlobalValEnv, - tcLookupGlobal, + tcLookupLocatedGlobal, tcLookupGlobal, tcLookupGlobalId, tcLookupTyCon, tcLookupClass, tcLookupDataCon, + tcLookupLocatedGlobalId, tcLookupLocatedTyCon, + tcLookupLocatedClass, tcLookupLocatedDataCon, - getInGlobalScope, - -- Local environment - tcExtendTyVarKindEnv, + tcExtendKindEnv, tcExtendTyVarEnv, tcExtendTyVarEnv2, tcExtendLocalValEnv, tcExtendLocalValEnv2, - tcLookup, tcLookupLocalIds, + tcLookup, tcLookupLocated, tcLookupLocalIds, tcLookupId, tcLookupTyVar, lclEnvElts, getInLocalScope, findGlobals, + wrongThingErr, tcExtendRecEnv, -- For knot-tying @@ -44,35 +45,32 @@ module TcEnv( #include "HsVersions.h" -import RnHsSyn ( RenamedMonoBinds, RenamedSig ) -import HsSyn ( RuleDecl(..), , HsTyVarBndr(..) ) +import HsSyn ( LRuleDecl, LHsBinds, LSig, pprLHsBinds ) import TcIface ( tcImportDecl ) import TcRnMonad import TcMType ( zonkTcType, zonkTcTyVar, zonkTcTyVarsAndFV ) -import TcType ( Type, TcTyVar, TcTyVarSet, +import TcType ( Type, TcKind, TcTyVar, TcTyVarSet, tyVarsOfType, tyVarsOfTypes, tcSplitDFunTy, mkGenTyConApp, getDFunTyKey, tcTyConAppTyCon, tyVarBindingInfo, tidyOpenType, tidyOpenTyVar ) import qualified Type ( getTyVar_maybe ) import Id ( idName, isLocalId ) -import Var ( TyVar, Id, mkTyVar, idType ) +import Var ( TyVar, Id, idType ) import VarSet import VarEnv import RdrName ( extendLocalRdrEnv ) import DataCon ( DataCon ) import TyCon ( TyCon ) import Class ( Class ) -import Name ( Name, NamedThing(..), - getSrcLoc, mkInternalName, nameIsLocalOrFrom - ) +import Name ( Name, NamedThing(..), getSrcLoc, mkInternalName, nameIsLocalOrFrom ) import NameEnv import OccName ( mkDFunOcc, occNameString ) import HscTypes ( DFunId, extendTypeEnvList, lookupType, - TyThing(..), tyThingId, tyThingTyCon, tyThingClass, tyThingDataCon, + TyThing(..), tyThingId, tyThingDataCon, ExternalPackageState(..) ) -import SrcLoc ( SrcLoc ) +import SrcLoc ( SrcLoc, Located(..) ) import Outputable import Maybe ( isJust ) \end{code} @@ -84,9 +82,17 @@ import Maybe ( isJust ) %* * %************************************************************************ +Using the Located versions (eg. tcLookupLocatedGlobal) is preferred, +unless you know that the SrcSpan in the monad is already set to the +span of the Name. + \begin{code} -tcLookupGlobal :: Name -> TcM TyThing +tcLookupLocatedGlobal :: Located Name -> TcM TyThing -- c.f. IfaceEnvEnv.tcIfaceGlobal +tcLookupLocatedGlobal name + = addLocM tcLookupGlobal name + +tcLookupGlobal :: Name -> TcM TyThing tcLookupGlobal name = do { env <- getGblEnv ; if nameIsLocalOrFrom (tcg_mod env) name @@ -97,8 +103,7 @@ tcLookupGlobal name Nothing -> notFound "tcLookupGlobal" name else do -- It's imported - { eps <- getEps - ; hpt <- getHpt + { (eps,hpt) <- getEpsAndHpt ; case lookupType hpt (eps_PTE eps) name of Just thing -> return thing Nothing -> do { traceIf (text "tcLookupGlobal" <+> ppr name) @@ -120,13 +125,29 @@ tcLookupDataCon con_name tcLookupClass :: Name -> TcM Class tcLookupClass name - = tcLookupGlobal name `thenM` \ thing -> - return (tyThingClass thing) + = tcLookupGlobal name `thenM` \ thing -> + case thing of + AClass cls -> return cls + other -> wrongThingErr "class" (AGlobal thing) name tcLookupTyCon :: Name -> TcM TyCon tcLookupTyCon name - = tcLookupGlobal name `thenM` \ thing -> - return (tyThingTyCon thing) + = tcLookupGlobal name `thenM` \ thing -> + case thing of + ATyCon tc -> return tc + other -> wrongThingErr "type constructor" (AGlobal thing) name + +tcLookupLocatedGlobalId :: Located Name -> TcM Id +tcLookupLocatedGlobalId = addLocM tcLookupId + +tcLookupLocatedDataCon :: Located Name -> TcM DataCon +tcLookupLocatedDataCon = addLocM tcLookupDataCon + +tcLookupLocatedClass :: Located Name -> TcM Class +tcLookupLocatedClass = addLocM tcLookupClass + +tcLookupLocatedTyCon :: Located Name -> TcM TyCon +tcLookupLocatedTyCon = addLocM tcLookupTyCon \end{code} %************************************************************************ @@ -151,33 +172,14 @@ tcExtendGlobalValEnv ids thing_inside = tcExtendGlobalEnv [AnId id | id <- ids] thing_inside \end{code} -A variety of global lookups, when we know what we are looking for. - \begin{code} -getInGlobalScope :: TcM (Name -> Bool) --- Get all things in the global environment; used for deciding what --- rules to suck in. Anything defined in this module (nameIsLocalOrFrom) --- is certainly in the envt, so we don't bother to look. -getInGlobalScope - = do { mod <- getModule - ; eps <- getEps - ; hpt <- getHpt - ; return (\n -> nameIsLocalOrFrom mod n || - isJust (lookupType hpt (eps_PTE eps) n)) } -\end{code} - - -\begin{code} -tcExtendRecEnv :: [(Name,TyThing)] -- Global bindings - -> [(Name,TcTyThing)] -- Local bindings - -> TcM r -> TcM r --- Extend both local and global environments for the type/class knot tying game -tcExtendRecEnv gbl_stuff lcl_stuff thing_inside - = do { (gbl_env, lcl_env) <- getEnvs - ; let { ge' = extendNameEnvList (tcg_type_env gbl_env) gbl_stuff - ; le' = extendNameEnvList (tcl_env lcl_env) lcl_stuff } - ; setEnvs (gbl_env {tcg_type_env = ge'}, lcl_env {tcl_env = le'}) - thing_inside } +tcExtendRecEnv :: [(Name,TyThing)] -> TcM r -> TcM r +-- Extend the global environments for the type/class knot tying game +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 \end{code} @@ -188,6 +190,9 @@ tcExtendRecEnv gbl_stuff lcl_stuff thing_inside %************************************************************************ \begin{code} +tcLookupLocated :: Located Name -> TcM TcTyThing +tcLookupLocated = addLocM tcLookup + tcLookup :: Name -> TcM TcTyThing tcLookup name = getLclEnv `thenM` \ local_env -> @@ -238,15 +243,12 @@ getInLocalScope = getLclEnv `thenM` \ env -> \end{code} \begin{code} -tcExtendTyVarKindEnv :: [HsTyVarBndr Name] -> TcM r -> TcM r --- The tyvars are all kinded -tcExtendTyVarKindEnv tvs thing_inside +tcExtendKindEnv :: [(Name, TcKind)] -> TcM r -> TcM r +tcExtendKindEnv things thing_inside = updLclEnv upd thing_inside where upd lcl_env = lcl_env { tcl_env = extend (tcl_env lcl_env) } - extend env = extendNameEnvList env [(n, ATyVar (mkTyVar n k)) - | KindedTyVar n k <- tvs] - -- No need to extend global tyvars for kind checking + extend env = extendNameEnvList env [(n, AThing k) | (n,k) <- things] tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r tcExtendTyVarEnv tvs thing_inside @@ -400,7 +402,7 @@ tcGetGlobalTyVars %************************************************************************ \begin{code} -tcExtendRules :: [RuleDecl Id] -> TcM a -> TcM a +tcExtendRules :: [LRuleDecl Id] -> TcM a -> TcM a -- Just pop the new rules into the EPS and envt resp -- All the rules come from an interface file, not soruce -- Nevertheless, some may be for this module, if we read @@ -566,8 +568,8 @@ data InstInfo data InstBindings = VanillaInst -- The normal case - RenamedMonoBinds -- Bindings - [RenamedSig] -- User pragmas recorded for generating + (LHsBinds Name) -- Bindings + [LSig Name] -- User pragmas recorded for generating -- specialised instances | NewTypeDerived -- Used for deriving instances of newtypes, where the @@ -580,7 +582,7 @@ pprInstInfo info = vcat [ptext SLIT("InstInfo:") <+> ppr (idType (iDFunId info)) pprInstInfoDetails info = pprInstInfo info $$ nest 2 (details (iBinds info)) where - details (VanillaInst b _) = ppr b + details (VanillaInst b _) = pprLHsBinds b details (NewTypeDerived _) = text "Derived from the representation type" simpleInstInfoTy :: InstInfo -> Type @@ -603,4 +605,15 @@ simpleInstInfoTyCon inst = tcTyConAppTyCon (simpleInstInfoTy inst) \begin{code} notFound wheRe name = failWithTc (text wheRe <> colon <+> quotes (ppr name) <+> ptext SLIT("is not in scope")) + +wrongThingErr expected thing name + = failWithTc (pp_thing thing <+> quotes (ppr name) <+> + ptext SLIT("used as a") <+> text expected) + where + pp_thing (AGlobal (ATyCon _)) = ptext SLIT("Type constructor") + pp_thing (AGlobal (AClass _)) = ptext SLIT("Class") + pp_thing (AGlobal (AnId _)) = ptext SLIT("Identifier") + pp_thing (AGlobal (ADataCon _)) = ptext SLIT("Data constructor") + pp_thing (ATyVar _) = ptext SLIT("Type variable") + pp_thing (ATcId _ _ _) = ptext SLIT("Local identifier") \end{code}