[project @ 1999-10-25 13:20:57 by sof]

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

diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs
index d33163c..ed94366 100644 (file)
--- a/ghc/compiler/typecheck/TcTyDecls.lhs
+++ b/ghc/compiler/typecheck/TcTyDecls.lhs
@@ -18,11 +18,11 @@ import HsSyn                ( MonoBinds(..),
                        )
 import RnHsSyn         ( RenamedTyClDecl, RenamedConDecl )
 import TcHsSyn         ( TcMonoBinds )
-import BasicTypes      ( RecFlag(..), NewOrData(..), StrictnessMark(..) )
+import BasicTypes      ( RecFlag(..), NewOrData(..) )
 
 import TcMonoType      ( tcExtendTopTyVarScope, tcExtendTyVarScope, 
                          tcHsTypeKind, tcHsType, tcHsTopType, tcHsTopBoxedType,
-                         tcContext
+                         tcContext, tcHsTopTypeKind
                        )
 import TcType          ( zonkTcTyVarToTyVar, zonkTcThetaType )
 import TcEnv           ( tcLookupTy, TcTyThing(..) )
@@ -31,16 +31,17 @@ import TcUnify              ( unifyKind )
 
 import Class           ( Class )
 import DataCon         ( DataCon, dataConSig, mkDataCon, isNullaryDataCon,
-                         dataConFieldLabels, dataConId
+                         dataConFieldLabels, dataConId,
+                         markedStrict, notMarkedStrict, markedUnboxed
                        )
 import MkId            ( mkDataConId, mkRecordSelId, mkNewTySelId )
 import Id              ( getIdUnfolding )
-import CoreUnfold      ( getUnfoldingTemplate )
+import CoreUnfold      ( unfoldingTemplate )
 import FieldLabel
 import Var             ( Id, TyVar )
-import Name            ( isLocallyDefined, OccName, NamedThing(..) )
+import Name            ( Name, isLocallyDefined, OccName, NamedThing(..), nameUnique )
 import Outputable
-import TyCon           ( TyCon, mkSynTyCon, mkAlgTyCon, isAlgTyCon, 
+import TyCon           ( TyCon, ArgVrcs, mkSynTyCon, mkAlgTyCon, isAlgTyCon, 
                          isSynTyCon, tyConDataCons, isNewTyCon
                        )
 import Type            ( getTyVar, tyVarsOfTypes,
@@ -52,6 +53,7 @@ import Type           ( getTyVar, tyVarsOfTypes,
 import Var             ( tyVarKind )
 import VarSet          ( intersectVarSet, isEmptyVarSet )
 import Util            ( equivClasses )
+import FiniteMap        ( FiniteMap, lookupWithDefaultFM )
 \end{code}
 
 %************************************************************************
@@ -104,20 +106,22 @@ kcConDecl (ConDecl _ ex_tvs ex_ctxt details loc)
 %************************************************************************
 
 \begin{code}
-tcTyDecl :: RecFlag -> RenamedTyClDecl -> TcM s TyCon
+tcTyDecl :: RecFlag -> FiniteMap Name ArgVrcs -> RenamedTyClDecl -> TcM s TyCon
 
-tcTyDecl is_rec (TySynonym tycon_name tyvar_names rhs src_loc)
+tcTyDecl is_rec rec_vrcs (TySynonym tycon_name tyvar_names rhs src_loc)
   = tcLookupTy tycon_name                              `thenNF_Tc` \ (tycon_kind, Just arity, _) ->
     tcExtendTopTyVarScope tycon_kind tyvar_names       $ \ tyvars _ ->
-    tcHsTopType rhs                                    `thenTc` \ rhs_ty ->
+    tcHsTopTypeKind rhs                                        `thenTc` \ (_, rhs_ty) ->
     let
        -- Construct the tycon
-       tycon = mkSynTyCon tycon_name tycon_kind arity tyvars rhs_ty
+        argvrcs = lookupWithDefaultFM rec_vrcs (pprPanic "tcTyDecl: argvrcs:" $ ppr tycon_name)
+                                      tycon_name
+       tycon = mkSynTyCon tycon_name tycon_kind arity tyvars rhs_ty argvrcs
     in
     returnTc tycon
 
 
-tcTyDecl is_rec (TyData data_or_new context tycon_name tyvar_names con_decls derivings pragmas src_loc)
+tcTyDecl is_rec rec_vrcs (TyData data_or_new context tycon_name tyvar_names con_decls derivings pragmas src_loc)
   =    -- Lookup the pieces
     tcLookupTy tycon_name                              `thenNF_Tc` \ (tycon_kind, _, ATyCon rec_tycon) ->
     tcExtendTopTyVarScope tycon_kind tyvar_names       $ \ tyvars _ ->
@@ -134,7 +138,10 @@ tcTyDecl is_rec (TyData data_or_new context tycon_name tyvar_names con_decls der
                                DataType | all isNullaryDataCon data_cons -> EnumType
                                         | otherwise                      -> DataType
 
-       tycon = mkAlgTyCon tycon_name tycon_kind tyvars ctxt
+        argvrcs = lookupWithDefaultFM rec_vrcs (pprPanic "tcTyDecl: argvrcs:" $ ppr tycon_name)
+                                      tycon_name
+
+       tycon = mkAlgTyCon tycon_name tycon_kind tyvars ctxt argvrcs
                           data_cons
                           derived_classes
                           Nothing              -- Not a dictionary
@@ -190,7 +197,7 @@ tc_con_decl_help tycon tyvars ctxt name ex_tyvars ex_theta details
              Nothing -> []
              Just f  -> [mkFieldLabel (getName f) arg_ty (head allFieldLabelTags)]
         in           
-       mk_data_con [NotMarkedStrict] [arg_ty] field_label
+       mk_data_con [notMarkedStrict] [arg_ty] field_label
 
     tc_rec_con fields
       = checkTc (null ex_tyvars) (exRecConErr name)        `thenTc_`
@@ -236,10 +243,9 @@ thinContext arg_tys ctxt
       in_arg_tys (clas,tys) = not $ isEmptyVarSet $ 
                              tyVarsOfTypes tys `intersectVarSet` arg_tyvars
   
-get_strictness (Banged   _) = MarkedStrict
-get_strictness (Unbanged _) = NotMarkedStrict
-get_strictness (Unpacked _) = MarkedUnboxed bot bot
-       where bot = error "get_strictness"
+get_strictness (Banged   _) = markedStrict
+get_strictness (Unbanged _) = notMarkedStrict
+get_strictness (Unpacked _) = markedUnboxed
 
 get_pty (Banged ty)   = ty
 get_pty (Unbanged ty) = ty
@@ -270,9 +276,12 @@ mkDataBinds_one tycon
 
        -- For the locally-defined things
        -- we need to turn the unfoldings inside the Ids into bindings,
-       binds = [ CoreMonoBind data_id (getUnfoldingTemplate (getIdUnfolding data_id))
+       binds | isLocallyDefined tycon
+             = [ CoreMonoBind data_id (unfoldingTemplate (getIdUnfolding data_id))
                | data_id <- data_ids, isLocallyDefined data_id
                ]
+             | otherwise
+             = []
     in 
     returnTc (data_ids, andMonoBindList binds)
   where