Recover gracefully from a Template Haskell programmers error

If a TH programmer uses a type constructor as a data constructor,
GHC simply crashed.  This commit makes it report the error in a
graceful way.

diff --git a/compiler/basicTypes/RdrName.lhs b/compiler/basicTypes/RdrName.lhs
index 030aa1f..7965449 100644 (file)
--- a/compiler/basicTypes/RdrName.lhs
+++ b/compiler/basicTypes/RdrName.lhs
@@ -201,11 +201,9 @@ isExact_maybe other        = Nothing
 \begin{code}
 instance Outputable RdrName where
     ppr (Exact name)   = ppr name
-    ppr (Unqual occ)   = ppr occ <+> ppr_name_space occ
-    ppr (Qual mod occ) = ppr mod <> dot <> ppr occ <+> ppr_name_space occ
-    ppr (Orig mod occ) = ppr mod <> dot <> ppr occ <+> ppr_name_space occ
-
-ppr_name_space occ = ifPprDebug (parens (pprNonVarNameSpace (occNameSpace occ)))
+    ppr (Unqual occ)   = ppr occ
+    ppr (Qual mod occ) = ppr mod <> dot <> ppr occ
+    ppr (Orig mod occ) = ppr mod <> dot <> ppr occ
 
 instance OutputableBndr RdrName where
     pprBndr _ n 

diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs
index 497ba23..388828e 100644 (file)
--- a/compiler/typecheck/TcEnv.lhs
+++ b/compiler/typecheck/TcEnv.lhs
@@ -11,7 +11,7 @@ module TcEnv(
        tcExtendGlobalEnv, 
        tcExtendGlobalValEnv,
        tcLookupLocatedGlobal,  tcLookupGlobal, 
-       tcLookupGlobalId, tcLookupTyCon, tcLookupClass, tcLookupDataCon,
+       tcLookupField, tcLookupTyCon, tcLookupClass, tcLookupDataCon,
        tcLookupLocatedGlobalId, tcLookupLocatedTyCon,
        tcLookupLocatedClass, 
        
@@ -121,16 +121,19 @@ tcLookupGlobal name
                tcImportDecl name       -- Go find it in an interface
        }}}}}
 
-tcLookupGlobalId :: Name -> TcM Id
--- Never used for Haskell-source DataCons, hence no ADataCon case
-tcLookupGlobalId name
+tcLookupField :: Name -> TcM Id                -- Returns the selector Id
+tcLookupField name
   = tcLookupGlobal name                `thenM` \ thing ->
-    return (tyThingId thing)
+    case thing of
+       AnId id -> return id
+       other   -> wrongThingErr "field name" (AGlobal thing) name
 
 tcLookupDataCon :: Name -> TcM DataCon
-tcLookupDataCon con_name
-  = tcLookupGlobal con_name    `thenM` \ thing ->
-    return (tyThingDataCon thing)
+tcLookupDataCon name
+  = tcLookupGlobal name        `thenM` \ thing ->
+    case thing of
+       ADataCon con -> return con
+       other        -> wrongThingErr "data constructor" (AGlobal thing) name
 
 tcLookupClass :: Name -> TcM Class
 tcLookupClass name

diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs
index a044f43..36cda5a 100644 (file)
--- a/compiler/typecheck/TcExpr.lhs
+++ b/compiler/typecheck/TcExpr.lhs
@@ -32,9 +32,7 @@ import BasicTypes     ( Arity, isMarkedStrict )
 import Inst            ( newMethodFromName, newIPDict, instToId,
                          newDicts, newMethodWithGivenTy, tcInstStupidTheta )
 import TcBinds         ( tcLocalBinds )
-import TcEnv           ( tcLookup, tcLookupId,
-                         tcLookupDataCon, tcLookupGlobalId
-                       )
+import TcEnv           ( tcLookup, tcLookupId, tcLookupDataCon, tcLookupField )
 import TcArrows                ( tcProc )
 import TcMatches       ( tcMatchesCase, tcMatchLambda, tcDoStmts, TcMatchCtxt(..) )
 import TcHsType                ( tcHsSigType, UserTypeCtxt(..) )
@@ -394,7 +392,7 @@ tcExpr expr@(RecordUpd record_expr rbinds _ _) res_ty
     let 
        field_names = map fst rbinds
     in
-    mappM (tcLookupGlobalId.unLoc) field_names `thenM` \ sel_ids ->
+    mappM (tcLookupField . unLoc) field_names  `thenM` \ sel_ids ->
        -- The renamer has already checked that they
        -- are all in scope
     let