[project @ 2002-02-13 15:19:17 by simonpj]

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

diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs
index f525f4e..0ed2fef 100644 (file)
--- a/ghc/compiler/typecheck/TcTyDecls.lhs
+++ b/ghc/compiler/typecheck/TcTyDecls.lhs
@@ -31,7 +31,9 @@ import FieldLabel
 import Var             ( TyVar, idType )
 import Name            ( Name, NamedThing(..) )
 import Outputable
-import TyCon           ( TyCon, tyConName, tyConTheta, getSynTyConDefn, tyConTyVars, tyConDataCons, isSynTyCon )
+import TyCon           ( TyCon, DataConDetails(..), visibleDataCons,
+                         tyConName, tyConTheta, getSynTyConDefn, 
+                         tyConTyVars, tyConDataCons, isSynTyCon )
 import VarSet          ( intersectVarSet, isEmptyVarSet )
 import PrelNames       ( unpackCStringName, unpackCStringUtf8Name )
 import ListSetOps      ( equivClasses )
@@ -53,14 +55,14 @@ tcTyDecl unf_env (TySynonym {tcdName = tycon_name, tcdSynRhs = rhs})
     returnTc (tycon_name, SynTyDetails rhs_ty)
 
 tcTyDecl unf_env (TyData {tcdND = new_or_data, tcdCtxt = context,
-                                 tcdName = tycon_name, tcdCons = con_decls})
+                         tcdName = tycon_name, tcdCons = con_decls})
   = tcLookupTyCon tycon_name                   `thenNF_Tc` \ tycon ->
     let
        tyvars = tyConTyVars tycon
     in
     tcExtendTyVarEnv tyvars                            $
-    tcHsTheta context                                          `thenTc` \ ctxt ->
-    mapTc (tcConDecl new_or_data tycon tyvars ctxt) con_decls  `thenTc` \ data_cons ->
+    tcHsTheta context                                  `thenTc` \ ctxt ->
+    tcConDecls new_or_data tycon tyvars ctxt con_decls `thenTc` \ data_cons ->
     let
        sel_ids = mkRecordSelectors unf_env tycon data_cons
     in
@@ -76,7 +78,8 @@ mkRecordSelectors unf_env tycon data_cons
      [ mkRecordSelId tycon field unpack_id unpackUtf8_id
      | field <- nubBy eq_name fields ]
   where
-    fields = [ field | con <- data_cons, field <- dataConFieldLabels con ]
+    fields = [ field | con <- visibleDataCons data_cons, 
+                      field <- dataConFieldLabels con ]
     eq_name field1 field2 = fieldLabelName field1 == fieldLabelName field2
 
     unpack_id     = tcLookupRecId unf_env unpackCStringName
@@ -155,49 +158,59 @@ kcConDetails new_or_data ex_ctxt details
            -- going to remove the constructor while coercing it to a lifted type.
 
 
-tcConDecl :: NewOrData -> TyCon -> [TyVar] -> ThetaType -> RenamedConDecl -> TcM DataCon
-tcConDecl new_or_data tycon tyvars ctxt (ConDecl name wkr_name ex_tvs ex_ctxt details src_loc)
-  = tcAddSrcLoc src_loc                                                        $
-    tcHsTyVars ex_tvs (kcConDetails new_or_data ex_ctxt details)       $ \ ex_tyvars ->
-    tcHsTheta ex_ctxt                                                  `thenTc` \ ex_theta ->
-    case details of
-       VanillaCon btys    -> tc_datacon ex_tyvars ex_theta btys
-       InfixCon bty1 bty2 -> tc_datacon ex_tyvars ex_theta [bty1,bty2]
-       RecCon fields      -> tc_rec_con ex_tyvars ex_theta fields
+tcConDecls :: NewOrData -> TyCon -> [TyVar] -> ThetaType 
+          -> DataConDetails RenamedConDecl -> TcM (DataConDetails DataCon)
+
+tcConDecls new_or_data tycon tyvars ctxt con_decls
+  = case con_decls of
+       Unknown     -> returnTc Unknown
+       HasCons n   -> returnTc (HasCons n)
+       DataCons cs -> mapTc tc_con_decl cs     `thenTc` \ data_cons ->
+                      returnTc (DataCons data_cons)
   where
