From d85022e77941df072eff0a49d8659c016552a30d Mon Sep 17 00:00:00 2001
From: simonm <unknown>
Date: Tue, 14 Oct 1997 09:37:47 +0000
Subject: [PATCH] [project @ 1997-10-14 09:37:44 by simonm] Fix bug in
 typechecking locally-overloaded function arguments.

---
 ghc/compiler/typecheck/Inst.lhs   |    4 ++++
 ghc/compiler/typecheck/TcExpr.lhs |   26 +++++++++++++-------------
 2 files changed, 17 insertions(+), 13 deletions(-)

diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs
index dc65e0f..67688c0 100644
--- a/ghc/compiler/typecheck/Inst.lhs
+++ b/ghc/compiler/typecheck/Inst.lhs
@@ -608,6 +608,8 @@ data InstOrigin s
   | ArithSeqOrigin	RenamedArithSeqInfo -- [x..], [x..y] etc
 
   | SignatureOrigin		-- A dict created from a type signature
+  | Rank2Origin			-- A dict created when typechecking the argument
+				-- of a rank-2 typed function
 
   | DoOrigin			-- The monad for a do expression
 
@@ -685,6 +687,8 @@ pprOrigin sty inst
 	= hsep [ptext SLIT("the arithmetic sequence:"), ppr sty seq]
     pp_orig (SignatureOrigin)
 	=  ptext SLIT("a type signature")
+    pp_orig (Rank2Origin)
+	=  ptext SLIT("a function with an overloaded argument type")
     pp_orig (DoOrigin)
 	=  ptext SLIT("a do statement")
     pp_orig (ClassDeclOrigin)
diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs
index 1eb18f0..6f24758 100644
--- a/ghc/compiler/typecheck/TcExpr.lhs
+++ b/ghc/compiler/typecheck/TcExpr.lhs
@@ -676,7 +676,6 @@ tcPolyExpr arg expected_arg_ty
     let
 	(sig_theta, sig_tau) = splitRhoTy sig_rho
     in
-    ASSERT( null sig_theta )	-- And expected_tyvars are all DontBind things
 	
 	-- Type-check the arg and unify with expected type
     tcExpr arg sig_tau				`thenTc` \ (arg', lie_arg) ->
@@ -692,23 +691,24 @@ tcPolyExpr arg expected_arg_ty
 	-- Conclusion: include the free vars of the expected arg type in the
 	-- list of "free vars" for the signature check.
 
-    tcAddErrCtxt (rank2ArgCtxt arg expected_arg_ty) (
-	tcExtendGlobalTyVars (tyVarsOfType expected_arg_ty) (
-		checkSigTyVars sig_tyvars sig_tau
-	)						`thenTc_`
+    tcAddErrCtxt (rank2ArgCtxt arg expected_arg_ty) $
+    tcExtendGlobalTyVars (tyVarsOfType expected_arg_ty) $
 
-	    -- Check that there's no overloading involved
-	    -- Even if there isn't, there may be some Insts which mention the expected_tyvars,
-	    -- but which, on simplification, don't actually need a dictionary involving
-	    -- the tyvar.  So we have to do a proper simplification right here.
-	tcSimplifyRank2 (mkTyVarSet sig_tyvars) 
-			lie_arg				`thenTc` \ (free_insts, inst_binds) ->
+    checkSigTyVars sig_tyvars sig_tau		`thenTc_`
+    newDicts Rank2Origin sig_theta		`thenNF_Tc` \ (sig_dicts, dict_ids) ->
+	-- ToDo: better origin
+    tcSimplifyAndCheck 
+		(mkTyVarSet sig_tyvars) 	-- No need to zonk the tyvars because
+						-- they won't be bound to anything
+		sig_dicts lie_arg		`thenTc` \ (lie', inst_binds) ->
 
 	    -- This HsLet binds any Insts which came out of the simplification.
 	    -- It's a bit out of place here, but using AbsBind involves inventing
 	    -- a couple of new names which seems worse.
-	returnTc (TyLam sig_tyvars (HsLet (mk_binds inst_binds) arg'), free_insts)
-    )
+     returnTc ( TyLam sig_tyvars $
+		DictLam dict_ids $
+		HsLet (mk_binds inst_binds) arg' 
+	      , lie')
   where
     mk_binds inst_binds = MonoBind inst_binds [] nonRecursive
 \end{code}
-- 
1.7.10.4