[project @ 2000-04-20 16:22:46 by panne]

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

diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs
index be02521..4018eb3 100644 (file)
--- a/ghc/compiler/typecheck/TcClassDcl.lhs
+++ b/ghc/compiler/typecheck/TcClassDcl.lhs
@@ -31,6 +31,7 @@ import TcEnv          ( TcId, ValueEnv, TcTyThing(..), tcAddImportedIdInfo,
                          tcExtendLocalValEnv
                        )
 import TcBinds         ( tcBindWithSigs, tcSpecSigs )
+import TcTyDecls       ( mkNewTyConRep )
 import TcUnify         ( unifyKinds )
 import TcMonad
 import TcMonoType      ( kcHsType, tcHsTopType, tcExtendTopTyVarScope, 
@@ -53,14 +54,13 @@ import Name         ( Name, nameOccName, isLocallyDefined, NamedThing(..) )
 import NameSet         ( emptyNameSet )
 import Outputable
 import Type            ( Type, ThetaType, ClassContext,
-                         mkFunTy, mkTyVarTy, mkTyVarTys, mkDictTy,
+                         mkFunTy, mkTyVarTy, mkTyVarTys, mkDictTy, mkDictTys,
                          mkSigmaTy, mkForAllTys, mkClassPred, classesOfPreds,
                          boxedTypeKind, mkArrowKind
                        )
-import PprType          ( {- instance Outputable Type -} )
 import Var             ( tyVarKind, TyVar )
-import VarSet          ( mkVarSet )
-import TyCon           ( mkAlgTyCon )
+import VarSet          ( mkVarSet, emptyVarSet )
+import TyCon           ( AlgTyConFlavour(..), mkClassTyCon )
 import Unique          ( Unique, Uniquable(..) )
 import Util
 import Maybes          ( seqMaybe )
@@ -174,8 +174,8 @@ tcClassDecl1 rec_env rec_inst_mapper rec_vrcs
 
        dict_component_tys = sc_tys ++ op_tys
        new_or_data = case dict_component_tys of
-                       [_]   -> NewType
-                       other -> DataType
+                       [_]   -> NewTyCon (mkNewTyConRep tycon)
+                       other -> DataTyCon
 
         dict_con = mkDataCon datacon_name
                           [notMarkedStrict | _ <- dict_component_tys]
@@ -193,16 +193,13 @@ tcClassDecl1 rec_env rec_inst_mapper rec_vrcs
                                                          ppr tycon_name)
                                       tycon_name
 
-       tycon = mkAlgTyCon tycon_name
-                           class_kind
-                           tyvars
-                           []                  -- No context
-                            argvrcs
-                           [dict_con]          -- Constructors
-                           []                  -- No derivings
-                           (Just clas)         -- Yes!  It's a dictionary 
-                           new_or_data
-                           NonRecursive
+       tycon = mkClassTyCon tycon_name
+                            class_kind
+                            tyvars
+                             argvrcs
+                            dict_con           -- Constructors
+                            clas               -- Yes!  It's a dictionary 
+                            new_or_data
     in
     returnTc clas
 \end{code}
@@ -244,7 +241,7 @@ tcClassContext class_name rec_class rec_tyvars context sc_sel_names
 
     let
        sc_theta' = classesOfPreds sc_theta
-       sc_tys = [mkDictTy sc tys | (sc,tys) <- sc_theta']
+       sc_tys = mkDictTys sc_theta'
        sc_sel_ids = zipWithEqual "tcClassContext" mk_super_id sc_sel_names sc_tys
     in
        -- Done
@@ -254,10 +251,10 @@ tcClassContext class_name rec_class rec_tyvars context sc_sel_names
     rec_tyvar_tys = mkTyVarTys rec_tyvars
 
     mk_super_id name dict_ty
-        = mkDictSelId name rec_class ty
+        = mkDictSelId name rec_class {- SUP:??? ty
         where
          ty = mkForAllTys rec_tyvars $
-              mkFunTy (mkDictTy rec_class rec_tyvar_tys) dict_ty
+              mkFunTy (mkDictTy rec_class rec_tyvar_tys) dict_ty -}
 
     check_constraint (HsPClass c tys) = checkTc (all is_tyvar tys)
                                         (superClassErr class_name (c, tys))
@@ -292,7 +289,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 {- SUP:??? global_ty -}
        dm_id       = mkDefaultMethodId dm_name rec_clas global_ty
        final_dm_id = tcAddImportedIdInfo rec_env dm_id
     in
@@ -599,15 +596,14 @@ tcMethodBind clas origin inst_tyvars inst_tys inst_theta
        -- Now check that the instance type variables
        -- (or, in the case of a class decl, the class tyvars)
        -- have not been unified with anything in the environment
-   tcAddErrCtxtM (sigCtxt sig_msg (mkSigmaTy inst_tyvars inst_theta (idType meth_id))) $
-   checkSigTyVars inst_tyvars                                          `thenTc_` 
+   tcAddErrCtxtM (sigCtxt sig_msg inst_tyvars inst_theta (idType meth_id))     $
+   checkSigTyVars inst_tyvars emptyVarSet                                      `thenTc_` 
 
    returnTc (binds `AndMonoBinds` prag_binds1 `AndMonoBinds` prag_binds2, 
             insts `plusLIE` prag_lie', 
             meth)
  where
-   sig_msg ty = sep [ptext SLIT("When checking the expected type for"),
-                   nest 4 (ppr sel_name <+> dcolon <+> ppr ty)]
+   sig_msg = ptext SLIT("When checking the expected type for class method") <+> ppr sel_name
 
    sel_name = idName sel_id