[project @ 2000-10-16 13:13:41 by sewardj]

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

diff --git a/ghc/compiler/basicTypes/DataCon.lhs b/ghc/compiler/basicTypes/DataCon.lhs
index f44f932..50aac8c 100644 (file)
--- a/ghc/compiler/basicTypes/DataCon.lhs
+++ b/ghc/compiler/basicTypes/DataCon.lhs
@@ -9,12 +9,12 @@ module DataCon (
        ConTag, fIRST_TAG,
        mkDataCon,
        dataConRepType, dataConSig, dataConName, dataConTag, dataConTyCon,
-       dataConArgTys, dataConOrigArgTys,
-       dataConRepArgTys,
+       dataConArgTys, dataConOrigArgTys, dataConInstOrigArgTys,
+       dataConRepArgTys, dataConTheta,
        dataConFieldLabels, dataConStrictMarks, 
        dataConSourceArity, dataConRepArity,
        dataConNumInstArgs, dataConId, dataConWrapId, dataConRepStrictness,
-       isNullaryDataCon, isTupleCon, isUnboxedTupleCon, isDynDataCon,
+       isNullaryDataCon, isTupleCon, isUnboxedTupleCon, 
        isExistentialDataCon, 
 
        splitProductType_maybe, splitProductType,
@@ -28,16 +28,15 @@ module DataCon (
 import {-# SOURCE #-} Subst( substTy, mkTyVarSubst )
 
 import CmdLineOpts     ( opt_DictsStrict )
-import TysPrim
 import Type            ( Type, ThetaType, TauType, ClassContext,
                          mkForAllTys, mkFunTys, mkTyConApp, 
-                         mkTyVarTys, mkDictTy,
-                         splitAlgTyConApp_maybe, classesToPreds
+                         mkTyVarTys, mkDictTys,
+                         splitTyConApp_maybe, classesToPreds
                        )
-import TyCon           ( TyCon, tyConDataCons, isDataTyCon, isProductTyCon,
+import TyCon           ( TyCon, tyConDataCons, tyConDataConsIfAvailable, isDataTyCon, isProductTyCon,
                          isTupleTyCon, isUnboxedTupleTyCon, isRecursiveTyCon )
 import Class           ( classTyCon )
-import Name            ( Name, NamedThing(..), nameUnique, isDynName, isLocallyDefined )
+import Name            ( Name, NamedThing(..), nameUnique, isLocallyDefined )
 import Var             ( TyVar, Id )
 import FieldLabel      ( FieldLabel )
 import BasicTypes      ( Arity )
@@ -46,10 +45,9 @@ import Outputable
 import Unique          ( Unique, Uniquable(..) )
 import CmdLineOpts     ( opt_UnboxStrictFields )
 import PprType         ()      -- Instances
-import UniqSet
 import Maybes          ( maybeToBool )
 import Maybe
-import Util            ( assoc )
+import ListSetOps      ( assoc )
 \end{code}
 
 
@@ -105,6 +103,9 @@ data DataCon
        --      dcTyCon    = T
 
        dcTyVars :: [TyVar],            -- Type vars and context for the data type decl
+                                       -- These are ALWAYS THE SAME AS THE TYVARS 
+                                       -- FOR THE PARENT TyCon.  We occasionally rely on
+                                       -- this just to avoid redundant instantiation
        dcTheta  ::  ClassContext,
 
        dcExTyVars :: [TyVar],          -- Ditto for the context of the constructor, 
@@ -117,7 +118,7 @@ data DataCon
        dcRepArgTys :: [Type],          -- Final, representation argument types, after unboxing and flattening,
                                        -- and including existential dictionaries
 
-       dcTyCon  :: TyCon,              -- Result tycon 
+       dcTyCon  :: TyCon,              -- Result tycon
 
        -- Now the strictness annotations and field labels of the constructor
        dcUserStricts :: [StrictnessMark], 
@@ -259,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 = [mkDictTy cls tys | (cls,tys) <- ex_theta] ++ concat strict_arg_tyss
+    rep_arg_tys = mkDictTys 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
@@ -353,6 +354,16 @@ dataConArgTys :: DataCon
 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 dc = dcTheta dc
+
+-- And the same deal for the original arg tys:
+
+dataConInstOrigArgTys :: DataCon -> [Type] -> [Type]
+dataConInstOrigArgTys (MkData {dcOrigArgTys = arg_tys, dcTyVars = tyvars, 
+                      dcExTyVars = ex_tyvars}) inst_tys
+ = map (substTy (mkTyVarSubst (tyvars ++ ex_tyvars) inst_tys)) arg_tys
 \end{code}
 
 These two functions get the real argument types of the constructor,
@@ -381,9 +392,6 @@ isUnboxedTupleCon (MkData {dcTyCon = tc}) = isUnboxedTupleTyCon tc
 
 isExistentialDataCon :: DataCon -> Bool
 isExistentialDataCon (MkData {dcExTyVars = tvs}) = not (null tvs)
-
-isDynDataCon :: DataCon -> Bool
-isDynDataCon con = isDynName (dataConName con)
 \end{code}
 
 
@@ -402,6 +410,7 @@ splitProductType_maybe
                  [Type])               -- Its *representation* arg types
 
        -- Returns (Just ...) for any 
+       --      concrete (i.e. constructors visible)
        --      single-constructor
        --      not existentially quantified
        -- type whether a data type or a new type
@@ -411,10 +420,13 @@ splitProductType_maybe
        -- it through till someone finds it's important.
 
 splitProductType_maybe ty
-  = case splitAlgTyConApp_maybe ty of
-       Just (tycon,ty_args,[data_con]) 
-          | isProductTyCon tycon               -- Includes check for non-existential
+  = case splitTyConApp_maybe ty of
+       Just (tycon,ty_args) 
+          | isProductTyCon tycon       -- Includes check for non-existential,
+                                       -- and for constructors visible
           -> Just (tycon, ty_args, data_con, dataConArgTys data_con ty_args)
+          where
+             data_con = head (tyConDataConsIfAvailable tycon)
        other -> Nothing
 
 splitProductType str ty