X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcClassDcl.lhs;h=00c1087e27f47f37aba2be2c651390322f32fd21;hb=d0f325ce37d6ee322168e44392f10e0ed52f8294;hp=6cc6a7a811e346036e043b869a2321e8c259a77f;hpb=8b935dd5c2679476b47543c48b5a65ec11b6ba24;p=ghc-hetmet.git

diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs
index 6cc6a7a..00c1087e 100644
--- a/ghc/compiler/typecheck/TcClassDcl.lhs
+++ b/ghc/compiler/typecheck/TcClassDcl.lhs
@@ -40,7 +40,7 @@ import MkId		( mkDataCon, mkSuperDictSelId,
 			  mkMethodSelId, mkDefaultMethodId
 			)
 import Id		( Id, StrictnessMark(..),
-			  getIdUnfolding, idType
+			  getIdUnfolding, idType, idName
 			)
 import CoreUnfold	( getUnfoldingTemplate )
 import IdInfo
@@ -404,28 +404,27 @@ tcDefaultMethodBinds clas default_binds
 
 	-- Typecheck the default bindings
     let
-	tc_dm meth_bind
-	  | not (maybeToBool maybe_stuff)
-	  =	-- Binding for something that isn't in the class signature
-	    failWithTc (badMethodErr bndr_name clas)
-
-	  | otherwise
-	  =	-- Normal case
-	    tcMethodBind clas origin inst_tys clas_tyvars sel_id meth_bind [{- No prags -}]
+	tc_dm meth_bind 
+ 	  = case [pair | pair@(sel_id,_) <- sel_ids_w_dms,
+		  	 idName sel_id == bndr_name] of
+
+		[] -> 	-- Binding for something that isn't in the class signature
+		       failWithTc (badMethodErr bndr_name clas)
+	
+		((sel_id, Just dm_id):_) ->
+			-- We're looking at a default-method binding, so the dm_id
+			-- is sure to be there!  Hence the inner "Just".
+			-- Normal case
+
+			tcMethodBind clas origin inst_tys clas_tyvars
+				     sel_id meth_bind [{- No prags -}]
 						`thenTc` \ (bind, insts, (_, local_dm_id)) ->
-	    returnTc (bind, insts, (clas_tyvars, RealId dm_id, local_dm_id))
+			returnTc (bind, insts, (clas_tyvars, RealId dm_id, local_dm_id))
 	  where
 	    bndr_name  = case meth_bind of
 				FunMonoBind name _ _ _		-> name
 				PatMonoBind (VarPatIn name) _ _ -> name
 				
-	    maybe_stuff = assocMaybe assoc_list (nameOccName bndr_name)
-	    assoc_list  = [ (getOccName sel_id, pair) 
-			  | pair@(sel_id, dm_ie) <- op_sel_ids `zip` defm_ids
-			  ]
-	    Just (sel_id, Just dm_id) = maybe_stuff
-		 -- We're looking at a default-method binding, so the dm_id
-		 -- is sure to be there!  Hence the inner "Just".
     in	   
     mapAndUnzip3Tc tc_dm 
 	(flatten default_binds [])		`thenTc` \ (defm_binds, insts_needed, abs_bind_stuff) ->
@@ -454,6 +453,7 @@ tcDefaultMethodBinds clas default_binds
 
   where
     (tyvars, sc_theta, sc_sel_ids, op_sel_ids, defm_ids) = classBigSig clas
+    sel_ids_w_dms =  op_sel_ids `zip` defm_ids
     origin = ClassDeclOrigin
 
     flatten EmptyMonoBinds rest	      = rest
@@ -481,19 +481,25 @@ tcMethodBind
 
 tcMethodBind clas origin inst_tys inst_tyvars sel_id meth_bind prags
  = tcAddSrcLoc src_loc	 		        $
-   newMethod origin (RealId sel_id) inst_tys	`thenNF_Tc` \ meth@(_, TcId local_meth_id) ->
-   tcInstSigTcType (idType local_meth_id)	`thenNF_Tc` \ (tyvars', rho_ty') ->
+   newMethod origin (RealId sel_id) inst_tys	`thenNF_Tc` \ meth@(_, TcId meth_id) ->
+   tcInstSigTcType (idType meth_id)	`thenNF_Tc` \ (tyvars', rho_ty') ->
    let
 	(theta', tau')  = splitRhoTy rho_ty'
-	sig_info        = TySigInfo bndr_name local_meth_id tyvars' theta' tau' src_loc
+	sig_info        = TySigInfo meth_name meth_id tyvars' theta' tau' src_loc
+	meth_name	= idName meth_id
+	meth_bind'	= case meth_bind of
+			    FunMonoBind _ fix matches loc    -> FunMonoBind meth_name fix matches loc
+			    PatMonoBind (VarPatIn _) rhs loc -> PatMonoBind (VarPatIn meth_name) rhs loc
+		-- The renamer just puts the selector ID as the binder in the method binding
+		-- but we must use the method name; so we substitute it here.  Crude but simple.
    in
-   tcExtendLocalValEnv [bndr_name] [local_meth_id] (
+   tcExtendLocalValEnv [meth_name] [meth_id] (
 	tcPragmaSigs prags
    )						`thenTc` \ (prag_info_fn, prag_binds, prag_lie) ->
 
    tcExtendGlobalTyVars inst_tyvars (
      tcAddErrCtxt (methodCtxt sel_id)		$
-     tcBindWithSigs NotTopLevel [bndr_name] meth_bind [sig_info]
+     tcBindWithSigs NotTopLevel [meth_name] meth_bind' [sig_info]
 		    NonRecursive prag_info_fn 	
    )							`thenTc` \ (binds, insts, _) ->
 
@@ -502,16 +508,16 @@ tcMethodBind clas origin inst_tys inst_tyvars sel_id meth_bind prags
 	-- have not been unified with anything in the environment
    tcAddErrCtxt (monoCtxt sel_id) (
      tcAddErrCtxt (sigCtxt sel_id) $
-     checkSigTyVars inst_tyvars (idType local_meth_id)
+     checkSigTyVars inst_tyvars (idType meth_id)
    )							`thenTc_` 
 
    returnTc (binds `AndMonoBinds` prag_binds, 
 	     insts `plusLIE` prag_lie, 
 	     meth)
  where
-   (bndr_name, src_loc) = case meth_bind of
-				FunMonoBind name _ _ loc	  -> (name, loc)
-				PatMonoBind (VarPatIn name) _ loc -> (name, loc)
+   src_loc = case meth_bind of
+		FunMonoBind name _ _ loc	  -> loc
+		PatMonoBind (VarPatIn name) _ loc -> loc
 \end{code}
 
 Contexts and errors