From: sof <unknown>
Date: Mon, 10 May 1999 17:54:00 +0000 (+0000)
Subject: [project @ 1999-05-10 17:53:59 by sof]
X-Git-Tag: Approximately_9120_patches~6233
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=88bab0e77f9b1b913bb2c4072ab83ca706315c16;p=ghc-hetmet.git

[project @ 1999-05-10 17:53:59 by sof]
Assuming that the TC sometime in the future will want to start looking
at infix decls (right, Simon?), the renamer currently passes them on
rather than filter.

Couple of TC tweaks to have it non-burpingly handle such FixSigs
inside class decls.
---

diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs
index 9943242..e3289b3 100644
--- a/ghc/compiler/typecheck/TcClassDcl.lhs
+++ b/ghc/compiler/typecheck/TcClassDcl.lhs
@@ -12,7 +12,7 @@ import HsSyn		( HsDecl(..), TyClDecl(..), Sig(..), MonoBinds(..),
 			  InPat(..), HsBinds(..), GRHSs(..),
 			  HsExpr(..), HsLit(..), HsType(..), pprClassAssertion,
 			  unguardedRHS, andMonoBinds, andMonoBindList, getTyVarName,
-			  isClassDecl
+			  isClassDecl, isClassOpSig
 			)
 import HsPragmas	( ClassPragmas(..) )
 import BasicTypes	( NewOrData(..), TopLevelFlag(..), RecFlag(..), StrictnessMark(..) )
@@ -125,10 +125,12 @@ kcClassDecl (ClassDecl	context class_name
 	-- The net effect is to mutate the class kind
     tcExtendTopTyVarScope kind tyvar_names	$ \ _ _ ->
     tcContext context				`thenTc_`
-    mapTc kc_sig class_sigs			`thenTc_`
+    mapTc kc_sig the_class_sigs			`thenTc_`
 
     returnTc ()
   where
+    the_class_sigs = filter isClassOpSig class_sigs
+  
     kc_sig (ClassOpSig _ _ op_ty loc) = tcAddSrcLoc loc (tcHsType op_ty)
 \end{code}
 
@@ -156,7 +158,8 @@ tcClassDecl1 rec_env rec_inst_mapper
 --  traceTc (text "tcClassCtxt done" <+> ppr class_name)	`thenTc_`
 
 	-- CHECK THE CLASS SIGNATURES,
-    mapTc (tcClassSig rec_env rec_class tyvars) class_sigs
+    mapTc (tcClassSig rec_env rec_class tyvars) 
+	  (filter isClassOpSig class_sigs)
 						`thenTc` \ sig_stuff ->
 
 	-- MAKE THE CLASS OBJECT ITSELF
diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs
index 995d0a1..e4ad273 100644
--- a/ghc/compiler/typecheck/TcTyClsDecls.lhs
+++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs
@@ -325,10 +325,11 @@ get_tys tys
 
 ----------------------------------------------------
 get_sigs sigs
-  = unionManyUniqSets (map get_sig sigs)
+  = unionManyUniqSets (mapMaybe get_sig sigs)
   where 
-    get_sig (ClassOpSig _ _ ty _) = get_ty ty
-    get_sig other = panic "TcTyClsDecls:get_sig"
+    get_sig (ClassOpSig _ _ ty _) = Just (get_ty ty)
+    get_sig (FixSig _)		  = Nothing
+    get_sig other		  = panic "TcTyClsDecls:get_sig"
 
 ----------------------------------------------------
 set_name name = unitUniqSet (getUnique name)