From ce82461fe2c76eb0df07e1f55d743f5d5afcec07 Mon Sep 17 00:00:00 2001
From: simonm <unknown>
Date: Fri, 3 Oct 1997 12:33:26 +0000
Subject: [PATCH] [project @ 1997-10-03 12:33:26 by simonm] reinstate better
 error messages for function arguments

---
 ghc/compiler/typecheck/TcExpr.lhs |   34 +++++++++++++++++++++-------------
 1 file changed, 21 insertions(+), 13 deletions(-)

diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs
index 542ff8d..1eb18f0 100644
--- a/ghc/compiler/typecheck/TcExpr.lhs
+++ b/ghc/compiler/typecheck/TcExpr.lhs
@@ -608,22 +608,23 @@ tcApp :: RenamedHsExpr -> [RenamedHsExpr]   -- Function and args
 
 tcApp fun args res_ty
   = 	-- First type-check the function
-    tcExpr_id fun  			`thenTc` \ (fun', lie_fun, fun_ty) ->
+    tcExpr_id fun  				`thenTc` \ (fun', lie_fun, fun_ty) ->
 
     tcAddErrCtxt (tooManyArgsCtxt fun) (
 	split_fun_ty fun_ty (length args)
-    )							`thenTc` \ (expected_arg_tys, actual_result_ty) ->
+    )						`thenTc` \ (expected_arg_tys, actual_result_ty) ->
 
 	-- Unify with expected result before type-checking the args
-    unifyTauTy res_ty actual_result_ty			`thenTc_`
+    unifyTauTy res_ty actual_result_ty		`thenTc_`
 
 	-- Now typecheck the args
-    mapAndUnzipTc tcArg (zipEqual "tcApp" args expected_arg_tys)	`thenTc` \ (args', lie_args_s) ->
+    mapAndUnzipTc (tcArg fun)
+	  (zip3 args expected_arg_tys [1..])	`thenTc` \ (args', lie_args_s) ->
 
     -- Check that the result type doesn't have any nested for-alls.
     -- For example, a "build" on its own is no good; it must be applied to something.
     checkTc (isTauTy actual_result_ty)
-	    (lurkingRank2Err fun fun_ty) `thenTc_`
+	    (lurkingRank2Err fun fun_ty)	`thenTc_`
 
     returnTc (fun', args', lie_fun `plusLIE` plusLIEs lie_args_s)
 
@@ -644,10 +645,17 @@ split_fun_ty fun_ty n
 \end{code}
 
 \begin{code}
-tcArg :: (RenamedHsExpr, TcType s)	-- Actual argument and expected arg type
+tcArg :: RenamedHsExpr			-- The function (for error messages)
+      -> (RenamedHsExpr, TcType s, Int)	-- Actual argument and expected arg type
       -> TcM s (TcExpr s, LIE s)	-- Resulting argument and LIE
+tcArg the_fun (arg, expected_arg_ty, arg_no)
+  = tcAddErrCtxt (funAppCtxt the_fun arg arg_no) $
+    tcPolyExpr arg expected_arg_ty
 
-tcArg (arg,expected_arg_ty)
+
+-- tcPolyExpr is like tcExpr, except that the expected type
+-- can be a polymorphic one.
+tcPolyExpr arg expected_arg_ty
   | not (maybeToBool (getForAllTy_maybe expected_arg_ty))
   = 	-- The ordinary, non-rank-2 polymorphic case
     tcExpr arg expected_arg_ty
@@ -947,7 +955,7 @@ tcRecordBinds expected_record_ty rbinds
 	  Just (record_ty, field_ty) = getFunTy_maybe tau
 	in
 	unifyTauTy expected_record_ty record_ty		`thenTc_`
-	tcArg (rhs, field_ty)				`thenTc` \ (rhs', lie) ->
+	tcPolyExpr rhs field_ty				`thenTc` \ (rhs', lie) ->
 	returnTc ((RealId sel_id, rhs', pun_flag), lie)
 
 badFields rbinds data_con
@@ -1015,11 +1023,6 @@ sectionRAppCtxt expr sty
 sectionLAppCtxt expr sty
   = hang (ptext SLIT("In the left section")) 4 (ppr sty expr)
 
-funAppCtxt fun arg_no arg sty
-  = hang (hsep [ ptext SLIT("In the"), speakNth arg_no, ptext SLIT("argument of"), 
-		    ppr sty fun <> text ", namely"])
-	 4 (ppr sty arg)
-
 stmtCtxt do_or_lc stmt sty
   = hang (ptext SLIT("In a") <+> whatever <> colon)
          4 (ppr sty stmt)
@@ -1033,6 +1036,11 @@ tooManyArgsCtxt f sty
   = hang (ptext SLIT("Too many arguments in an application of the function"))
 	 4 (ppr sty f)
 
+funAppCtxt fun arg arg_no sty
+  = hang (hsep [ptext SLIT("In the"), speakNth arg_no, ptext SLIT("argument of"), 
+		ppr sty fun <> text ", namely"])
+	 4 (ppr sty arg)
+
 lurkingRank2Err fun fun_ty sty
   = hang (hsep [ptext SLIT("Illegal use of"), ppr sty fun])
 	 4 (vcat [text "It is applied to too few arguments,", 
-- 
1.7.10.4