[project @ 2000-02-09 18:32:09 by lewie]

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

diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs
index 6c0568c..bd07d22 100644 (file)
--- a/ghc/compiler/typecheck/TcClassDcl.lhs
+++ b/ghc/compiler/typecheck/TcClassDcl.lhs
@@ -12,8 +12,9 @@ module TcClassDcl ( kcClassDecl, tcClassDecl1, tcClassDecls2,
 
 import HsSyn           ( HsDecl(..), TyClDecl(..), Sig(..), MonoBinds(..),
                          InPat(..), HsBinds(..), GRHSs(..),
-                         HsExpr(..), HsLit(..), HsType(..), pprClassAssertion,
-                         unguardedRHS, andMonoBinds, andMonoBindList, getTyVarName,
+                         HsExpr(..), HsLit(..), HsType(..), HsPred(..),
+                         pprHsClassAssertion, unguardedRHS,
+                         andMonoBinds, andMonoBindList, getTyVarName,
                          isClassDecl, isClassOpSig, isPragSig, collectMonoBinders
                        )
 import HsPragmas       ( ClassPragmas(..) )
@@ -50,8 +51,9 @@ import IdInfo
 import Name            ( Name, nameOccName, isLocallyDefined, NamedThing(..) )
 import NameSet         ( emptyNameSet )
 import Outputable
-import Type            ( mkFunTy, mkTyVarTy, mkTyVarTys, mkDictTy,
-                         mkSigmaTy, mkForAllTys, Type, ThetaType,
+import Type            ( Type, ThetaType, ClassContext,
+                         mkFunTy, mkTyVarTy, mkTyVarTys, mkDictTy,
+                         mkSigmaTy, mkForAllTys, mkClassPred, classesOfPreds,
                          boxedTypeKind, mkArrowKind
                        )
 import Var             ( tyVarKind, TyVar )
@@ -106,7 +108,7 @@ Death to "ExpandingDicts".
 
 \begin{code}
 kcClassDecl (ClassDecl context class_name
-                       tyvar_names class_sigs def_methods pragmas 
+                       tyvar_names fundeps class_sigs def_methods pragmas
                        tycon_name datacon_name sc_sel_names src_loc)
   =         -- CHECK ARITY 1 FOR HASKELL 1.4
     checkTc (opt_GlasgowExts || length tyvar_names == 1)
@@ -138,7 +140,7 @@ kcClassDecl (ClassDecl      context class_name
 \begin{code}
 tcClassDecl1 rec_env rec_inst_mapper rec_vrcs
             (ClassDecl context class_name
-                       tyvar_names class_sigs def_methods pragmas 
+                       tyvar_names fundeps class_sigs def_methods pragmas 
                        tycon_name datacon_name sc_sel_names src_loc)
   =    -- LOOK THINGS UP IN THE ENVIRONMENT
     tcLookupTy class_name                              `thenTc` \ (class_kind, _, AClass rec_class) ->
@@ -151,6 +153,9 @@ tcClassDecl1 rec_env rec_inst_mapper rec_vrcs
                                                `thenTc` \ (sc_theta, sc_tys, sc_sel_ids) ->
 --  traceTc (text "tcClassCtxt done" <+> ppr class_name)       `thenTc_`
 
+       -- CHECK THE FUNCTIONAL DEPENDENCIES,
+    tcFundeps fundeps                          `thenTc` \ fds ->
+
        -- CHECK THE CLASS SIGNATURES,
     mapTc (tcClassSig rec_env rec_class tyvars) 
          (filter isClassOpSig class_sigs)
@@ -160,7 +165,7 @@ tcClassDecl1 rec_env rec_inst_mapper rec_vrcs
     let
        (op_tys, op_items) = unzip sig_stuff
        rec_class_inst_env = rec_inst_mapper rec_class
-       clas = mkClass class_name tyvars
+       clas = mkClass class_name tyvars fds
                       sc_theta sc_sel_ids op_items
                       tycon
                       rec_class_inst_env
@@ -199,12 +204,24 @@ tcClassDecl1 rec_env rec_inst_mapper rec_vrcs
     returnTc clas
 \end{code}
 
+\begin{code}
+tcFundeps = mapTc tc_fundep
+tc_fundep (us, vs) =
+    mapTc tc_fd_tyvar us       `thenTc` \ us' ->
+    mapTc tc_fd_tyvar vs       `thenTc` \ vs' ->
+    returnTc (us', vs')
+tc_fd_tyvar v =
+    tcLookupTy v `thenTc` \(_, _, thing) ->
+    case thing of
+        ATyVar tv -> returnTc tv
+       -- ZZ else should fail more gracefully
+\end{code}
 
 \begin{code}
 tcClassContext :: Name -> Class -> [TyVar]
               -> RenamedContext        -- class context
               -> [Name]                -- Names for superclass selectors
-              -> TcM s (ThetaType,     -- the superclass context
+              -> TcM s (ClassContext,  -- the superclass context
                         [Type],        -- types of the superclass dictionaries
                         [Id])          -- superclass selector Ids
 
@@ -223,11 +240,12 @@ tcClassContext class_name rec_class rec_tyvars context sc_sel_names
     tcContext context                  `thenTc` \ sc_theta ->
 
     let
-       sc_tys = [mkDictTy sc tys | (sc,tys) <- sc_theta]
+       sc_theta' = classesOfPreds sc_theta
+       sc_tys = [mkDictTy sc tys | (sc,tys) <- sc_theta']
        sc_sel_ids = zipWithEqual "tcClassContext" mk_super_id sc_sel_names sc_tys
     in
        -- Done
-    returnTc (sc_theta, sc_tys, sc_sel_ids)
+    returnTc (sc_theta', sc_tys, sc_sel_ids)
 
   where
     rec_tyvar_tys = mkTyVarTys rec_tyvars
@@ -238,8 +256,8 @@ tcClassContext class_name rec_class rec_tyvars context sc_sel_names
          ty = mkForAllTys rec_tyvars $
               mkFunTy (mkDictTy rec_class rec_tyvar_tys) dict_ty
 
-    check_constraint (c, tys) = checkTc (all is_tyvar tys)
-                                       (superClassErr class_name (c, tys))
+    check_constraint (HsPClass c tys) = checkTc (all is_tyvar tys)
+                                        (superClassErr class_name (c, tys))
 
     is_tyvar (MonoTyVar _) = True
     is_tyvar other        = False
@@ -267,7 +285,7 @@ tcClassSig rec_env rec_clas rec_clas_tyvars
     tcHsTopType op_ty                          `thenTc` \ local_ty ->
     let
        global_ty   = mkSigmaTy rec_clas_tyvars 
-                               [(rec_clas, mkTyVarTys rec_clas_tyvars)]
+                               [mkClassPred rec_clas (mkTyVarTys rec_clas_tyvars)]
                                local_ty
 
        -- Build the selector id and default method id
@@ -324,7 +342,7 @@ tcClassDecl2 :: RenamedTyClDecl             -- The class declaration
             -> NF_TcM s (LIE, TcMonoBinds)
 
 tcClassDecl2 (ClassDecl context class_name
-                       tyvar_names class_sigs default_binds pragmas _ _ _ src_loc)
+                       tyvar_names _ class_sigs default_binds pragmas _ _ _ src_loc)
 
   | not (isLocallyDefined class_name)
   = returnNF_Tc (emptyLIE, EmptyMonoBinds)
@@ -448,7 +466,7 @@ tcDefaultMethodBinds clas default_binds sigs
     tc_dm op_item@(_, dm_id, _)
       = tcInstTyVars tyvars            `thenNF_Tc` \ (clas_tyvars, inst_tys, _) ->
        let
-           theta = [(clas,inst_tys)]
+           theta = [(mkClassPred clas inst_tys)]
        in
        newDicts origin theta                   `thenNF_Tc` \ (this_dict, [this_dict_id]) ->
        let
@@ -627,7 +645,7 @@ classArityErr class_name
   = ptext SLIT("Too many parameters for class") <+> quotes (ppr class_name)
 
 superClassErr class_name sc
-  = ptext SLIT("Illegal superclass constraint") <+> quotes (pprClassAssertion sc)
+  = ptext SLIT("Illegal superclass constraint") <+> quotes (pprHsClassAssertion sc)
     <+> ptext SLIT("in declaration for class") <+> quotes (ppr class_name)
 
 defltMethCtxt class_name