X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcClassDcl.lhs;h=3994e93952ab2bc9a97d14967ea00554e34bdd2d;hb=d68887047bcfb9021151f768fe1a22df2d3fbe1e;hp=cf01b509c11d01e3f36522d0ec494ecde39f98fc;hpb=6c936babdfb7f9c229b1d01be35728e2caf1d53d;p=ghc-hetmet.git

diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs
index cf01b50..3994e93 100644
--- a/ghc/compiler/typecheck/TcClassDcl.lhs
+++ b/ghc/compiler/typecheck/TcClassDcl.lhs
@@ -26,12 +26,12 @@ import TcHsSyn		( TcMonoBinds )
 
 import Inst		( Inst, InstOrigin(..), LIE, emptyLIE, plusLIE, plusLIEs, 
 			  instToId, newDicts, newMethod )
-import TcEnv		( TcId, TcEnv, RecTcEnv, TyThingDetails(..), tcAddImportedIdInfo,
+import TcEnv		( RecTcEnv, TyThingDetails(..), tcAddImportedIdInfo,
 			  tcLookupClass, tcExtendTyVarEnvForMeths, tcExtendGlobalTyVars,
 			  tcExtendLocalValEnv, tcExtendTyVarEnv
 			)
 import TcBinds		( tcBindWithSigs, tcSpecSigs )
-import TcMonoType	( tcHsRecType, tcRecClassContext, checkSigTyVars, checkAmbiguity, sigCtxt, mkTcSig )
+import TcMonoType	( tcHsRecType, tcRecTheta, checkSigTyVars, checkAmbiguity, sigCtxt, mkTcSig )
 import TcSimplify	( tcSimplifyCheck, bindInstsOfLocalFuns )
 import TcType		( TcType, TcTyVar, tcInstTyVars )
 import TcMonad
@@ -44,10 +44,10 @@ import DataCon		( mkDataCon, notMarkedStrict )
 import Id		( Id, idType, idName )
 import Module		( Module )
 import Name		( Name, NamedThing(..) )
-import Name		( NameEnv, lookupNameEnv, emptyNameEnv, unitNameEnv, plusNameEnv, nameEnvElts )
+import NameEnv		( NameEnv, lookupNameEnv, emptyNameEnv, unitNameEnv, plusNameEnv, nameEnvElts )
 import NameSet		( emptyNameSet )
 import Outputable
-import Type		( Type, ClassContext, mkTyVarTys, mkDictTys, mkClassPred,
+import Type		( Type, ThetaType, mkTyVarTys, mkPredTys, mkClassPred,
 			  splitTyConApp_maybe, isTyVarTy
 			)
 import Var		( TyVar )
@@ -148,7 +148,7 @@ tcClassDecl1 is_rec rec_env
 	-- MAKE THE CLASS DETAILS
     let
 	(op_tys, op_items) = unzip sig_stuff
-        sc_tys		   = mkDictTys sc_theta
+        sc_tys		   = mkPredTys sc_theta
 	dict_component_tys = sc_tys ++ op_tys
 
         dict_con = mkDataCon datacon_name
@@ -219,23 +219,20 @@ checkGenericClassIsUnary clas dm_env
 tcSuperClasses :: RecFlag -> Bool -> Class
 	       -> RenamedContext 	-- class context
 	       -> [Name]		-- Names for superclass selectors
-	       -> TcM (ClassContext,	-- the superclass context
-		         [Id])  	-- superclass selector Ids
+	       -> TcM (ThetaType,	-- the superclass context
+		       [Id])		-- superclass selector Ids
 
 tcSuperClasses is_rec gla_exts clas context sc_sel_names
-  = 	-- Check the context.
+  = ASSERT( length context == length sc_sel_names )
+	-- Check the context.
 	-- The renamer has already checked that the context mentions
 	-- only the type variable of the class decl.
 
 	-- For std Haskell check that the context constrains only tyvars
-    (if gla_exts then
-	returnTc ()
-     else
-	mapTc_ check_constraint context
-    )						`thenTc_`
+    mapTc_ check_constraint context			`thenTc_`
 
 	-- Context is already kind-checked
-    tcRecClassContext is_rec context		`thenTc` \ sc_theta ->
+    tcRecTheta is_rec context		`thenTc` \ sc_theta ->
     let
        sc_sel_ids = [mkDictSelId sc_name clas | sc_name <- sc_sel_names]
     in
@@ -243,8 +240,10 @@ tcSuperClasses is_rec gla_exts clas context sc_sel_names
     returnTc (sc_theta, sc_sel_ids)
 
   where
-    check_constraint sc@(HsPClass c tys) 
-	= checkTc (all is_tyvar tys) (superClassErr clas sc)
+    check_constraint sc = checkTc (ok sc) (superClassErr clas sc)
+    ok (HsClassP c tys) | gla_exts  = True
+			| otherwise = all is_tyvar tys 
+    ok (HsIParam _ _)  = False		-- Never legal
 
     is_tyvar (HsTyVar _) = True
     is_tyvar other	 = False
@@ -287,11 +286,11 @@ tcClassSig is_rec unf_env clas clas_tyvars maybe_dm_env
     let
 	-- Build the selector id and default method id
 	sel_id = mkDictSelId op_name clas
- 	dm_id  = mkDefaultMethodId dm_name clas global_ty
+ 	dm_id  = mkDefaultMethodId dm_name global_ty
 	DefMeth dm_name = sig_dm
 
 	dm_info = case maybe_dm_env of
-		    Nothing      -> iface_dm_info
+		    Nothing     -> iface_dm_info
 		    Just dm_env -> mk_src_dm_info dm_env
 
 	iface_dm_info = case sig_dm of