X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcClassDcl.lhs;h=3154f84f7281dc48f1b5cdd1c8c19df184c50de4;hb=2ecf1c9f639dc75f1078e88c2e551116923f742a;hp=1b1a7b0177211d9100af702749547b8a83ef0e6f;hpb=6c1d2ec4f8f08d77e39de6f79afa4143110901fa;p=ghc-hetmet.git

diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs
index 1b1a7b0..3154f84 100644
--- a/ghc/compiler/typecheck/TcClassDcl.lhs
+++ b/ghc/compiler/typecheck/TcClassDcl.lhs
@@ -11,10 +11,10 @@ module TcClassDcl ( tcClassDecl1, tcClassDecls2, mkImplicitClassBinds,
 #include "HsVersions.h"
 
 import HsSyn		( HsDecl(..), TyClDecl(..), Sig(..), MonoBinds(..),
-			  HsExpr(..), HsLit(..), HsType(..), HsPred(..),
+			  HsExpr(..), HsLit(..), HsType(..), HsPred(..), 
 			  mkSimpleMatch, andMonoBinds, andMonoBindList, 
 			  isClassDecl, isClassOpSig, isPragSig,
-			  fromClassDeclNameList, tyClDeclName
+			  getClassDeclSysNames, tyClDeclName
 			)
 import BasicTypes	( TopLevelFlag(..), RecFlag(..) )
 import RnHsSyn		( RenamedTyClDecl, 
@@ -31,14 +31,14 @@ import TcEnv		( TcId, TcEnv, TyThingDetails(..), tcAddImportedIdInfo,
 			  tcExtendLocalValEnv, tcExtendTyVarEnv, newDefaultMethodName
 			)
 import TcBinds		( tcBindWithSigs, tcSpecSigs )
-import TcMonoType	( tcHsSigType, tcClassContext, checkSigTyVars, sigCtxt, mkTcSig )
+import TcMonoType	( tcHsSigType, tcClassContext, checkSigTyVars, checkAmbiguity, sigCtxt, mkTcSig )
 import TcSimplify	( tcSimplifyAndCheck, bindInstsOfLocalFuns )
 import TcType		( TcType, TcTyVar, tcInstTyVars, zonkTcSigTyVars )
 import TcMonad
 import Generics		( mkGenericRhs, validGenericMethodType )
 import PrelInfo		( nO_METHOD_BINDING_ERROR_ID )
-import Class		( classTyVars, classBigSig, classSelIds, classTyCon, 
-			  Class, ClassOpItem, DefMeth (..) )
+import Class		( classTyVars, classBigSig, classSelIds, classTyCon, classTvsFds,
+			  Class, ClassOpItem, DefMeth (..), FunDep )
 import MkId		( mkDictSelId, mkDataConId, mkDataConWrapId, mkDefaultMethodId )
 import DataCon		( mkDataCon, notMarkedStrict )
 import Id		( Id, idType, idName )
@@ -47,7 +47,7 @@ import Name		( Name, isLocallyDefined, NamedThing(..),
 			  plusNameEnv, nameEnvElts )
 import NameSet		( emptyNameSet )
 import Outputable
-import Type		( Type, ClassContext, mkTyVarTys, mkDictTys, mkSigmaTy, mkClassPred,
+import Type		( Type, ClassContext, mkTyVarTys, mkDictTys, mkClassPred,
 			  splitTyConApp_maybe, isTyVarTy
 			)
 import Var		( TyVar )
@@ -103,7 +103,7 @@ Death to "ExpandingDicts".
 tcClassDecl1 :: TcEnv -> RenamedTyClDecl -> TcM (Name, TyThingDetails)
 tcClassDecl1 rec_env
       	     (ClassDecl context class_name
-			tyvar_names fundeps class_sigs def_methods pragmas 
+			tyvar_names fundeps class_sigs def_methods
 			sys_names src_loc)
   = 	-- CHECK ARITY 1 FOR HASKELL 1.4
     doptsTc Opt_GlasgowExts				`thenTc` \ glaExts ->
@@ -113,10 +113,10 @@ tcClassDecl1 rec_env
 	-- LOOK THINGS UP IN THE ENVIRONMENT
     tcLookupClass class_name				`thenTc` \ clas ->
     let
-	tyvars   = classTyVars clas
+	(tyvars, fds) = classTvsFds clas
 	op_sigs  = filter isClassOpSig class_sigs
 	op_names = [n | ClassOpSig n _ _ _ <- op_sigs]
-	(_, datacon_name, datacon_wkr_name, sc_sel_names) = fromClassDeclNameList sys_names
+	(_, datacon_name, datacon_wkr_name, sc_sel_names) = getClassDeclSysNames sys_names
     in
     tcExtendTyVarEnv tyvars				$ 
 
@@ -128,7 +128,8 @@ tcClassDecl1 rec_env
     tcSuperClasses clas context sc_sel_names	`thenTc` \ (sc_theta, sc_sel_ids) ->
 
 	-- CHECK THE CLASS SIGNATURES,
-    mapTc (tcClassSig rec_env clas tyvars dm_info) op_sigs	`thenTc` \ sig_stuff ->
+    mapTc (tcClassSig rec_env clas tyvars fds dm_info) 
+	  op_sigs				`thenTc` \ sig_stuff ->
 
 	-- MAKE THE CLASS DETAILS
     let
@@ -238,6 +239,7 @@ tcSuperClasses clas context sc_sel_names
 tcClassSig :: TcEnv			-- Knot tying only!
 	   -> Class	    		-- ...ditto...
 	   -> [TyVar]		 	-- The class type variable, used for error check only
+	   -> [FunDep TyVar]
 	   -> NameEnv (DefMeth Name)	-- Info about default methods
 	   -> RenamedClassOpSig
 	   -> TcM (Type,		-- Type of the method
@@ -248,21 +250,21 @@ tcClassSig :: TcEnv			-- Knot tying only!
 -- so we distinguish them in checkDefaultBinds, and pass this knowledge in the
 -- Class.DefMeth data structure. 
 
-tcClassSig rec_env clas clas_tyvars dm_info
+tcClassSig rec_env clas clas_tyvars fds dm_info
 	   (ClassOpSig op_name maybe_dm op_ty src_loc)
   = tcAddSrcLoc src_loc $
 
 	-- Check the type signature.  NB that the envt *already has*
 	-- bindings for the type variables; see comments in TcTyAndClassDcls.
 
-    -- NB: Renamer checks that the class type variable is mentioned in local_ty,
-    -- and that it is not constrained by theta
     tcHsSigType op_ty				`thenTc` \ local_ty ->
     let
-	global_ty   = mkSigmaTy clas_tyvars 
-			        [mkClassPred clas (mkTyVarTys clas_tyvars)]
-			        local_ty
+	theta = [mkClassPred clas (mkTyVarTys clas_tyvars)]
+    in
+	-- Check for ambiguous class op types
+    checkAmbiguity True clas_tyvars theta local_ty	 `thenTc` \ global_ty ->
 
+    let
 	-- Build the selector id and default method id
 	sel_id      = mkDictSelId op_name clas
 
@@ -400,7 +402,7 @@ tcClassDecl2 :: RenamedTyClDecl		-- The class declaration
 	     -> NF_TcM (LIE, TcMonoBinds)
 
 tcClassDecl2 (ClassDecl context class_name
-			tyvar_names _ sigs default_binds pragmas _ src_loc)
+			tyvar_names _ sigs default_binds _ src_loc)
   = 	-- A locally defined class
     recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyMonoBinds)) $ 
     tcAddSrcLoc src_loc		     		          $