[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 a9aac4c..50aac8c 100644 (file)
--- a/ghc/compiler/basicTypes/DataCon.lhs
+++ b/ghc/compiler/basicTypes/DataCon.lhs
@@ -9,7 +9,7 @@ module DataCon (
        ConTag, fIRST_TAG,
        mkDataCon,
        dataConRepType, dataConSig, dataConName, dataConTag, dataConTyCon,
-       dataConArgTys, dataConOrigArgTys,
+       dataConArgTys, dataConOrigArgTys, dataConInstOrigArgTys,
        dataConRepArgTys, dataConTheta,
        dataConFieldLabels, dataConStrictMarks, 
        dataConSourceArity, dataConRepArity,
@@ -28,13 +28,12 @@ module DataCon (
 import {-# SOURCE #-} Subst( substTy, mkTyVarSubst )
 
 import CmdLineOpts     ( opt_DictsStrict )
-import TysPrim
 import Type            ( Type, ThetaType, TauType, ClassContext,
                          mkForAllTys, mkFunTys, mkTyConApp, 
                          mkTyVarTys, mkDictTys,
-                         splitAlgTyConApp_maybe, classesToPreds
+                         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, isLocallyDefined )
@@ -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}
 
 
@@ -120,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], 
@@ -357,7 +355,15 @@ dataConArgTys (MkData {dcRepArgTys = arg_tys, dcTyVars = tyvars,
                       dcExTyVars = ex_tyvars}) inst_tys
  = map (substTy (mkTyVarSubst (tyvars ++ ex_tyvars) inst_tys)) arg_tys
 
-dataConTheta (MkData {dcTheta = theta}) = theta
+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,
@@ -404,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
@@ -413,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