From 204105777c7a67e99ccdc88106255bb83a033f1c Mon Sep 17 00:00:00 2001 From: simonpj Date: Tue, 22 Jun 2004 11:03:51 +0000 Subject: [PATCH] [project @ 2004-06-22 11:03:42 by simonpj] ----------------------------------------------- Improve reporting of TH reify out-of-scope errors ----------------------------------------------- No change to functionality, just better error reports. --- ghc/compiler/iface/IfaceEnv.lhs | 3 +-- ghc/compiler/rename/RnNames.lhs | 3 +-- ghc/compiler/typecheck/TcEnv.lhs | 6 ++--- ghc/compiler/typecheck/TcRnMonad.lhs | 4 ++++ ghc/compiler/typecheck/TcSplice.lhs | 43 ++++++++++++++++++++++++++++++---- 5 files changed, 46 insertions(+), 13 deletions(-) diff --git a/ghc/compiler/iface/IfaceEnv.lhs b/ghc/compiler/iface/IfaceEnv.lhs index e987637..5cfc903 100644 --- a/ghc/compiler/iface/IfaceEnv.lhs +++ b/ghc/compiler/iface/IfaceEnv.lhs @@ -259,8 +259,7 @@ initOrigNames names = foldl extendOrigNameCache emptyModuleEnv names \begin{code} tcIfaceGlobal :: Name -> IfM a TyThing tcIfaceGlobal name - = do { eps <- getEps - ; hpt <- getHpt + = do { (eps,hpt) <- getEpsAndHpt ; case lookupType hpt (eps_PTE eps) name of { Just thing -> return thing ; Nothing -> diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index baa7c74..58f8166 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -728,8 +728,7 @@ check_occs ie occs names reportDeprecations :: TcGblEnv -> RnM () reportDeprecations tcg_env = ifOptM Opt_WarnDeprecations $ - do { hpt <- getHpt - ; eps <- getEps + do { (eps,hpt) <- getEpsAndHpt ; mapM_ (check hpt (eps_PIT eps)) all_gres } where used_names = findUses (tcg_dus tcg_env) emptyNameSet diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs index cb2eb28..6ac4272 100644 --- a/ghc/compiler/typecheck/TcEnv.lhs +++ b/ghc/compiler/typecheck/TcEnv.lhs @@ -105,8 +105,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) @@ -184,8 +183,7 @@ getInGlobalScope :: TcM (Name -> Bool) -- is certainly in the envt, so we don't bother to look. getInGlobalScope = do { mod <- getModule - ; eps <- getEps - ; hpt <- getHpt + ; (eps,hpt) <- getEpsAndHpt ; return (\n -> nameIsLocalOrFrom mod n || isJust (lookupType hpt (eps_PTE eps) n)) } \end{code} diff --git a/ghc/compiler/typecheck/TcRnMonad.lhs b/ghc/compiler/typecheck/TcRnMonad.lhs index 35f9169..3632acd 100644 --- a/ghc/compiler/typecheck/TcRnMonad.lhs +++ b/ghc/compiler/typecheck/TcRnMonad.lhs @@ -274,6 +274,10 @@ updateEps_ upd_fn = do { eps_var <- getEpsVar getHpt :: TcRnIf gbl lcl HomePackageTable getHpt = do { env <- getTopEnv; return (hsc_HPT env) } + +getEpsAndHpt :: TcRnIf gbl lcl (ExternalPackageState, HomePackageTable) +getEpsAndHpt = do { env <- getTopEnv; eps <- readMutVar (hsc_EPS env) + ; return (eps, hsc_HPT env) } \end{code} %************************************************************************ diff --git a/ghc/compiler/typecheck/TcSplice.lhs b/ghc/compiler/typecheck/TcSplice.lhs index 63d5750..89d4a7a 100644 --- a/ghc/compiler/typecheck/TcSplice.lhs +++ b/ghc/compiler/typecheck/TcSplice.lhs @@ -29,17 +29,20 @@ import TcHsSyn ( mkHsLet, zonkTopLExpr ) import TcSimplify ( tcSimplifyTop, tcSimplifyBracket ) import TcUnify ( Expected, zapExpectedTo, zapExpectedType ) import TcType ( TcType, TcKind, liftedTypeKind, mkAppTy, tcSplitSigmaTy ) -import TcEnv ( spliceOK, tcMetaTy, bracketOK, tcLookup ) +import TcEnv ( spliceOK, tcMetaTy, bracketOK ) import TcMType ( newTyVarTy, newKindVar, UserTypeCtxt(ExprSigCtxt), zonkTcType, zonkTcTyVar ) import TcHsType ( tcHsSigType, kcHsType ) +import TcIface ( tcImportDecl ) import TypeRep ( Type(..), PredType(..), TyThing(..) ) -- For reification -import Name ( Name, NamedThing(..), nameOccName, nameModule, isExternalName, mkInternalName ) +import Name ( Name, NamedThing(..), nameOccName, nameModule, isExternalName, + mkInternalName, nameIsLocalOrFrom ) +import NameEnv ( lookupNameEnv ) +import HscTypes ( lookupType, ExternalPackageState(..) ) import OccName import Var ( Id, TyVar, idType ) import Module ( moduleUserString, mkModuleName ) import TcRnMonad import IfaceEnv ( lookupOrig ) - import Class ( Class, classBigSig ) import TyCon ( TyCon, tyConTheta, tyConTyVars, getSynTyConDefn, isSynTyCon, isNewTyCon, tyConDataCons ) import DataCon ( DataCon, dataConTyCon, dataConOrigArgTys, dataConStrictMarks, @@ -361,7 +364,7 @@ runMetaD :: LHsExpr Id -- Of type Q [Dec] -> TcM [TH.Dec] -- Of type [Dec] runMetaD e = runMeta e -runMeta :: LHsExpr Id -- Of type X +runMeta :: LHsExpr Id -- Of type X -> TcM t -- Of type t runMeta expr = do { hsc_env <- getTopEnv @@ -442,7 +445,7 @@ illegalSplice level reify :: TH.Name -> TcM TH.Info reify th_name = do { name <- lookupThName th_name - ; thing <- tcLookup name + ; thing <- tcLookupTh name -- ToDo: this tcLookup could fail, which would give a -- rather unhelpful error message ; reifyThing thing @@ -481,6 +484,32 @@ lookupThName (TH.Name occ (TH.NameU uniq)) bogus_ns = OccName.varName -- Not yet recorded in the TH name -- but only the unique matters +tcLookupTh :: Name -> TcM TcTyThing +-- This is a specialised version of TcEnv.tcLookup; specialised mainly in that +-- it gives a reify-related error message on failure, whereas in the normal +-- tcLookup, failure is a bug. +tcLookupTh name + = do { (gbl_env, lcl_env) <- getEnvs + ; case lookupNameEnv (tcl_env lcl_env) name of + Just thing -> returnM thing + Nothing -> do + { if nameIsLocalOrFrom (tcg_mod gbl_env) name + then -- It's defined in this module + case lookupNameEnv (tcg_type_env gbl_env) name of + Just thing -> return (AGlobal thing) + Nothing -> failWithTc (notInEnv name) + + else do -- It's imported + { (eps,hpt) <- getEpsAndHpt + ; case lookupType hpt (eps_PTE eps) name of + Just thing -> return (AGlobal thing) + Nothing -> do { traceIf (text "tcLookupGlobal" <+> ppr name) + ; thing <- initIfaceTcRn (tcImportDecl name) + ; return (AGlobal thing) } + -- Imported names should always be findable; + -- if not, we fail hard in tcImportDecl + }}} + mk_uniq :: Int# -> Unique mk_uniq u = mkUniqueGrimily (I# u) @@ -489,6 +518,10 @@ notInScope th_name = quotes (text (TH.pprint th_name)) <+> ptext SLIT("is not in scope at a reify") -- Ugh! Rather an indirect way to display the name +notInEnv :: Name -> SDoc +notInEnv name = quotes (ppr name) <+> + ptext SLIT("is not in the type environment at a reify") + ------------------------------ reifyThing :: TcTyThing -> TcM TH.Info -- The only reason this is monadic is for error reporting, -- 1.7.10.4