[project @ 2000-07-07 09:37:39 by simonmar]

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

diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs
index a5aee6b..8e38983 100644 (file)
--- a/ghc/compiler/typecheck/TcClassDcl.lhs
+++ b/ghc/compiler/typecheck/TcClassDcl.lhs
@@ -13,8 +13,8 @@ module TcClassDcl ( kcClassDecl, tcClassDecl1, tcClassDecls2, mkImplicitClassBin
 import HsSyn           ( HsDecl(..), TyClDecl(..), Sig(..), MonoBinds(..),
                          InPat(..), HsBinds(..), GRHSs(..),
                          HsExpr(..), HsLit(..), HsType(..), HsPred(..),
-                         pprHsClassAssertion, unguardedRHS,
-                         andMonoBinds, andMonoBindList, getTyVarName,
+                         mkSimpleMatch,
+                         andMonoBinds, andMonoBindList, getTyVarName, 
                          isClassDecl, isClassOpSig, isPragSig, collectMonoBinders
                        )
 import HsPragmas       ( ClassPragmas(..) )
@@ -27,7 +27,7 @@ import TcHsSyn                ( TcMonoBinds, idsToMonoBinds )
 
 import Inst            ( Inst, InstOrigin(..), LIE, emptyLIE, plusLIE, plusLIEs, newDicts, newMethod )
 import TcEnv           ( TcId, ValueEnv, TcTyThing(..), tcAddImportedIdInfo,
-                         tcLookupClass, tcLookupTy, tcExtendTyVarEnvForMeths, tcExtendGlobalTyVars,
+                         tcLookupTy, tcExtendTyVarEnvForMeths, tcExtendGlobalTyVars,
                          tcExtendLocalValEnv
                        )
 import TcBinds         ( tcBindWithSigs, tcSpecSigs )
@@ -117,7 +117,7 @@ kcClassDecl (ClassDecl      context class_name
            (classArityErr class_name)          `thenTc_`
 
        -- Get the (mutable) class kind
-    tcLookupTy class_name                      `thenNF_Tc` \ (kind, _, _) ->
+    tcLookupTy class_name                      `thenNF_Tc` \ (kind, _) ->
 
        -- Make suitable tyvars and do kind checking
        -- The net effect is to mutate the class kind
@@ -145,7 +145,7 @@ tcClassDecl1 rec_env rec_inst_mapper rec_vrcs
                        tyvar_names fundeps class_sigs def_methods pragmas 
                        tycon_name datacon_name datacon_wkr_name sc_sel_names src_loc)
   =    -- LOOK THINGS UP IN THE ENVIRONMENT
-    tcLookupTy class_name                              `thenTc` \ (class_kind, _, AClass rec_class) ->
+    tcLookupTy class_name                              `thenTc` \ (class_kind, AClass rec_class arity) ->
     tcExtendTopTyVarScope class_kind tyvar_names       $ \ tyvars _ ->
        -- The class kind is by now immutable
        
@@ -201,7 +201,7 @@ tcClassDecl1 rec_env rec_inst_mapper rec_vrcs
                             clas               -- Yes!  It's a dictionary 
                             new_or_data
     in
-    returnTc clas
+    returnTc (class_name, AClass clas arity)
 \end{code}
 
 \begin{code}
@@ -211,10 +211,8 @@ tc_fundep (us, vs) =
     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
+    tcLookupTy v        `thenTc` \(_, ATyVar tv) ->
+    returnTc tv
 \end{code}
 
 \begin{code}
@@ -242,25 +240,17 @@ tcClassContext class_name rec_class rec_tyvars context sc_sel_names
     let
        sc_theta' = classesOfPreds sc_theta
        sc_tys = mkDictTys sc_theta'
-       sc_sel_ids = zipWithEqual "tcClassContext" mk_super_id sc_sel_names sc_tys
+       sc_sel_ids = [mkDictSelId sc_name rec_class | sc_name <- sc_sel_names]
     in
        -- Done
     returnTc (sc_theta', sc_tys, sc_sel_ids)
 
   where
-    rec_tyvar_tys = mkTyVarTys rec_tyvars
+    check_constraint sc@(HsPClass c tys) = checkTc (all is_tyvar tys)
+                                                  (superClassErr class_name sc)
 
-    mk_super_id name dict_ty
-        = mkDictSelId name rec_class ty
-        where
-         ty = mkForAllTys rec_tyvars $
-              mkFunTy (mkDictTy rec_class rec_tyvar_tys) dict_ty
-
-    check_constraint (HsPClass c tys) = checkTc (all is_tyvar tys)
-                                        (superClassErr class_name (c, tys))
-
-    is_tyvar (MonoTyVar _) = True
-    is_tyvar other        = False
+    is_tyvar (HsTyVar _) = True
+    is_tyvar other      = False
 
 
 tcClassSig :: ValueEnv         -- Knot tying only!
@@ -289,7 +279,7 @@ tcClassSig rec_env rec_clas rec_clas_tyvars
                                local_ty
 
        -- Build the selector id and default method id
-       sel_id      = mkDictSelId op_name rec_clas global_ty
+       sel_id      = mkDictSelId op_name rec_clas
        dm_id       = mkDefaultMethodId dm_name rec_clas global_ty
        final_dm_id = tcAddImportedIdInfo rec_env dm_id
     in
@@ -350,7 +340,7 @@ tcClassDecl2 (ClassDecl context class_name
   | otherwise  -- It is locally defined
   = recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyMonoBinds)) $ 
     tcAddSrcLoc src_loc                                          $
-    tcLookupClass class_name                           `thenNF_Tc` \ clas ->
+    tcLookupTy class_name                              `thenNF_Tc` \ (_, AClass clas _) ->
     tcDefaultMethodBinds clas default_binds class_sigs
 \end{code}
 
@@ -611,8 +601,6 @@ tcMethodBind clas origin inst_tyvars inst_tys inst_theta
        -- but we must use the method name; so we substitute it here.  Crude but simple.
    find_bind meth_name (FunMonoBind op_name fix matches loc)
        | op_name == sel_name = Just (FunMonoBind meth_name fix matches loc)
-   find_bind meth_name (PatMonoBind (VarPatIn op_name) grhss loc)
-       | op_name == sel_name = Just (PatMonoBind (VarPatIn meth_name) grhss loc)
    find_bind meth_name (AndMonoBinds b1 b2)
                              = find_bind meth_name b1 `seqMaybe` find_bind meth_name b2
    find_bind meth_name other  = Nothing        -- Default case
@@ -630,8 +618,9 @@ tcMethodBind clas origin inst_tyvars inst_tys inst_theta
    find_prags meth_name (prag:prags) = find_prags meth_name prags
 
    mk_default_bind local_meth_name loc
-      = PatMonoBind (VarPatIn local_meth_name)
-                   (GRHSs (unguardedRHS (default_expr loc) loc) EmptyBinds Nothing)
+      = FunMonoBind local_meth_name
+                   False       -- Not infix decl
+                   [mkSimpleMatch [] (default_expr loc) Nothing loc]
                    loc
 
    default_expr loc 
@@ -651,7 +640,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 (pprHsClassAssertion sc)
+  = ptext SLIT("Illegal superclass constraint") <+> quotes (ppr sc)
     <+> ptext SLIT("in declaration for class") <+> quotes (ppr class_name)
 
 defltMethCtxt class_name