From 1679919a0f088d0d34967dcfef195c8afd6bc273 Mon Sep 17 00:00:00 2001
From: sof <unknown>
Date: Mon, 25 Aug 1997 22:32:16 +0000
Subject: [PATCH] [project @ 1997-08-25 22:32:16 by sof] Improved error
 messages

---
 ghc/compiler/typecheck/TcExpr.lhs |   31 +++++++++++++++----------------
 1 file changed, 15 insertions(+), 16 deletions(-)

diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs
index 73bede1..88832b1 100644
--- a/ghc/compiler/typecheck/TcExpr.lhs
+++ b/ghc/compiler/typecheck/TcExpr.lhs
@@ -344,8 +344,9 @@ tcExpr (ExplicitTuple exprs) res_ty
     where
      len = length exprs
 
-tcExpr (RecordCon (HsVar con) rbinds) res_ty
-  = tcId con				`thenNF_Tc` \ (con_expr, con_lie, con_tau) ->
+tcExpr (RecordCon con rbinds) res_ty
+  = tcLookupGlobalValue con		`thenNF_Tc` \ con_id ->
+    tcId con				`thenNF_Tc` \ (con_expr, con_lie, con_tau) ->
     let
 	(_, record_ty) = splitFunTy con_tau
     in
@@ -354,7 +355,6 @@ tcExpr (RecordCon (HsVar con) rbinds) res_ty
     unifyTauTy record_ty res_ty         `thenTc_`
 
 	-- Check that the record bindings match the constructor
-    tcLookupGlobalValue con				`thenNF_Tc` \ con_id ->
     let
 	bad_fields = badFields rbinds con_id
     in
@@ -365,7 +365,7 @@ tcExpr (RecordCon (HsVar con) rbinds) res_ty
 	--  doesn't match the constructor.)
     tcRecordBinds record_ty rbinds		`thenTc` \ (rbinds', rbinds_lie) ->
 
-    returnTc (RecordCon con_expr rbinds', con_lie `plusLIE` rbinds_lie)
+    returnTc (RecordConOut (RealId con_id) con_expr rbinds', con_lie `plusLIE` rbinds_lie)
 
 
 -- The main complication with RecordUpd is that we need to explicitly
@@ -836,7 +836,7 @@ tcStmt :: (RenamedHsExpr -> TcType s -> TcM s (TcExpr s, LIE s))	-- This is tcEx
        -> TcM s (thing, LIE s)
 
 tcStmt tc_expr do_or_lc m combine stmt@(ReturnStmt exp) do_next
-  = ASSERT( case do_or_lc of { DoStmt -> False; ListComp -> True } )
+  = ASSERT( case do_or_lc of { DoStmt -> False; ListComp -> True; Guard -> True } )
     tcSetErrCtxt (stmtCtxt do_or_lc stmt) (
         newTyVarTy mkTypeKind                `thenNF_Tc` \ exp_ty ->
 	tc_expr exp exp_ty		     `thenTc`    \ (exp', exp_lie) ->
@@ -847,7 +847,7 @@ tcStmt tc_expr do_or_lc m combine stmt@(ReturnStmt exp) do_next
   	      stmt_lie `plusLIE` thing_lie)
 
 tcStmt tc_expr do_or_lc m combine stmt@(GuardStmt exp src_loc) do_next
-  = ASSERT( case do_or_lc of { DoStmt -> False; ListComp -> True } )
+  = ASSERT( case do_or_lc of { DoStmt -> False; ListComp -> True; Guard -> True } )
     newTyVarTy mkTypeKind                    `thenNF_Tc` \ exp_ty ->
     tcAddSrcLoc src_loc 		(
     tcSetErrCtxt (stmtCtxt do_or_lc stmt) (
@@ -859,7 +859,7 @@ tcStmt tc_expr do_or_lc m combine stmt@(GuardStmt exp src_loc) do_next
   	      stmt_lie `plusLIE` thing_lie)
 
 tcStmt tc_expr do_or_lc m combine stmt@(ExprStmt exp src_loc) do_next
-  = ASSERT( case do_or_lc of { DoStmt -> True; ListComp -> False } )
+  = ASSERT( case do_or_lc of { DoStmt -> True; ListComp -> False; Guard -> False } )
     newTyVarTy mkTypeKind                    `thenNF_Tc` \ exp_ty ->
     tcAddSrcLoc src_loc 		(
     tcSetErrCtxt (stmtCtxt do_or_lc stmt)	(
@@ -1031,13 +1031,14 @@ funAppCtxt fun arg_no arg sty
 		    ppr sty fun <> text ", namely"])
 	 4 (ppr sty arg)
 
-stmtCtxt ListComp stmt sty
-  = hang (ptext SLIT("In a pattern guard/list-comprehension qualifier:")) 
-         4 (ppr sty stmt)
-
-stmtCtxt DoStmt stmt sty
-  = hang (ptext SLIT("In a do statement:")) 
+stmtCtxt do_or_lc stmt sty
+  = hang (ptext SLIT("In a") <+> whatever <> colon)
          4 (ppr sty stmt)
+  where
+    whatever = case do_or_lc of
+		 ListComp -> ptext SLIT("list-comprehension qualifier")
+		 DoStmt   -> ptext SLIT("do statement")
+		 Guard	  -> ptext SLIT("guard")
 
 tooManyArgsCtxt f sty
   = hang (ptext SLIT("Too many arguments in an application of the function"))
@@ -1049,9 +1050,7 @@ lurkingRank2Err fun fun_ty sty
 		      ptext SLIT("so that the result type has for-alls in it")])
 
 rank2ArgCtxt arg expected_arg_ty sty
-  = hang (ptext SLIT("In a polymorphic function argument:"))
-	 4 (sep [(<>) (ppr sty arg) (ptext SLIT(" ::")),
-		   ppr sty expected_arg_ty])
+  = ptext SLIT("In a polymorphic function argument") <+> ppr sty arg
 
 badFieldsUpd rbinds sty
   = hang (ptext SLIT("No constructor has all these fields:"))
-- 
1.7.10.4