[project @ 2001-05-22 13:43:14 by simonpj]
[ghc-hetmet.git] / ghc / compiler / typecheck / TcTyDecls.lhs
index 45afd7b..afbd15e 100644 (file)
@@ -10,14 +10,14 @@ module TcTyDecls (
 
 #include "HsVersions.h"
 
-import HsSyn           ( TyClDecl(..), ConDecl(..), ConDetails(..), BangType(..),
-                         getBangType, conDetailsTys
+import HsSyn           ( TyClDecl(..), ConDecl(..), ConDetails(..), 
+                         getBangType, getBangStrictness, conDetailsTys
                        )
 import RnHsSyn         ( RenamedTyClDecl, RenamedConDecl, RenamedContext )
 import BasicTypes      ( NewOrData(..), RecFlag, isRec )
 
-import TcMonoType      ( tcHsRecType, tcHsTyVars, tcRecClassContext,
-                         kcHsContext, kcHsSigType, kcHsBoxedSigType
+import TcMonoType      ( tcHsRecType, tcHsTyVars, tcRecTheta,
+                         kcHsContext, kcHsSigType, kcHsLiftedSigType
                        )
 import TcEnv           ( tcExtendTyVarEnv, 
                          tcLookupTyCon, tcLookupRecId, 
@@ -25,19 +25,16 @@ import TcEnv                ( tcExtendTyVarEnv,
                        )
 import TcMonad
 
-import Class           ( ClassContext )
-import DataCon         ( DataCon, mkDataCon, dataConFieldLabels,  markedStrict, 
-                         notMarkedStrict, markedUnboxed, dataConRepType
-                       )
+import DataCon         ( DataCon, mkDataCon, dataConFieldLabels, dataConRepType )
 import MkId            ( mkDataConId, mkDataConWrapId, mkRecordSelId )
 import FieldLabel
 import Var             ( TyVar )
 import Name            ( Name, NamedThing(..) )
 import Outputable
 import TyCon           ( TyCon, isNewTyCon, tyConTyVars )
-import Type            ( tyVarsOfTypes, splitFunTy, applyTys,
+import Type            ( tyVarsOfTypes, tyVarsOfPred, splitFunTy, applyTys,
                          mkTyConApp, mkTyVarTys, mkForAllTys, 
-                         splitAlgTyConApp_maybe, Type
+                         splitAlgTyConApp_maybe, Type, ThetaType
                        )
 import TysWiredIn      ( unitTy )
 import VarSet          ( intersectVarSet, isEmptyVarSet )
@@ -53,7 +50,7 @@ import ListSetOps     ( equivClasses )
 
 \begin{code}
 tcTyDecl1 :: RecFlag -> RecTcEnv -> RenamedTyClDecl -> TcM (Name, TyThingDetails)
-tcTyDecl1 is_rec unf_env (TySynonym tycon_name tyvar_names rhs src_loc)
+tcTyDecl1 is_rec unf_env (TySynonym {tcdName = tycon_name, tcdSynRhs = rhs})
   = tcLookupTyCon tycon_name                   `thenNF_Tc` \ tycon ->
     tcExtendTyVarEnv (tyConTyVars tycon)       $
     tcHsRecType is_rec rhs                     `thenTc` \ rhs_ty ->
@@ -71,7 +68,8 @@ tcTyDecl1 is_rec unf_env (TySynonym tycon_name tyvar_names rhs src_loc)
 
     returnTc (tycon_name, SynTyDetails rhs_ty)
 
-tcTyDecl1 is_rec unf_env (TyData new_or_data context tycon_name _ con_decls _ derivings src_loc name1 name2)
+tcTyDecl1 is_rec unf_env (TyData {tcdND = new_or_data, tcdCtxt = context,
+                                 tcdName = tycon_name, tcdCons = con_decls})
   = tcLookupTyCon tycon_name                   `thenNF_Tc` \ tycon ->
     let
        tyvars = tyConTyVars tycon
@@ -79,7 +77,7 @@ tcTyDecl1 is_rec unf_env (TyData new_or_data context tycon_name _ con_decls _ de
     tcExtendTyVarEnv tyvars                            $
 
        -- Typecheck the pieces
-    tcRecClassContext is_rec context                                   `thenTc` \ ctxt ->
+    tcRecTheta is_rec context                                          `thenTc` \ ctxt ->
     mapTc (tcConDecl is_rec new_or_data tycon tyvars ctxt) con_decls   `thenTc` \ data_cons ->
     tcRecordSelectors is_rec unf_env tycon data_cons                   `thenTc` \ sel_ids -> 
     returnTc (tycon_name, DataTyDetails ctxt data_cons sel_ids)
@@ -121,17 +119,17 @@ kcConDetails new_or_data ex_ctxt details
   where
     kc_sig_type = case new_or_data of
                    DataType -> kcHsSigType
-                   NewType  -> kcHsBoxedSigType
-           -- Can't allow an unboxed type here, because we're effectively
-           -- going to remove the constructor while coercing it to a boxed type.
+                   NewType  -> kcHsLiftedSigType
+           -- Can't allow an unlifted type here, because we're effectively
+           -- going to remove the constructor while coercing it to a lifted type.
 
 
-tcConDecl :: RecFlag -> NewOrData -> TyCon -> [TyVar] -> ClassContext -> RenamedConDecl -> TcM DataCon
+tcConDecl :: RecFlag -> NewOrData -> TyCon -> [TyVar] -> ThetaType -> RenamedConDecl -> TcM DataCon
 
 tcConDecl is_rec 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 ->
-    tcRecClassContext is_rec ex_ctxt                                   `thenTc` \ ex_theta ->
+    tcRecTheta is_rec 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]
@@ -181,12 +179,8 @@ thinContext arg_tys ctxt
   = filter in_arg_tys ctxt
   where
       arg_tyvars = tyVarsOfTypes arg_tys
-      in_arg_tys (clas,tys) = not $ isEmptyVarSet $ 
-                             tyVarsOfTypes tys `intersectVarSet` arg_tyvars
-
-getBangStrictness (Banged   _) = markedStrict
-getBangStrictness (Unbanged _) = notMarkedStrict
-getBangStrictness (Unpacked _) = markedUnboxed
+      in_arg_tys pred = not $ isEmptyVarSet $ 
+                       tyVarsOfPred pred `intersectVarSet` arg_tyvars
 \end{code}
 
 
@@ -198,32 +192,34 @@ getBangStrictness (Unpacked _) = markedUnboxed
 
 \begin{code}
 tcRecordSelectors is_rec unf_env tycon data_cons
-  = mapTc tc_group groups
+       -- Omit the check that the fields have consistent types if 
+       -- the group is recursive; TcTyClsDecls.tcGroup will repeat 
+       -- with NonRecursive once we have tied the knot
+  | isRec is_rec = returnTc sel_ids
+  | otherwise   = mapTc check groups   `thenTc_` 
+                  returnTc sel_ids
   where
-    fields = [ (con, field) | con   <- data_cons,
-                             field <- dataConFieldLabels con ]
+    fields = [ field | con   <- data_cons
+                    , field <- dataConFieldLabels con ]
 
        -- groups is list of fields that share a common name
-    groups = equivClasses cmp_name fields
-    cmp_name (_, field1) (_, field2) 
-       = fieldLabelName field1 `compare` fieldLabelName field2
+    groups                = equivClasses cmp_name fields
+    cmp_name field1 field2 = fieldLabelName field1 `compare` fieldLabelName field2
+
+    sel_ids = [ mkRecordSelId tycon field unpack_id unpackUtf8_id
+             | (field : _) <- groups ]
 
-    tc_group fields@((first_con, first_field_label) : other_fields)
+    check fields@(first_field_label : other_fields)
        -- These fields all have the same name, but are from
        -- different constructors in the data type
        =       -- Check that all the fields in the group have the same type
-               -- Wimp out (omit check) if the group is recursive; 
-               -- TcTyClsDecls.tcGroup will repeat with NonRecursive once we
-               -- have tied the knot
                -- NB: this check assumes that all the constructors of a given
                -- data type use the same type variables
-         checkTc (not (isRec is_rec) && all (== field_ty) other_tys)
-                 (fieldTypeMisMatch field_name)        `thenTc_`
-         returnTc (mkRecordSelId tycon first_field_label unpack_id unpackUtf8_id)
+         checkTc (all (== field_ty) other_tys) (fieldTypeMisMatch field_name)
        where
            field_ty   = fieldLabelType first_field_label
            field_name = fieldLabelName first_field_label
-           other_tys  = [fieldLabelType fl | (_, fl) <- other_fields]
+           other_tys  = map fieldLabelType other_fields
 
     unpack_id     = tcLookupRecId unf_env unpackCStringName
     unpackUtf8_id = tcLookupRecId unf_env unpackCStringUtf8Name
@@ -240,7 +236,7 @@ tcRecordSelectors is_rec unf_env tycon data_cons
 
 \begin{code}
 fieldTypeMisMatch field_name
-  = sep [ptext SLIT("Declared types differ for field"), quotes (ppr field_name)]
+  = sep [ptext SLIT("Different constructors give different types for field"), quotes (ppr field_name)]
 
 exRecConErr name
   = ptext SLIT("Can't combine named fields with locally-quantified type variables")