From 210cba682cd91e166d902cef85003176caacf5d1 Mon Sep 17 00:00:00 2001
From: simonpj <unknown>
Date: Mon, 2 Sep 2002 16:37:13 +0000
Subject: [PATCH] [project @ 2002-09-02 16:37:13 by simonpj] Fix an obscure
 bug in the creation of default methods for class ops with
 higher-rank type.   See the comments with 	
 TcClassDcl.mkDefMethRhs

Test is should_compile/tc161

		MERGE TO STABLE
---
 ghc/compiler/typecheck/TcClassDcl.lhs |   30 +++++++++++++++++++++++++-----
 1 file changed, 25 insertions(+), 5 deletions(-)

diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs
index 79c834d..2d70894 100644
--- a/ghc/compiler/typecheck/TcClassDcl.lhs
+++ b/ghc/compiler/typecheck/TcClassDcl.lhs
@@ -11,9 +11,9 @@ module TcClassDcl ( tcClassDecl1, tcClassDecls2,
 #include "HsVersions.h"
 
 import HsSyn		( TyClDecl(..), Sig(..), MonoBinds(..),
-			  HsExpr(..), HsLit(..), 
+			  HsExpr(..), HsLit(..), InPat(WildPatIn),
 			  mkSimpleMatch, andMonoBinds, andMonoBindList, 
-			  isClassOpSig, isPragSig,
+			  isClassOpSig, isPragSig, 
 			  getClassDeclSysNames, placeHolderType
 			)
 import BasicTypes	( RecFlag(..), StrictnessMark(..) )
@@ -35,7 +35,7 @@ import TcSimplify	( tcSimplifyCheck )
 import TcUnify		( checkSigTyVars, sigCtxt )
 import TcMType		( tcInstTyVars )
 import TcType		( Type, TyVarDetails(..), TcType, TcThetaType, TcTyVar, 
-			  mkTyVarTys, mkPredTys, mkClassPred, 
+			  mkTyVarTys, mkPredTys, mkClassPred, tcSplitSigmaTy, tcSplitFunTys,
 			  tcIsTyVarTy, tcSplitTyConApp_maybe
 			)
 import TcMonad
@@ -528,10 +528,30 @@ mkDefMethRhs origin clas inst_tys sel_id loc NoDefMeth
    	   (omittedMethodWarn sel_id)		`thenNF_Tc_`
     returnTc error_rhs
   where
-    error_rhs = HsApp (HsVar (getName nO_METHOD_BINDING_ERROR_ID)) 
-	    	      (HsLit (HsStringPrim (mkFastString (stringToUtf8 error_msg))))
+    error_rhs  = HsLam (mkSimpleMatch wild_pats simple_rhs placeHolderType loc)
+    simple_rhs = HsApp (HsVar (getName nO_METHOD_BINDING_ERROR_ID)) 
+	    	       (HsLit (HsStringPrim (mkFastString (stringToUtf8 error_msg))))
     error_msg = showSDoc (hcat [ppr loc, text "|", ppr sel_id ])
 
+	-- When the type is of form t1 -> t2 -> t3
+	-- make a default method like (\ _ _ -> noMethBind "blah")
+	-- rather than simply        (noMethBind "blah")
+	-- Reason: if t1 or t2 are higher-ranked types we get n
+	--	   silly ambiguity messages.
+	-- Example:	f :: (forall a. Eq a => a -> a) -> Int
+	--		f = error "urk"
+	-- Here, tcSub tries to force (error "urk") to have the right type,
+	-- thus:	f = \(x::forall a. Eq a => a->a) -> error "urk" (x t)
+	-- where 't' is fresh ty var.  This leads directly to "ambiguous t".
+	-- 
+	-- NB: technically this changes the meaning of the default-default
+	--     method slightly, because `seq` can see the lambdas.  Oh well.
+    (_,_,tau1)    = tcSplitSigmaTy (idType sel_id)
+    (_,_,tau2)    = tcSplitSigmaTy tau1
+	-- Need two splits because the  selector can have a type like
+	-- 	forall a. Foo a => forall b. Eq b => ...
+    (arg_tys, _) = tcSplitFunTys tau2
+    wild_pats	 = [WildPatIn | ty <- arg_tys]
 
 mkDefMethRhs origin clas inst_tys sel_id loc GenDefMeth 
   =  	-- A generic default method
-- 
1.7.10.4