[project @ 1999-06-08 16:06:04 by simonmar]

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

diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs
index 1632327..282b30e 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,14 +31,15 @@ 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 FieldLabel
 import Var             ( Id, TyVar )
-import Name            ( Name, isLocallyDefined, OccName, NamedThing(..) )
+import Name            ( Name, isLocallyDefined, OccName, NamedThing(..), nameUnique )
 import Outputable
 import TyCon           ( TyCon, ArgVrcs, mkSynTyCon, mkAlgTyCon, isAlgTyCon, 
                          isSynTyCon, tyConDataCons, isNewTyCon
@@ -110,7 +111,7 @@ tcTyDecl :: RecFlag -> FiniteMap Name ArgVrcs -> RenamedTyClDecl -> TcM s TyCon
 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
         argvrcs = lookupWithDefaultFM rec_vrcs (pprPanic "tcTyDecl: argvrcs:" $ ppr tycon_name)
@@ -196,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_`
@@ -242,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
@@ -276,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 (getUnfoldingTemplate (getIdUnfolding data_id))
                | data_id <- data_ids, isLocallyDefined data_id
                ]
+             | otherwise
+             = []
     in 
     returnTc (data_ids, andMonoBindList binds)
   where
@@ -300,7 +303,18 @@ mkRecordSelector tycon fields@((first_con, first_field_label) : other_fields)
        -- Check that all the fields in the group have the same type
        -- This check assumes that all the constructors of a given
        -- data type use the same type variables
-  = checkTc (all (== field_ty) other_tys)
+  = (if null other_fields then (\x->x) else
+       let lbls = [fieldLabelName f | (_,f) <- fields]
+           uniqs = [nameUnique l | l <- lbls]
+
+       in
+        pprTrace "mkRecordSelector" (vcat [ppr fields,
+                                       ppr lbls,
+                                       ppr uniqs,
+                                       hsep [text (show (field_name `compare` fieldLabelName f)) | (_,f) <- fields]
+                                       ]))
+                                 
+    checkTc (all (== field_ty) other_tys)
            (fieldTypeMisMatch field_name)      `thenTc_`
     returnTc selector_id
   where