-    tc_datacon ex_tyvars ex_theta btys
-      = mapTc tcHsType (map getBangType btys)  `thenTc` \ arg_tys ->
-       mk_data_con ex_tyvars ex_theta (map getBangStrictness btys) arg_tys []
-
-    tc_rec_con ex_tyvars ex_theta fields
-      = checkTc (null ex_tyvars) (exRecConErr name)    `thenTc_`
-       mapTc tc_field (fields `zip` allFieldLabelTags) `thenTc` \ field_labels_s ->
-       let
-           field_labels = concat field_labels_s
-           arg_stricts = [str | (ns, bty) <- fields, 
-                                let str = getBangStrictness bty, 
-                                n <- ns        -- One for each.  E.g   x,y,z :: !Int
-                         ]
-       in
-       mk_data_con ex_tyvars ex_theta arg_stricts 
-                   (map fieldLabelType field_labels) field_labels
-
-    tc_field ((field_label_names, bty), tag)
-      = tcHsType (getBangType bty)                     `thenTc` \ field_ty ->
-       returnTc [mkFieldLabel (getName name) tycon field_ty tag | name <- field_label_names]
-
-    mk_data_con ex_tyvars ex_theta arg_stricts arg_tys fields
-      = let
-          data_con = mkDataCon name arg_stricts fields
-                          tyvars (thinContext arg_tys ctxt)
-                          ex_tyvars ex_theta
-                          arg_tys
-                          tycon data_con_id data_con_wrap_id
-
-          data_con_id      = mkDataConId wkr_name data_con
-          data_con_wrap_id = mkDataConWrapId data_con
-       in
-       returnNF_Tc data_con
+    tc_con_decl (ConDecl name wkr_name ex_tvs ex_ctxt details src_loc)
+      = tcAddSrcLoc src_loc                                            $
+       tcHsTyVars ex_tvs (kcConDetails new_or_data ex_ctxt details)    $ \ ex_tyvars ->
+       tcHsTheta ex_ctxt                                               `thenTc` \ ex_theta ->
+       case details of
+           VanillaCon btys    -> tc_datacon ex_tyvars ex_theta btys
+           InfixCon bty1 bty2 -> tc_datacon ex_tyvars ex_theta [bty1,bty2]
+           RecCon fields      -> tc_rec_con ex_tyvars ex_theta fields
+      where
+       
+       tc_datacon ex_tyvars ex_theta btys
+         = mapTc tcHsType (map getBangType btys)       `thenTc` \ arg_tys ->
+           mk_data_con ex_tyvars ex_theta (map getBangStrictness btys) arg_tys []
+    
+       tc_rec_con ex_tyvars ex_theta fields
+         = checkTc (null ex_tyvars) (exRecConErr name) `thenTc_`
+           mapTc tc_field (fields `zip` allFieldLabelTags)     `thenTc` \ field_labels_s ->
+           let
+               field_labels = concat field_labels_s
+               arg_stricts = [str | (ns, bty) <- fields, 
+                                    let str = getBangStrictness bty, 
+                                    n <- ns    -- One for each.  E.g   x,y,z :: !Int
+                             ]
+           in
+           mk_data_con ex_tyvars ex_theta arg_stricts 
+                       (map fieldLabelType field_labels) field_labels
+    
+       tc_field ((field_label_names, bty), tag)
+         = tcHsType (getBangType bty)                  `thenTc` \ field_ty ->
+           returnTc [mkFieldLabel (getName name) tycon field_ty tag | name <- field_label_names]
+    
+       mk_data_con ex_tyvars ex_theta arg_stricts arg_tys fields
+         = let
+              data_con = mkDataCon name arg_stricts fields
+                              tyvars (thinContext arg_tys ctxt)
+                              ex_tyvars ex_theta
+                              arg_tys
+                              tycon data_con_id data_con_wrap_id
+    
+              data_con_id      = mkDataConId wkr_name data_con
+              data_con_wrap_id = mkDataConWrapId data_con
+           in
+           returnNF_Tc data_con
 
 -- The context for a data constructor should be limited to
 -- the type variables mentioned in the arg_tys