[commit: ghc] ghc-generics: Adapt mkGenericDefMethBind to the new generics (83f16ad)

[Simon Peyton Jones]

Repository : ssh://darcs.haskell.org//srv/darcs/ghc

On branch  : ghc-generics

http://hackage.haskell.org/trac/ghc/changeset/83f16ade9edf272c88c6b2ed8b8e951b905fe130

>---------------------------------------------------------------

commit 83f16ade9edf272c88c6b2ed8b8e951b905fe130
Author: simonpj <simonpj at cam-04-unx.europe.corp.microsoft.com>
Date:   Tue Apr 12 18:02:08 2011 +0100

    Adapt mkGenericDefMethBind to the new generics

>---------------------------------------------------------------

 compiler/typecheck/TcClassDcl.lhs |   36 +++++++-----------------------------
 compiler/typecheck/TcInstDcls.lhs |    5 +++--
 2 files changed, 10 insertions(+), 31 deletions(-)

diff --git a/compiler/typecheck/TcClassDcl.lhs b/compiler/typecheck/TcClassDcl.lhs
index 62a3da8..36bef11 100644
--- a/compiler/typecheck/TcClassDcl.lhs
+++ b/compiler/typecheck/TcClassDcl.lhs
@@ -361,42 +361,20 @@ gives rise to the instance declarations
 	  op Unit      = ...
 
 \begin{code}
-mkGenericDefMethBind :: Class -> [Type] -> Id -> TcM (LHsBind Name)
-mkGenericDefMethBind clas inst_tys sel_id
+mkGenericDefMethBind :: Class -> [Type] -> Id -> Name -> TcM (LHsBind Name)
+mkGenericDefMethBind clas inst_tys sel_id dm_name
   = 	-- A generic default method
-    	-- If the method is defined generically, we can only do the job if the
-	-- instance declaration is for a single-parameter type class with
-	-- a type constructor applied to type arguments in the instance decl
-	-- 	(checkTc, so False provokes the error)
-    do	{ checkTc (isJust maybe_tycon)
-	 	  (badGenericInstance sel_id (notSimple inst_tys))
-	; checkTc (tyConHasGenerics tycon)
-	   	  (badGenericInstance sel_id (notGeneric tycon))
-
-	; dflags <- getDOpts
+    	-- If the method is defined generically, we only have to call the
+        -- dm_name.
+    do	{ dflags <- getDOpts
 	; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Filling in method body"
 		   (vcat [ppr clas <+> ppr inst_tys,
 			  nest 2 (ppr sel_id <+> equals <+> ppr rhs)]))
 
-		-- Rename it before returning it
-	; (rn_rhs, _) <- rnLExpr rhs
         ; return (noLoc $ mkFunBind (noLoc (idName sel_id))
-                                    [mkSimpleMatch [] rn_rhs]) }
+                                    [mkSimpleMatch [] rhs]) }
   where
-    rhs = mkGenericRhs sel_id clas_tyvar tycon
-
-	  -- The tycon is only used in the generic case, and in that
-	  -- case we require that the instance decl is for a single-parameter
-	  -- type class with type variable arguments:
-	  --	instance (...) => C (T a b)
-    clas_tyvar  = ASSERT (not (null (classTyVars clas))) head (classTyVars clas)
-    Just tycon	= maybe_tycon
-    maybe_tycon = case inst_tys of 
-			[ty] -> case tcSplitTyConApp_maybe ty of
-				  Just (tycon, arg_tys) | all tcIsTyVarTy arg_tys -> Just tycon
-				  _    						  -> Nothing
-			_ -> Nothing
-
+    rhs = nlHsVar dm_name
 
 ---------------------------
 getGenericInstances :: [LTyClDecl Name] -> TcM [InstInfo Name] 
diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs
index 0ffc466..68b9106 100644
--- a/compiler/typecheck/TcInstDcls.lhs
+++ b/compiler/typecheck/TcInstDcls.lhs
@@ -924,8 +924,9 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
     ----------------------
     tc_default :: Id -> DefMeth -> TcM (TcId, LHsBind Id)
 
-    -- JPM: This is probably not that simple...
-    tc_default sel_id (GenDefMeth dm_name) = tc_default sel_id (DefMeth dm_name)
+    tc_default sel_id (GenDefMeth dm_name)
+      = do { meth_bind <- mkGenericDefMethBind clas inst_tys sel_id dm_name
+           ; tc_body sel_id False {- Not generated code? -} meth_bind }
 {-
     tc_default sel_id GenDefMeth    -- Derivable type classes stuff
       = do { meth_bind <- mkGenericDefMethBind clas inst_tys sel_id