[project @ 2000-10-30 09:52:14 by simonpj]

[ghc-hetmet.git] / ghc / compiler / typecheck / TcClassDcl.lhs

diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs
index 1b1a7b0..3154f84 100644 (file)
--- 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                                          $