[project @ 2001-03-19 16:20:44 by simonpj]

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

diff --git a/ghc/compiler/basicTypes/DataCon.lhs b/ghc/compiler/basicTypes/DataCon.lhs
index 39f4952..dd6212b 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,
 
@@ -28,15 +28,15 @@ module DataCon (
 import {-# SOURCE #-} Subst( substTy, mkTyVarSubst )
 
 import CmdLineOpts     ( opt_DictsStrict )
-import Type            ( Type, TauType, ClassContext,
+import Type            ( Type, TauType, ThetaType,
                          mkForAllTys, mkFunTys, mkTyConApp,
-                         mkTyVarTys, mkDictTys,
+                         mkTyVarTys, mkPredTys, getClassPredTys_maybe,
                          splitTyConApp_maybe
                        )
 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 )
@@ -106,10 +106,10 @@ data DataCon
                                        -- These are ALWAYS THE SAME AS THE TYVARS
                                        -- FOR THE PARENT TyCon.  We occasionally rely on
                                        -- this just to avoid redundant instantiation
-       dcTheta  ::  ClassContext,
+       dcTheta  ::  ThetaType,
 
        dcExTyVars :: [TyVar],          -- Ditto for the context of the constructor,
-       dcExTheta  :: ClassContext,     -- the existentially quantified stuff
+       dcExTheta  :: ThetaType,        -- the existentially quantified stuff
                                        
        dcOrigArgTys :: [Type],         -- Original argument types
                                        -- (before unboxing and flattening of
@@ -233,8 +233,8 @@ instance Show DataCon where
 \begin{code}
 mkDataCon :: Name
          -> [StrictnessMark] -> [FieldLabel]
-         -> [TyVar] -> ClassContext
-         -> [TyVar] -> ClassContext
+         -> [TyVar] -> ThetaType
+         -> [TyVar] -> ThetaType
          -> [TauType] -> TyCon
          -> Id -> Id
          -> DataCon
@@ -260,7 +260,7 @@ mkDataCon name arg_stricts fields
 
     (real_arg_stricts, strict_arg_tyss)
        = unzip (zipWith (unbox_strict_arg_ty tycon) arg_stricts orig_arg_tys)
-    rep_arg_tys = mkDictTys ex_theta ++ concat strict_arg_tyss
+    rep_arg_tys = mkPredTys ex_theta ++ concat strict_arg_tyss
        
     ex_dict_stricts = map mk_dict_strict_mark ex_theta
        -- Add a strictness flag for the existential dictionary arguments
@@ -274,9 +274,9 @@ mkDataCon name arg_stricts fields
 
     result_ty = mkTyConApp tycon (mkTyVarTys tyvars)
 
-mk_dict_strict_mark (clas,tys)
-  | opt_DictsStrict &&
-       -- Don't mark newtype things as strict!
+mk_dict_strict_mark pred
+  | opt_DictsStrict,   -- Don't mark newtype things as strict!
+    Just (clas,_) <- getClassPredTys_maybe pred,
     isDataTyCon (classTyCon clas) = MarkedStrict
   | otherwise                    = NotMarkedStrict
 \end{code}
@@ -334,8 +334,8 @@ dataConRepStrictness dc
     go (NotMarkedStrict     : ss) = wwLazy   : go ss
     go (MarkedUnboxed con _ : ss) = go (dcRealStricts con ++ ss)
 
-dataConSig :: DataCon -> ([TyVar], ClassContext,
-                         [TyVar], ClassContext,
+dataConSig :: DataCon -> ([TyVar], ThetaType,
+                         [TyVar], ThetaType,
                          [TauType], TyCon)
 
 dataConSig (MkData {dcTyVars = tyvars, dcTheta = theta,
@@ -355,7 +355,7 @@ dataConArgTys (MkData {dcRepArgTys = arg_tys, dcTyVars = tyvars,
                       dcExTyVars = ex_tyvars}) inst_tys
  = map (substTy (mkTyVarSubst (tyvars ++ ex_tyvars) inst_tys)) arg_tys
 
-dataConTheta :: DataCon -> ClassContext
+dataConTheta :: DataCon -> ThetaType
 dataConTheta dc = dcTheta dc
 
 -- And the same deal for the original arg tys:
@@ -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