From f59d6c9d6ead47a61681b1086b313c2fad225912 Mon Sep 17 00:00:00 2001
From: "simonpj@microsoft.com" <unknown>
Date: Fri, 22 Feb 2008 18:25:14 +0000
Subject: [PATCH] Improve error messages from type-checking data constructors

This addresses Trac #2112
---
 compiler/typecheck/TcHsType.lhs     |   14 +++++---------
 compiler/typecheck/TcRnMonad.lhs    |    2 +-
 compiler/typecheck/TcTyClsDecls.lhs |    3 ++-
 3 files changed, 8 insertions(+), 11 deletions(-)

diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs
index 00bc2ed..66102a6 100644
--- a/compiler/typecheck/TcHsType.lhs
+++ b/compiler/typecheck/TcHsType.lhs
@@ -597,9 +597,9 @@ GADT constructor signatures
 
 \begin{code}
 tcLHsConResTy :: LHsType Name -> TcM (TyCon, [TcType])
-tcLHsConResTy res_ty
-  = addErrCtxt (gadtResCtxt res_ty) $
-    case get_largs res_ty [] of
+tcLHsConResTy (L span res_ty)
+  = setSrcSpan span $
+    case get_args res_ty [] of
 	   (HsTyVar tc_name, args) 
 	      -> do { args' <- mapM dsHsType args
 		    ; thing <- tcLookup tc_name
@@ -612,15 +612,11 @@ tcLHsConResTy res_ty
 	-- because that causes a black hole, and for good reason.  Building
 	-- the type means expanding type synonyms, and we can't do that
 	-- inside the "knot".  So we have to work by steam.
-    get_largs (L _ ty) args = get_args ty args
-    get_args (HsAppTy fun arg) 		  args = get_largs fun (arg:args)
-    get_args (HsParTy ty)      		  args = get_largs ty  args
+    get_args (HsAppTy (L _ fun) arg) 	  args = get_args fun (arg:args)
+    get_args (HsParTy (L _ ty)) 	  args = get_args ty  args
     get_args (HsOpTy ty1 (L span tc) ty2) args = (HsTyVar tc, ty1:ty2:args)
     get_args ty  	     		  args = (ty, args)
 
-gadtResCtxt ty
-  = hang (ptext SLIT("In the result type of a data constructor:"))
-       2 (ppr ty)
 badGadtDecl ty
   = hang (ptext SLIT("Malformed constructor result type:"))
        2 (ppr ty)
diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs
index 11e6bba..3c6c59e 100644
--- a/compiler/typecheck/TcRnMonad.lhs
+++ b/compiler/typecheck/TcRnMonad.lhs
@@ -646,7 +646,7 @@ checkNoErrs main
   = do	{ (msgs, mb_res) <- tryTcLIE main
 	; addMessages msgs
 	; case mb_res of
-	    Nothing   -> failM
+	    Nothing  -> failM
 	    Just val -> return val
 	} 
 
diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index c1e5816..f3abbe9 100644
--- a/compiler/typecheck/TcTyClsDecls.lhs
+++ b/compiler/typecheck/TcTyClsDecls.lhs
@@ -812,7 +812,8 @@ tcConDecl :: Bool 		-- True <=> -funbox-strict_fields
 
 tcConDecl unbox_strict existential_ok tycon tc_tvs	-- Data types
 	  (ConDecl name _ tvs ctxt details res_ty _)
-  = tcTyVarBndrs tvs		$ \ tvs' -> do 
+  = addErrCtxt (dataConCtxt name)	$ 
+    tcTyVarBndrs tvs			$ \ tvs' -> do 
     { ctxt' <- tcHsKindedContext ctxt
     ; checkTc (existential_ok || (null tvs && null (unLoc ctxt)))
 	      (badExistential name)
-- 
1.7.10.4