[project @ 2000-10-03 08:43:00 by simonpj]

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

diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs
index f0518d3..c9699c9 100644 (file)
--- a/ghc/compiler/typecheck/TcTyClsDecls.lhs
+++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs
@@ -29,10 +29,11 @@ import TcMonoType   ( kcHsTyVars, kcHsType, kcHsBoxedSigType, kcHsContext, mkTyClT
 import TcType          ( TcKind, newKindVar, zonkKindEnv )
 
 import TcUnify         ( unifyKind )
+import TcInstDcls      ( tcAddDeclCtxt )
 import Type            ( Kind, mkArrowKind, boxedTypeKind, zipFunTys )
 import Variance         ( calcTyConArgVrcs )
 import Class           ( Class, mkClass, classTyCon )
-import TyCon           ( TyCon, ArgVrcs, AlgTyConFlavour(..), mkSynTyCon, mkAlgTyCon, mkClassTyCon )
+import TyCon           ( TyCon, ArgVrcs, AlgTyConFlavour(..), mkSynTyCon, mkAlgTyConRep, mkClassTyCon )
 import DataCon         ( isNullaryDataCon )
 import Var             ( varName )
 import FiniteMap
@@ -46,6 +47,8 @@ import UniqSet                ( emptyUniqSet, unitUniqSet, unionUniqSets,
                          unionManyUniqSets, uniqSetToList ) 
 import ErrUtils                ( Message )
 import Unique          ( Unique, Uniquable(..) )
+import HsDecls          ( fromClassDeclNameList )
+import Generics         ( mkTyConGenInfo )
 \end{code}
 
 
@@ -78,7 +81,6 @@ tcGroups unf_env (group:groups)
 
 Dealing with a group
 ~~~~~~~~~~~~~~~~~~~~
-
 Consider a mutually-recursive group, binding 
 a type constructor T and a class C.
 
@@ -156,8 +158,6 @@ tcGroup unf_env scc
                AcyclicSCC decl -> [decl]
                CyclicSCC decls -> decls
 
-tcTyClDecl1  :: ValueEnv -> RenamedTyClDecl -> TcM s (Name, TyThingDetails)
-
 tcTyClDecl1 unf_env decl
   = tcAddDeclCtxt decl                 $
     if isClassDecl decl then
@@ -180,11 +180,11 @@ getInitialKind (TySynonym name tyvars _ _)
    newKindVar          `thenNF_Tc` \ result_kind  ->
    returnNF_Tc (name, mk_kind arg_kinds result_kind)
 
-getInitialKind (TyData _ _ name tyvars _ _ _ _ _)
+getInitialKind (TyData _ _ name tyvars _ _ _ _ _ _ _)
  = kcHsTyVars tyvars   `thenNF_Tc` \ arg_kinds ->
    returnNF_Tc (name, mk_kind arg_kinds boxedTypeKind)
 
-getInitialKind (ClassDecl _ name tyvars _ _ _ _ _ _ _ _ _)
+getInitialKind (ClassDecl _ name tyvars _ _ _ _ _ _ )
  = kcHsTyVars tyvars   `thenNF_Tc` \ arg_kinds ->
    returnNF_Tc (name, mk_kind arg_kinds boxedTypeKind)
 
@@ -220,7 +220,7 @@ kcTyClDecl decl@(TySynonym tycon_name hs_tyvars rhs loc)
     kcHsType rhs                       `thenTc` \ rhs_kind ->
     unifyKind result_kind rhs_kind
 
-kcTyClDecl decl@(TyData _ context tycon_name hs_tyvars con_decls _ _ _ loc)
+kcTyClDecl decl@(TyData _ context tycon_name hs_tyvars con_decls _ _ _ loc _ _)
   = tcAddDeclCtxt decl                 $
     kcTyClDeclBody tycon_name hs_tyvars        $ \ result_kind ->
     kcHsContext context                        `thenTc_` 
@@ -234,7 +234,7 @@ kcTyClDecl decl@(TyData _ context tycon_name hs_tyvars con_decls _ _ _ loc)
 
 kcTyClDecl decl@(ClassDecl context class_name
                           hs_tyvars fundeps class_sigs
-                          _ _ _ _ _ _ loc)
+                          _ _ _ loc)
   = tcAddDeclCtxt decl                 $
     kcTyClDeclBody class_name hs_tyvars        $ \ result_kind ->
     kcHsContext context                        `thenTc_`
