[project @ 2000-12-19 14:19:24 by simonmar]

[ghc-hetmet.git] / ghc / compiler / basicTypes / DataCon.lhs

diff --git a/ghc/compiler/basicTypes/DataCon.lhs b/ghc/compiler/basicTypes/DataCon.lhs
index 39f4952..4ad15df 100644 (file)
--- a/ghc/compiler/basicTypes/DataCon.lhs
+++ b/ghc/compiler/basicTypes/DataCon.lhs
@@ -15,7 +15,7 @@ module DataCon (
        dataConSourceArity, dataConRepArity,
        dataConNumInstArgs, dataConId, dataConWrapId, dataConRepStrictness,
        isNullaryDataCon, isTupleCon, isUnboxedTupleCon,
-       isExistentialDataCon,
+       isExistentialDataCon, classDataCon,
 
        splitProductType_maybe, splitProductType,
 
@@ -35,8 +35,8 @@ import Type           ( Type, TauType, ClassContext,
                        )
 import TyCon           ( TyCon, tyConDataCons, tyConDataConsIfAvailable, isDataTyCon, isProductTyCon,
                          isTupleTyCon, isUnboxedTupleTyCon, isRecursiveTyCon )
-import Class           ( classTyCon )
-import Name            ( Name, NamedThing(..), nameUnique, isLocallyDefined )
+import Class           ( Class, classTyCon )
+import Name            ( Name, NamedThing(..), nameUnique )
 import Var             ( TyVar, Id )
 import FieldLabel      ( FieldLabel )
 import BasicTypes      ( Arity )
@@ -395,6 +395,12 @@ isExistentialDataCon (MkData {dcExTyVars = tvs}) = not (null tvs)
 \end{code}
 
 
+\begin{code}
+classDataCon :: Class -> DataCon
+classDataCon clas = case tyConDataCons (classTyCon clas) of
+                     (dict_constr:no_more) -> ASSERT( null no_more ) dict_constr 
+\end{code}
+
 %************************************************************************
 %*                                                                     *
 \subsection{Splitting products}
@@ -448,9 +454,8 @@ unbox_strict_arg_ty :: TyCon -> StrictnessMark -> Type -> (StrictnessMark, [Type
 unbox_strict_arg_ty tycon strict_mark ty
   | case strict_mark of
        NotMarkedStrict   -> False
-       MarkedUnboxed _ _ -> True
-       MarkedStrict      -> opt_UnboxStrictFields &&
-                            isLocallyDefined tycon &&
+       MarkedUnboxed _ _ -> True                               -- !! From interface file
+       MarkedStrict      -> opt_UnboxStrictFields &&           -- !  From source
                             maybeToBool maybe_product &&
                             not (isRecursiveTyCon tycon) &&
                             isDataTyCon arg_tycon