[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.

diff --git a/ghc/compiler/iface/IfaceEnv.lhs b/ghc/compiler/iface/IfaceEnv.lhs
index e987637..5cfc903 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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,