From 658e99a85870d02c734d78e488e963da107133ff Mon Sep 17 00:00:00 2001
From: "simonpj@microsoft.com" <unknown>
Date: Fri, 14 Apr 2006 11:58:31 +0000
Subject: [PATCH] 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.
---
 compiler/basicTypes/RdrName.lhs |    8 +++-----
 compiler/typecheck/TcEnv.lhs    |   19 +++++++++++--------
 compiler/typecheck/TcExpr.lhs   |    6 ++----
 3 files changed, 16 insertions(+), 17 deletions(-)

diff --git a/compiler/basicTypes/RdrName.lhs b/compiler/basicTypes/RdrName.lhs
index 030aa1f..7965449 100644
--- 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
--- 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
--- 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
-- 
1.7.10.4