@@ -283,13 +283,14 @@ buildTyConOrClass is_rec kenv rec_vrcs rec_details
         argvrcs                    = lookupWithDefaultFM rec_vrcs bogusVrcs tycon
 
 buildTyConOrClass is_rec kenv rec_vrcs  rec_details
-                 (TyData data_or_new context tycon_name tyvar_names _ nconstrs _ _ src_loc)
+                 (TyData data_or_new context tycon_name tyvar_names _ nconstrs _ _ src_loc name1 name2)
   = (tycon_name, ATyCon tycon)
   where
-       tycon = mkAlgTyCon tycon_name tycon_kind tyvars ctxt argvrcs
+       tycon = mkAlgTyConRep tycon_name tycon_kind tyvars ctxt argvrcs
                           data_cons nconstrs
                           derived_classes
-                          flavour is_rec
+                          flavour is_rec gen_info
+       gen_info = mkTyConGenInfo tycon name1 name2
 
        DataTyDetails ctxt data_cons derived_classes = lookupNameEnv_NF rec_details tycon_name
 
@@ -304,10 +305,11 @@ buildTyConOrClass is_rec kenv rec_vrcs  rec_details
 
 buildTyConOrClass is_rec kenv rec_vrcs  rec_details
                   (ClassDecl context class_name
-                            tyvar_names fundeps class_sigs def_methods pragmas 
-                            tycon_name datacon_name datacon_wkr_name sc_sel_names src_loc)
+                            tyvar_names fundeps class_sigs def_methods pragmas
+                            name_list src_loc)
   = (class_name, AClass clas)
   where
+        (tycon_name, _, _, _) = fromClassDeclNameList name_list
        clas = mkClass class_name tyvars fds
                       sc_theta sc_sel_ids op_items
                       tycon
@@ -386,7 +388,7 @@ Edges in Type/Class decls
 
 mk_cls_edges :: RenamedTyClDecl -> Maybe (RenamedTyClDecl, Unique, [Unique])
 
-mk_cls_edges decl@(ClassDecl ctxt name _ _ _ _ _ _ _ _ _ _)
+mk_cls_edges decl@(ClassDecl ctxt name _ _ _ _ _ _ _)
   = Just (decl, getUnique name, map getUnique (catMaybes (map get_clas ctxt)))
 mk_cls_edges other_decl
   = Nothing
@@ -394,7 +396,7 @@ mk_cls_edges other_decl
 ----------------------------------------------------
 mk_edges :: RenamedTyClDecl -> (RenamedTyClDecl, Unique, [Unique])
 
-mk_edges decl@(TyData _ ctxt name _ condecls _ derivs _ _)
+mk_edges decl@(TyData _ ctxt name _ condecls _ derivs _ _ _ _)
   = (decl, getUnique name, uniqSetToList (get_ctxt ctxt `unionUniqSets`
                                         get_cons condecls `unionUniqSets`
                                         get_deriv derivs))
@@ -402,7 +404,7 @@ mk_edges decl@(TyData _ ctxt name _ condecls _ derivs _ _)
 mk_edges decl@(TySynonym name _ rhs _)
   = (decl, getUnique name, uniqSetToList (get_ty rhs))
 
-mk_edges decl@(ClassDecl ctxt name _ _ sigs _ _ _ _ _ _ _)
+mk_edges decl@(ClassDecl ctxt name _ _ sigs _ _ _ _)
   = (decl, getUnique name, uniqSetToList (get_ctxt ctxt `unionUniqSets`
                                         get_sigs sigs))
 
@@ -467,23 +469,6 @@ set_name name = unitUniqSet (getUnique name)
 %************************************************************************
 
 \begin{code}
-tcAddDeclCtxt decl thing_inside
-  = tcAddSrcLoc loc    $
-    tcAddErrCtxt ctxt  $
-    thing_inside
-  where
-     (name, loc, thing)
-       = case decl of
-           (ClassDecl _ name _ _ _ _ _ _ _ _ _ loc) -> (name, loc, "class")
-           (TySynonym name _ _ loc)                 -> (name, loc, "type synonym")
-           (TyData NewType  _ name _ _ _ _ _ loc)   -> (name, loc, "newtype")
-           (TyData DataType _ name _ _ _ _ _ loc)   -> (name, loc, "data type")
-
-     ctxt = hsep [ptext SLIT("In the"), text thing, 
-                 ptext SLIT("declaration for"), quotes (ppr name)]
-\end{code}
-
-\begin{code}
 typeCycleErr, classCycleErr :: [[RenamedTyClDecl]] -> Message
 
 typeCycleErr syn_cycles