[project @ 2002-02-13 15:19:17 by simonpj]

----------------------------------
	Do the Right Thing for TyCons where we
	can't see all their constructors.
	----------------------------------

Inside a TyCon, three things can happen

1. GHC knows all the constructors, and has them to hand.
   (Nowadays, there may be zero constructors.)

2. GHC knows all the constructors, but has declined to slurp
   them all in, to avoid sucking in more declarations than
   necessary.  All we remember is the number of constructors,
   so we can get the return convention right.

3. GHC doesn't know anything. This happens *only* for decls
   coming from .hi-boot files, where the programmer declines to
   supply a representation.

Until now, these three cases have been conflated together.  Matters
are worse now that a TyCon really can have zero constructors.  In
fact, by confusing (3) with (1) we can actually generate bogus code.

With this commit, the dataCons field of a TyCon is of type:

data DataConDetails datacon
  = DataCons [datacon]	-- Its data constructors, with fully polymorphic types
			-- A type can have zero constructors

  | Unknown		-- We're importing this data type from an hi-boot file
			-- and we don't know what its constructors are

  | HasCons Int		-- In a quest for compilation speed we have imported
			-- only the number of constructors (to get return
			-- conventions right) but not the constructors themselves

This says exactly what is going on.  There are lots of consequential small
changes.

diff --git a/ghc/compiler/basicTypes/DataCon.lhs b/ghc/compiler/basicTypes/DataCon.lhs
index efefb63..ac3ffa3 100644 (file)
--- a/ghc/compiler/basicTypes/DataCon.lhs
+++ b/ghc/compiler/basicTypes/DataCon.lhs
@@ -30,7 +30,7 @@ import Type           ( Type, ThetaType,
                          mkTyVarTys, splitTyConApp_maybe, repType, 
                          mkPredTys, isStrictType
                        )
                          mkTyVarTys, splitTyConApp_maybe, repType, 
                          mkPredTys, isStrictType
                        )

-import TyCon           ( TyCon, tyConDataCons, tyConDataConsIfAvailable, isProductTyCon,
+import TyCon           ( TyCon, tyConDataCons, tyConDataCons, isProductTyCon,

                          isTupleTyCon, isUnboxedTupleTyCon, isRecursiveTyCon )
 import Class           ( Class, classTyCon )
 import Name            ( Name, NamedThing(..), nameUnique )
                          isTupleTyCon, isUnboxedTupleTyCon, isRecursiveTyCon )
 import Class           ( Class, classTyCon )
 import Name            ( Name, NamedThing(..), nameUnique )

@@ -399,7 +399,7 @@ splitProductType_maybe ty
                                        -- and for constructors visible
           -> Just (tycon, ty_args, data_con, dataConArgTys data_con ty_args)
           where
                                        -- and for constructors visible
           -> Just (tycon, ty_args, data_con, dataConArgTys data_con ty_args)
           where

-             data_con = head (tyConDataConsIfAvailable tycon)
+             data_con = head (tyConDataCons tycon)

        other -> Nothing
 
 splitProductType str ty
        other -> Nothing
 
 splitProductType str ty

diff --git a/ghc/compiler/ghci/InteractiveUI.hs b/ghc/compiler/ghci/InteractiveUI.hs
index 1e98d0c..b915e6f 100644 (file)
--- a/ghc/compiler/ghci/InteractiveUI.hs
+++ b/ghc/compiler/ghci/InteractiveUI.hs
@@ -1,6 +1,6 @@
 {-# OPTIONS -#include "Linker.h" -#include "SchedAPI.h" #-}
 -----------------------------------------------------------------------------
 {-# OPTIONS -#include "Linker.h" -#include "SchedAPI.h" #-}
 -----------------------------------------------------------------------------

--- $Id: InteractiveUI.hs,v 1.113 2002/02/12 15:17:15 simonmar Exp $
+-- $Id: InteractiveUI.hs,v 1.114 2002/02/13 15:19:18 simonpj Exp $

 --
 -- GHC Interactive User Interface
 --
 --
 -- GHC Interactive User Interface
 --

@@ -30,7 +30,7 @@ import Util
 import Id              ( isRecordSelector, recordSelectorFieldLabel, 
                          isDataConWrapId, isDataConId, idName )
 import Class           ( className )
 import Id              ( isRecordSelector, recordSelectorFieldLabel, 
                          isDataConWrapId, isDataConId, idName )
 import Class           ( className )

-import TyCon           ( tyConName, tyConClass_maybe, isPrimTyCon )
+import TyCon           ( tyConName, tyConClass_maybe, isPrimTyCon, DataConDetails(..) )

 import FieldLabel      ( fieldLabelTyCon )
 import SrcLoc          ( isGoodSrcLoc )
 import Module          ( moduleName )
 import FieldLabel      ( fieldLabelTyCon )
 import SrcLoc          ( isGoodSrcLoc )
 import Module          ( moduleName )

@@ -680,8 +680,8 @@ browseModule m exports_only = do
       thingDecl thing@(ATyCon t) =
         let rn_decl = ifaceTyThing thing in
        case rn_decl of
       thingDecl thing@(ATyCon t) =
         let rn_decl = ifaceTyThing thing in
        case rn_decl of

-         TyData { tcdCons = cons } -> 
-               rn_decl{ tcdCons = filter conIsVisible cons }
+         TyData { tcdCons = DataCons cons } -> 
+               rn_decl{ tcdCons = DataCons (filter conIsVisible cons) }

          other -> other
         where
          conIsVisible (ConDecl n _ _ _ _ _) = n `elem` thing_names
          other -> other
         where
          conIsVisible (ConDecl n _ _ _ _ _) = n `elem` thing_names

diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs
index 7eae5ff..b4d98cf 100644 (file)
--- a/ghc/compiler/hsSyn/HsDecls.lhs
+++ b/ghc/compiler/hsSyn/HsDecls.lhs
@@ -42,6 +42,7 @@ import ForeignCall    ( CCallTarget(..), DNCallSpec, CCallConv, Safety,
 -- others:
 import Name            ( NamedThing )
 import FunDeps         ( pprFundeps )
 -- others:
 import Name            ( NamedThing )
 import FunDeps         ( pprFundeps )

+import TyCon           ( DataConDetails(..), visibleDataCons )

 import Class           ( FunDep, DefMeth(..) )
 import CStrings                ( CLabelString )
 import Outputable      
 import Class           ( FunDep, DefMeth(..) )
 import CStrings                ( CLabelString )
 import Outputable      

@@ -277,8 +278,7 @@ data TyClDecl name pat
                tcdCtxt   :: HsContext name,     -- context
                tcdName   :: name,               -- type constructor
                tcdTyVars :: [HsTyVarBndr name], -- type variables
                tcdCtxt   :: HsContext name,     -- context
                tcdName   :: name,               -- type constructor
                tcdTyVars :: [HsTyVarBndr name], -- type variables

-               tcdCons   :: [ConDecl name],     -- data constructors (empty if abstract)
-               tcdNCons  :: Int,                -- Number of data constructors (valid even if type is abstract)
+               tcdCons   :: DataConDetails (ConDecl name),      -- data constructors (empty if abstract)

                tcdDerivs :: Maybe (HsContext name),    -- derivings; Nothing => not specified
                                                        -- Just [] => derive exactly what is asked
                tcdSysNames :: DataSysNames name,       -- Generic converter functions
                tcdDerivs :: Maybe (HsContext name),    -- derivings; Nothing => not specified
                                                        -- Just [] => derive exactly what is asked
                tcdSysNames :: DataSysNames name,       -- Generic converter functions

@@ -376,7 +376,7 @@ tyClDeclSysNames :: TyClDecl name pat -> [(name, SrcLoc)]
 
 tyClDeclSysNames (ClassDecl {tcdSysNames = names, tcdLoc = loc})
   = [(n,loc) | n <- names]
 
 tyClDeclSysNames (ClassDecl {tcdSysNames = names, tcdLoc = loc})
   = [(n,loc) | n <- names]

-tyClDeclSysNames (TyData {tcdCons = cons, tcdSysNames = names, tcdLoc = loc})
+tyClDeclSysNames (TyData {tcdCons = DataCons cons, tcdSysNames = names, tcdLoc = loc})

   = [(n,loc) | n <- names] ++ 
     [(wkr_name,loc) | ConDecl _ wkr_name _ _ _ loc <- cons]
 tyClDeclSysNames decl = []
   = [(n,loc) | n <- names] ++ 
     [(wkr_name,loc) | ConDecl _ wkr_name _ _ _ loc <- cons]
 tyClDeclSysNames decl = []

@@ -405,7 +405,7 @@ instance (NamedThing name, Ord name) => Eq (TyClDecl name pat) where
        tcdND d1   == tcdND   d2 && 
        eqWithHsTyVars (tcdTyVars d1) (tcdTyVars d2) (\ env -> 
          eq_hsContext env (tcdCtxt d1) (tcdCtxt d2)  &&
        tcdND d1   == tcdND   d2 && 
        eqWithHsTyVars (tcdTyVars d1) (tcdTyVars d2) (\ env -> 
          eq_hsContext env (tcdCtxt d1) (tcdCtxt d2)  &&

-         eqListBy (eq_ConDecl env) (tcdCons d1) (tcdCons d2)
+         eq_hsCD      env (tcdCons d1) (tcdCons d2)

        )
 
   (==) d1@(TySynonym {}) d2@(TySynonym {})
        )
 
   (==) d1@(TySynonym {}) d2@(TySynonym {})

@@ -424,6 +424,11 @@ instance (NamedThing name, Ord name) => Eq (TyClDecl name pat) where
 
   (==) _ _ = False     -- default case
 
 
   (==) _ _ = False     -- default case
 

+eq_hsCD env (DataCons c1) (DataCons c2) = eqListBy (eq_ConDecl env) c1 c2
+eq_hsCD env Unknown      Unknown       = True
+eq_hsCD env (HasCons n1)  (HasCons n2)  = n1 == n2
+eq_hsCD env d1           d2            = False
+

 eq_hsFD env (ns1,ms1) (ns2,ms2)
   = eqListBy (eq_hsVar env) ns1 ns2 && eqListBy (eq_hsVar env) ms1 ms2
 
 eq_hsFD env (ns1,ms1) (ns2,ms2)
   = eqListBy (eq_hsVar env) ns1 ns2 && eqListBy (eq_hsVar env) ms1 ms2
 

@@ -477,10 +482,10 @@ instance (NamedThing name, Outputable name, Outputable pat)
             4 (ppr mono_ty)
 
     ppr (TyData {tcdND = new_or_data, tcdCtxt = context, tcdName = tycon,
             4 (ppr mono_ty)
 
     ppr (TyData {tcdND = new_or_data, tcdCtxt = context, tcdName = tycon,

-                tcdTyVars = tyvars, tcdCons = condecls, tcdNCons = ncons,
+                tcdTyVars = tyvars, tcdCons = condecls, 

                 tcdDerivs = derivings})
       = pp_tydecl (ptext keyword <+> pp_decl_head context tycon tyvars)
                 tcdDerivs = derivings})
       = pp_tydecl (ptext keyword <+> pp_decl_head context tycon tyvars)

-                 (pp_condecls condecls ncons)
+                 (pp_condecls condecls)

                  derivings
       where
        keyword = case new_or_data of
                  derivings
       where
        keyword = case new_or_data of

@@ -507,8 +512,9 @@ instance (NamedThing name, Outputable name, Outputable pat)
 pp_decl_head :: Outputable name => HsContext name -> name -> [HsTyVarBndr name] -> SDoc
 pp_decl_head context thing tyvars = hsep [pprHsContext context, ppr thing, interppSP tyvars]
 
 pp_decl_head :: Outputable name => HsContext name -> name -> [HsTyVarBndr name] -> SDoc
 pp_decl_head context thing tyvars = hsep [pprHsContext context, ppr thing, interppSP tyvars]
 

-pp_condecls []     ncons = ptext SLIT("{- abstract with") <+> int ncons <+> ptext SLIT("constructors -}")
-pp_condecls (c:cs) ncons = equals <+> sep (ppr c : map (\ c -> ptext SLIT("|") <+> ppr c) cs)
+pp_condecls Unknown      = ptext SLIT("{- abstract -}")
+pp_condecls (HasCons n)   = ptext SLIT("{- abstract with") <+> int n <+> ptext SLIT("constructors -}")
+pp_condecls (DataCons cs) = equals <+> sep (punctuate (ptext SLIT(" |")) (map ppr cs))

 
 pp_tydecl pp_head pp_decl_rhs derivings
   = hang pp_head 4 (sep [
 
 pp_tydecl pp_head pp_decl_rhs derivings
   = hang pp_head 4 (sep [

@@ -554,12 +560,12 @@ data ConDetails name
 \end{code}
 
 \begin{code}
 \end{code}
 
 \begin{code}

-conDeclsNames :: Eq name => [ConDecl name] -> [(name,SrcLoc)]
+conDeclsNames :: Eq name => DataConDetails (ConDecl name) -> [(name,SrcLoc)]

   -- See tyClDeclNames for what this does
   -- The function is boringly complicated because of the records
   -- And since we only have equality, we have to be a little careful
 conDeclsNames cons
   -- See tyClDeclNames for what this does
   -- The function is boringly complicated because of the records
   -- And since we only have equality, we have to be a little careful
 conDeclsNames cons

-  = snd (foldl do_one ([], []) cons)
+  = snd (foldl do_one ([], []) (visibleDataCons cons))

   where
     do_one (flds_seen, acc) (ConDecl name _ _ _ details loc)
        = do_details ((name,loc):acc) details
   where
     do_one (flds_seen, acc) (ConDecl name _ _ _ details loc)
        = do_details ((name,loc):acc) details

diff --git a/ghc/compiler/main/HscStats.lhs b/ghc/compiler/main/HscStats.lhs
index 4f53d0a..f20d796 100644 (file)
--- a/ghc/compiler/main/HscStats.lhs
+++ b/ghc/compiler/main/HscStats.lhs
@@ -9,6 +9,7 @@ module HscStats ( ppSourceStats ) where
 #include "HsVersions.h"
 
 import HsSyn
 #include "HsVersions.h"
 
 import HsSyn

+import TyCon           ( DataConDetails(..) )

 import Outputable
 import Char            ( isSpace )
 import Util             ( count )
 import Outputable
 import Char            ( isSpace )
 import Util             ( count )

@@ -127,8 +128,8 @@ ppSourceStats short (HsModule name version exports imports decls _ src_loc)
     spec_info (Just (False, _)) = (0,0,0,0,1,0)
     spec_info (Just (True, _))  = (0,0,0,0,0,1)
 
     spec_info (Just (False, _)) = (0,0,0,0,1,0)
     spec_info (Just (True, _))  = (0,0,0,0,0,1)
 

-    data_info (TyData {tcdNCons = nconstrs, tcdDerivs = derivs})
-       = (nconstrs, case derivs of {Nothing -> 0; Just ds -> length ds})
+    data_info (TyData {tcdCons = DataCons cs, tcdDerivs = derivs})
+       = (length cs, case derivs of {Nothing -> 0; Just ds -> length ds})

     data_info other = (0,0)
 
     class_info decl@(ClassDecl {})
     data_info other = (0,0)
 
     class_info decl@(ClassDecl {})

diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs
index 930ea0a..6077dda 100644 (file)
--- a/ghc/compiler/main/HscTypes.lhs
+++ b/ghc/compiler/main/HscTypes.lhs
@@ -65,7 +65,7 @@ import Rules          ( RuleBase )
 import CoreSyn         ( CoreBind )
 import Id              ( Id )
 import Class           ( Class, classSelIds )
 import CoreSyn         ( CoreBind )
 import Id              ( Id )
 import Class           ( Class, classSelIds )

-import TyCon           ( TyCon, isNewTyCon, tyConGenIds, tyConSelIds, tyConDataConsIfAvailable )
+import TyCon           ( TyCon, isNewTyCon, tyConGenIds, tyConSelIds, tyConDataCons_maybe )

 import DataCon         ( dataConId, dataConWrapId )
 
 import BasicTypes      ( Version, initialVersion, Fixity, defaultFixity, IPName )
 import DataCon         ( dataConId, dataConWrapId )
 
 import BasicTypes      ( Version, initialVersion, Fixity, defaultFixity, IPName )

@@ -371,7 +371,7 @@ implicitTyThingIds things
     go (AClass cl) = classSelIds cl
     go (ATyCon tc) = tyConGenIds tc ++
                     tyConSelIds tc ++
     go (AClass cl) = classSelIds cl
     go (ATyCon tc) = tyConGenIds tc ++
                     tyConSelIds tc ++

-                    [ n | dc <- tyConDataConsIfAvailable tc, 
+                    [ n | dc <- tyConDataCons_maybe tc `orElse` [],

                           n  <- implicitConIds tc dc]
                -- Synonyms return empty list of constructors and selectors
 
                           n  <- implicitConIds tc dc]
                -- Synonyms return empty list of constructors and selectors
 

diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs
index de344b7..7055df9 100644 (file)
--- a/ghc/compiler/main/MkIface.lhs
+++ b/ghc/compiler/main/MkIface.lhs
@@ -199,8 +199,7 @@ ifaceTyThing (ATyCon tycon) = ty_decl
                        tcdCtxt   = toHsContext (tyConTheta tycon),
                        tcdName   = getName tycon,
                        tcdTyVars = toHsTyVars tyvars,
                        tcdCtxt   = toHsContext (tyConTheta tycon),
                        tcdName   = getName tycon,
                        tcdTyVars = toHsTyVars tyvars,

-                       tcdCons   = map ifaceConDecl (tyConDataCons tycon),
-                       tcdNCons  = tyConFamilySize tycon,
+                       tcdCons   = ifaceConDecls (tyConDataConDetails tycon),

                        tcdDerivs = Nothing,
                        tcdSysNames  = map getName (tyConGenIds tycon),
                        tcdLoc       = noSrcLoc }
                        tcdDerivs = Nothing,
                        tcdSysNames  = map getName (tyConGenIds tycon),
                        tcdLoc       = noSrcLoc }

@@ -217,8 +216,7 @@ ifaceTyThing (ATyCon tycon) = ty_decl
                        tcdCtxt   = [],
                        tcdName   = getName tycon,
                        tcdTyVars = toHsTyVars (take (tyConArity tycon) alphaTyVars),
                        tcdCtxt   = [],
                        tcdName   = getName tycon,
                        tcdTyVars = toHsTyVars (take (tyConArity tycon) alphaTyVars),

-                       tcdCons   = [],
-                       tcdNCons  = 0,
+                       tcdCons   = Unknown,

                        tcdDerivs = Nothing,
                        tcdSysNames  = [],
                        tcdLoc       = noSrcLoc }
                        tcdDerivs = Nothing,
                        tcdSysNames  = [],
                        tcdLoc       = noSrcLoc }

@@ -230,6 +228,10 @@ ifaceTyThing (ATyCon tycon) = ty_decl
     new_or_data | isNewTyCon tycon = NewType
                | otherwise        = DataType
 
     new_or_data | isNewTyCon tycon = NewType
                | otherwise        = DataType
 

+    ifaceConDecls Unknown       = Unknown
+    ifaceConDecls (HasCons n)   = HasCons n
+    ifaceConDecls (DataCons cs) = DataCons (map ifaceConDecl cs)
+

     ifaceConDecl data_con 
        = ConDecl (getName data_con) (getName (dataConId data_con))
                  (toHsTyVars ex_tyvars)
     ifaceConDecl data_con 
        = ConDecl (getName data_con) (getName (dataConId data_con))
                  (toHsTyVars ex_tyvars)

diff --git a/ghc/compiler/parser/Parser.y b/ghc/compiler/parser/Parser.y
index 8b2ef62..ca4fbba 100644 (file)
--- a/ghc/compiler/parser/Parser.y
+++ b/ghc/compiler/parser/Parser.y
@@ -1,6 +1,6 @@
 {-                                                             -*-haskell-*-
 -----------------------------------------------------------------------------
 {-                                                             -*-haskell-*-
 -----------------------------------------------------------------------------

-$Id: Parser.y,v 1.88 2002/02/13 14:05:51 simonpj Exp $
+$Id: Parser.y,v 1.89 2002/02/13 15:19:19 simonpj Exp $

 
 Haskell grammar.
 
 
 Haskell grammar.
 

@@ -25,6 +25,7 @@ import ForeignCall    ( Safety(..), CExportSpec(..),
                          CCallConv(..), CCallTarget(..), defaultCCallConv,
                        )
 import OccName         ( UserFS, varName, tcName, dataName, tcClsName, tvName )
                          CCallConv(..), CCallTarget(..), defaultCCallConv,
                        )
 import OccName         ( UserFS, varName, tcName, dataName, tcClsName, tvName )

+import TyCon           ( DataConDetails(..) )

 import SrcLoc          ( SrcLoc )
 import Module
 import CmdLineOpts     ( opt_SccProfilingOn )
 import SrcLoc          ( SrcLoc )
 import Module
 import CmdLineOpts     ( opt_SccProfilingOn )

@@ -357,11 +358,11 @@ topdecl :: { RdrBinding }
 
        | srcloc 'data' tycl_hdr constrs deriving
                {% returnP (RdrHsDecl (TyClD
 
        | srcloc 'data' tycl_hdr constrs deriving
                {% returnP (RdrHsDecl (TyClD

-                     (mkTyData DataType $3 (reverse $4) (length $4) $5 $1))) }
+                     (mkTyData DataType $3 (DataCons (reverse $4)) $5 $1))) }

 
        | srcloc 'newtype' tycl_hdr '=' newconstr deriving
                {% returnP (RdrHsDecl (TyClD
 
        | srcloc 'newtype' tycl_hdr '=' newconstr deriving
                {% returnP (RdrHsDecl (TyClD

-                     (mkTyData NewType $3 [$5] 1 $6 $1))) }
+                     (mkTyData NewType $3 (DataCons [$5]) $6 $1))) }

 
        | srcloc 'class' tycl_hdr fds where
                {% let 
 
        | srcloc 'class' tycl_hdr fds where
                {% let 

diff --git a/ghc/compiler/parser/RdrHsSyn.lhs b/ghc/compiler/parser/RdrHsSyn.lhs
index 6626fce..6b0e63c 100644 (file)
--- a/ghc/compiler/parser/RdrHsSyn.lhs
+++ b/ghc/compiler/parser/RdrHsSyn.lhs
@@ -213,12 +213,12 @@ mkClassDecl (cxt, cname, tyvars) fds sigs mbinds loc
       --  superclasses both called C!)
     new_names = mkClassDeclSysNames (tname, dname, dwname, sc_sel_names)
 
       --  superclasses both called C!)
     new_names = mkClassDeclSysNames (tname, dname, dwname, sc_sel_names)
 

-mkTyData new_or_data (context, tname, tyvars) list_con i maybe src
+mkTyData new_or_data (context, tname, tyvars) data_cons maybe src

   = let t_occ  = rdrNameOcc tname
         name1 = mkRdrUnqual (mkGenOcc1 t_occ) 
        name2 = mkRdrUnqual (mkGenOcc2 t_occ) 
     in TyData { tcdND = new_or_data, tcdCtxt = context, tcdName = tname,
   = let t_occ  = rdrNameOcc tname
         name1 = mkRdrUnqual (mkGenOcc1 t_occ) 
        name2 = mkRdrUnqual (mkGenOcc2 t_occ) 
     in TyData { tcdND = new_or_data, tcdCtxt = context, tcdName = tname,

-               tcdTyVars = tyvars, tcdCons = list_con, tcdNCons = i,
+               tcdTyVars = tyvars, tcdCons = data_cons, 

                tcdDerivs = maybe, tcdLoc = src, tcdSysNames = [name1, name2] }
 
 mkClassOpSigDM op ty loc
                tcdDerivs = maybe, tcdLoc = src, tcdSysNames = [name1, name2] }
 
 mkClassOpSigDM op ty loc

diff --git a/ghc/compiler/prelude/PrelRules.lhs b/ghc/compiler/prelude/PrelRules.lhs
index 0ebec4f..ba53089 100644 (file)
--- a/ghc/compiler/prelude/PrelRules.lhs
+++ b/ghc/compiler/prelude/PrelRules.lhs
@@ -32,13 +32,14 @@ import Literal              ( Literal(..), isLitLitLit, mkMachInt, mkMachWord
                        )
 import PrimOp          ( PrimOp(..), primOpOcc )
 import TysWiredIn      ( trueDataConId, falseDataConId )
                        )
 import PrimOp          ( PrimOp(..), primOpOcc )
 import TysWiredIn      ( trueDataConId, falseDataConId )

-import TyCon           ( tyConDataConsIfAvailable, isEnumerationTyCon, isNewTyCon )
+import TyCon           ( tyConDataCons_maybe, isEnumerationTyCon, isNewTyCon )

 import DataCon         ( dataConTag, dataConTyCon, dataConId, fIRST_TAG )
 import CoreUtils       ( exprIsValue, cheapEqExpr, exprIsConApp_maybe )
 import Type            ( tyConAppTyCon, eqType )
 import OccName         ( occNameUserString)
 import PrelNames       ( unpackCStringFoldrName, unpackCStringFoldrIdKey, hasKey,
                          eqStringName, unpackCStringIdKey )
 import DataCon         ( dataConTag, dataConTyCon, dataConId, fIRST_TAG )
 import CoreUtils       ( exprIsValue, cheapEqExpr, exprIsConApp_maybe )
 import Type            ( tyConAppTyCon, eqType )
 import OccName         ( occNameUserString)
 import PrelNames       ( unpackCStringFoldrName, unpackCStringFoldrIdKey, hasKey,
                          eqStringName, unpackCStringIdKey )

+import Maybes          ( orElse )

 import Name            ( Name )
 import Bits            ( Bits(..) )
 #if __GLASGOW_HASKELL__ >= 500
 import Name            ( Name )
 import Bits            ( Bits(..) )
 #if __GLASGOW_HASKELL__ >= 500

@@ -418,7 +419,7 @@ seqRule other                                = Nothing
 \begin{code}
 tagToEnumRule [Type ty, Lit (MachInt i)]
   = ASSERT( isEnumerationTyCon tycon ) 
 \begin{code}
 tagToEnumRule [Type ty, Lit (MachInt i)]
   = ASSERT( isEnumerationTyCon tycon ) 

-    case filter correct_tag (tyConDataConsIfAvailable tycon) of
+    case filter correct_tag (tyConDataCons_maybe tycon `orElse` []) of

 
 
        []        -> Nothing    -- Abstract type
 
 
        []        -> Nothing    -- Abstract type

diff --git a/ghc/compiler/prelude/TysWiredIn.lhs b/ghc/compiler/prelude/TysWiredIn.lhs
index ade3426..9d743a5 100644 (file)
--- a/ghc/compiler/prelude/TysWiredIn.lhs
+++ b/ghc/compiler/prelude/TysWiredIn.lhs
@@ -94,7 +94,7 @@ import OccName                ( mkOccFS, tcName, dataName, mkWorkerOcc, mkGenOcc1, mkGenOcc2 )
 import RdrName         ( rdrNameOcc )
 import DataCon         ( DataCon, mkDataCon, dataConId, dataConSourceArity )
 import Var             ( TyVar, tyVarKind )
 import RdrName         ( rdrNameOcc )
 import DataCon         ( DataCon, mkDataCon, dataConId, dataConSourceArity )
 import Var             ( TyVar, tyVarKind )

-import TyCon           ( TyCon, AlgTyConFlavour(..), tyConDataCons,
+import TyCon           ( TyCon, AlgTyConFlavour(..), DataConDetails(..), tyConDataCons,

                          mkTupleTyCon, mkAlgTyCon, tyConName
                        )
 
                          mkTupleTyCon, mkAlgTyCon, tyConName
                        )
 

@@ -165,8 +165,7 @@ pcTyCon new_or_data is_rec name tyvars argvrcs cons
                 tyvars
                 []              -- No context
                 argvrcs
                 tyvars
                 []              -- No context
                 argvrcs

-                cons
-                (length cons) 
+                (DataCons cons)

                []              -- No record selectors
                 new_or_data
                 is_rec
                []              -- No record selectors
                 new_or_data
                 is_rec

@@ -575,11 +574,10 @@ parrTyCon  = tycon
                parrTyConName 
                kind
                tyvars
                parrTyConName 
                kind
                tyvars

-               []               -- No context
+               []                       -- No context

                [(True, False)]
                [(True, False)]

-               [parrDataCon]    -- The constructor defined in `PrelPArr'
-               1                -- The real definition has one constructor
-               []               -- No record selectors
+               (DataCons [parrDataCon]) -- The constructor defined in `PrelPArr'
+               []                       -- No record selectors

                DataTyCon
                NonRecursive
                genInfo
                DataTyCon
                NonRecursive
                genInfo

diff --git a/ghc/compiler/rename/ParseIface.y b/ghc/compiler/rename/ParseIface.y
index ce9526c..0d01d6a 100644 (file)
--- a/ghc/compiler/rename/ParseIface.y
+++ b/ghc/compiler/rename/ParseIface.y
@@ -52,6 +52,7 @@ import HscTypes         ( WhetherHasOrphans, IsBootInterface, GenAvailInfo(..),
                           RdrAvailInfo )
 
 import RdrName          ( RdrName, mkRdrUnqual, mkIfaceOrig )
                           RdrAvailInfo )
 
 import RdrName          ( RdrName, mkRdrUnqual, mkIfaceOrig )

+import TyCon           ( DataConDetails(..) )

 import Name            ( OccName )
 import OccName          ( mkSysOccFS,
                          tcName, varName, dataName, clsName, tvName,
 import Name            ( OccName )
 import OccName          ( mkSysOccFS,
                          tcName, varName, dataName, clsName, tvName,

@@ -337,9 +338,9 @@ decl    : src_loc qvar_name '::' type maybe_idinfo
        | src_loc 'foreign' 'type' qtc_name                    
                        { ForeignType $4 Nothing DNType $1 }
        | src_loc 'data' tycl_hdr constrs              
        | src_loc 'foreign' 'type' qtc_name                    
                        { ForeignType $4 Nothing DNType $1 }
        | src_loc 'data' tycl_hdr constrs              

-                       { mkTyData DataType $3 $4 (length $4) Nothing $1 }
+                       { mkTyData DataType $3 $4 Nothing $1 }

        | src_loc 'newtype' tycl_hdr newtype_constr
        | src_loc 'newtype' tycl_hdr newtype_constr

-                       { mkTyData NewType $3 $4 1 Nothing $1 }
+                       { mkTyData NewType $3 (DataCons [$4]) Nothing $1 }

        | src_loc 'class' tycl_hdr fds csigs
                        { mkClassDecl $3 $4 $5 Nothing $1 }
 
        | src_loc 'class' tycl_hdr fds csigs
                        { mkClassDecl $3 $4 $5 Nothing $1 }
 

@@ -452,9 +453,10 @@ opt_version        : version                       { $1 }
 
 ----------------------------------------------------------------------------
 
 
 ----------------------------------------------------------------------------
 

-constrs                :: { [RdrNameConDecl] {- empty for handwritten abstract -} }
-               :                       { [] }
-               | '=' constrs1          { $2 }
+constrs                :: { DataConDetails RdrNameConDecl }
+               :                       { Unknown }
+               | '='                   { DataCons [] }
+               | '=' constrs1          { DataCons $2 }

 
 constrs1       :: { [RdrNameConDecl] }
 constrs1       :  constr               { [$1] }
 
 constrs1       :: { [RdrNameConDecl] }
 constrs1       :  constr               { [$1] }

@@ -465,10 +467,10 @@ constr            :  src_loc ex_stuff qdata_name batypes          { mk_con_decl $3 $2 (VanillaCon
                |  src_loc ex_stuff qdata_name '{' fields1 '}'  { mk_con_decl $3 $2 (RecCon $5)     $1 }
                 -- We use "data_fs" so as to include ()
 
                |  src_loc ex_stuff qdata_name '{' fields1 '}'  { mk_con_decl $3 $2 (RecCon $5)     $1 }
                 -- We use "data_fs" so as to include ()
 

-newtype_constr :: { [RdrNameConDecl] {- Not allowed to be empty -} }
-newtype_constr : src_loc '=' ex_stuff qdata_name atype { [mk_con_decl $4 $3 (VanillaCon [unbangedType $5]) $1] }
+newtype_constr :: { RdrNameConDecl }
+newtype_constr : src_loc '=' ex_stuff qdata_name atype { mk_con_decl $4 $3 (VanillaCon [unbangedType $5]) $1 }

                | src_loc '=' ex_stuff qdata_name '{' qvar_name '::' atype '}'
                | src_loc '=' ex_stuff qdata_name '{' qvar_name '::' atype '}'

-                                                       { [mk_con_decl $4 $3 (RecCon [([$6], unbangedType $8)]) $1] }
+                                                       { mk_con_decl $4 $3 (RecCon [([$6], unbangedType $8)]) $1 }

 
 ex_stuff :: { ([HsTyVarBndr RdrName], RdrNameContext) }
 ex_stuff       :                                       { ([],[]) }
 
 ex_stuff :: { ([HsTyVarBndr RdrName], RdrNameContext) }
 ex_stuff       :                                       { ([],[]) }

diff --git a/ghc/compiler/rename/RnHsSyn.lhs b/ghc/compiler/rename/RnHsSyn.lhs
index 43364ae..d3f9c74 100644 (file)
--- a/ghc/compiler/rename/RnHsSyn.lhs
+++ b/ghc/compiler/rename/RnHsSyn.lhs
@@ -11,6 +11,7 @@ module RnHsSyn where
 import HsSyn
 import HsCore
 import Class           ( FunDep, DefMeth(..) )
 import HsSyn
 import HsCore
 import Class           ( FunDep, DefMeth(..) )

+import TyCon           ( DataConDetails, visibleDataCons )

 import TysWiredIn      ( tupleTyCon, listTyCon, parrTyCon, charTyCon )
 import Name            ( Name, getName, isTyVarName )
 import NameSet
 import TysWiredIn      ( tupleTyCon, listTyCon, parrTyCon, charTyCon )
 import Name            ( Name, getName, isTyVarName )
 import NameSet

@@ -131,9 +132,9 @@ tyClDeclFVs (IfaceSig {tcdType = ty, tcdIdInfo = id_infos})
     plusFVs (map hsIdInfoFVs id_infos)
 
 tyClDeclFVs (TyData {tcdCtxt = context, tcdTyVars = tyvars, tcdCons = condecls})
     plusFVs (map hsIdInfoFVs id_infos)
 
 tyClDeclFVs (TyData {tcdCtxt = context, tcdTyVars = tyvars, tcdCons = condecls})

-  = delFVs (map hsTyVarName tyvars) $
-    extractHsCtxtTyNames context               `plusFV`
-    plusFVs (map conDeclFVs condecls)
+  = delFVs (map hsTyVarName tyvars)    $
+    extractHsCtxtTyNames context       `plusFV`
+    plusFVs (map conDeclFVs (visibleDataCons condecls))

 
 tyClDeclFVs (TySynonym {tcdTyVars = tyvars, tcdSynRhs = ty})
   = delFVs (map hsTyVarName tyvars) (extractHsTyNames ty)
 
 tyClDeclFVs (TySynonym {tcdTyVars = tyvars, tcdSynRhs = ty})
   = delFVs (map hsTyVarName tyvars) (extractHsTyNames ty)

diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs
index 81479de..ba2b1cd 100644 (file)
--- a/ghc/compiler/rename/RnIfaces.lhs
+++ b/ghc/compiler/rename/RnIfaces.lhs
@@ -39,7 +39,7 @@ import IdInfo         ( GlobalIdDetails(..) )
 import TcType          ( namesOfType )
 import FieldLabel      ( fieldLabelTyCon )
 import DataCon         ( dataConTyCon )
 import TcType          ( namesOfType )
 import FieldLabel      ( fieldLabelTyCon )
 import DataCon         ( dataConTyCon )

-import TyCon           ( isSynTyCon, getSynTyConDefn, tyConClass_maybe, tyConName )
+import TyCon           ( visibleDataCons, isSynTyCon, getSynTyConDefn, tyConClass_maybe, tyConName )

 import Class           ( className )
 import Name            ( Name {-instance NamedThing-}, nameOccName,
                          nameModule, isLocalName, NamedThing(..)
 import Class           ( className )
 import Name            ( Name {-instance NamedThing-}, nameOccName,
                          nameModule, isLocalName, NamedThing(..)

@@ -528,7 +528,8 @@ get_gates is_used (TySynonym {tcdTyVars = tvs, tcdSynRhs = ty})
        -- A type synonym type constructor isn't a "gate" for instance decls
 
 get_gates is_used (TyData {tcdCtxt = ctxt, tcdName = tycon, tcdTyVars = tvs, tcdCons = cons})
        -- A type synonym type constructor isn't a "gate" for instance decls
 
 get_gates is_used (TyData {tcdCtxt = ctxt, tcdName = tycon, tcdTyVars = tvs, tcdCons = cons})

-  = delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) cons)
+  = delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) 
+                                            (visibleDataCons cons))

                       (hsTyVarNames tvs)
     `addOneToNameSet` tycon
   where
                       (hsTyVarNames tvs)
     `addOneToNameSet` tycon
   where

diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs
index 85c7cb5..cc78801 100644 (file)
--- a/ghc/compiler/rename/RnSource.lhs
+++ b/ghc/compiler/rename/RnSource.lhs
@@ -32,6 +32,7 @@ import RnEnv          ( lookupTopBndrRn, lookupOccRn, lookupIfaceName,
 import RnMonad
 
 import Class           ( FunDep, DefMeth (..) )
 import RnMonad
 
 import Class           ( FunDep, DefMeth (..) )

+import TyCon           ( DataConDetails(..), visibleDataCons )

 import DataCon         ( dataConId )
 import Name            ( Name, NamedThing(..) )
 import NameSet
 import DataCon         ( dataConId )
 import Name            ( Name, NamedThing(..) )
 import NameSet

@@ -291,7 +292,7 @@ rnTyClDecl (ForeignType {tcdName = name, tcdFoType = fo_type, tcdExtName = ext_n
     returnRn (ForeignType {tcdName = name', tcdFoType = fo_type, tcdExtName = ext_name, tcdLoc = loc})
 
 rnTyClDecl (TyData {tcdND = new_or_data, tcdCtxt = context, tcdName = tycon,
     returnRn (ForeignType {tcdName = name', tcdFoType = fo_type, tcdExtName = ext_name, tcdLoc = loc})
 
 rnTyClDecl (TyData {tcdND = new_or_data, tcdCtxt = context, tcdName = tycon,

-                   tcdTyVars = tyvars, tcdCons = condecls, tcdNCons = nconstrs,
+                   tcdTyVars = tyvars, tcdCons = condecls, 

                    tcdDerivs = derivs, tcdLoc = src_loc, tcdSysNames = sys_names})
   = pushSrcLocRn src_loc $
     lookupTopBndrRn tycon                      `thenRn` \ tycon' ->
                    tcdDerivs = derivs, tcdLoc = src_loc, tcdSysNames = sys_names})
   = pushSrcLocRn src_loc $
     lookupTopBndrRn tycon                      `thenRn` \ tycon' ->

@@ -300,24 +301,14 @@ rnTyClDecl (TyData {tcdND = new_or_data, tcdCtxt = context, tcdName = tycon,
     rn_derivs derivs                           `thenRn` \ derivs' ->
     checkDupOrQualNames data_doc con_names     `thenRn_`
 
     rn_derivs derivs                           `thenRn` \ derivs' ->
     checkDupOrQualNames data_doc con_names     `thenRn_`
 

-       -- Check that there's at least one condecl,
-       -- or else we're reading an interface file, or -fglasgow-exts
-    (if null condecls then
-       doptRn Opt_GlasgowExts  `thenRn` \ glaExts ->
-       getModeRn               `thenRn` \ mode ->
-       checkRn (glaExts || isInterfaceMode mode)
-               (emptyConDeclsErr tycon)
-     else returnRn ()
-    )                                          `thenRn_` 
-
-    mapRn rnConDecl condecls                   `thenRn` \ condecls' ->
+    rnConDecls tycon' condecls                 `thenRn` \ condecls' ->

     mapRn lookupSysBinder sys_names            `thenRn` \ sys_names' ->
     returnRn (TyData {tcdND = new_or_data, tcdCtxt = context', tcdName = tycon',
     mapRn lookupSysBinder sys_names            `thenRn` \ sys_names' ->
     returnRn (TyData {tcdND = new_or_data, tcdCtxt = context', tcdName = tycon',

-                     tcdTyVars = tyvars', tcdCons = condecls', tcdNCons = nconstrs,
+                     tcdTyVars = tyvars', tcdCons = condecls', 

                      tcdDerivs = derivs', tcdLoc = src_loc, tcdSysNames = sys_names'})
   where
     data_doc = text "In the data type declaration for" <+> quotes (ppr tycon)
                      tcdDerivs = derivs', tcdLoc = src_loc, tcdSysNames = sys_names'})
   where
     data_doc = text "In the data type declaration for" <+> quotes (ppr tycon)

-    con_names = map conDeclName condecls
+    con_names = map conDeclName (visibleDataCons condecls)

 
     rn_derivs Nothing   = returnRn Nothing
     rn_derivs (Just ds) = rnContext data_doc ds        `thenRn` \ ds' -> returnRn (Just ds')
 
     rn_derivs Nothing   = returnRn Nothing
     rn_derivs (Just ds) = rnContext data_doc ds        `thenRn` \ ds' -> returnRn (Just ds')

@@ -458,6 +449,23 @@ finishSourceTyClDecl _ tycl_decl = returnRn (tycl_decl, emptyFVs)
 conDeclName :: RdrNameConDecl -> (RdrName, SrcLoc)
 conDeclName (ConDecl n _ _ _ _ l) = (n,l)
 
 conDeclName :: RdrNameConDecl -> (RdrName, SrcLoc)
 conDeclName (ConDecl n _ _ _ _ l) = (n,l)
 

+rnConDecls :: Name -> DataConDetails RdrNameConDecl -> RnMS (DataConDetails RenamedConDecl)
+rnConDecls tycon Unknown     = returnRn Unknown
+rnConDecls tycon (HasCons n) = returnRn (HasCons n)
+rnConDecls tycon (DataCons condecls)
+  =    -- Check that there's at least one condecl,
+       -- or else we're reading an interface file, or -fglasgow-exts
+    (if null condecls then
+       doptRn Opt_GlasgowExts  `thenRn` \ glaExts ->
+       getModeRn               `thenRn` \ mode ->
+       checkRn (glaExts || isInterfaceMode mode)
+               (emptyConDeclsErr tycon)
+     else returnRn ()
+    )                                          `thenRn_` 
+
+    mapRn rnConDecl condecls                   `thenRn` \ condecls' ->
+    returnRn (DataCons condecls')
+

 rnConDecl :: RdrNameConDecl -> RnMS RenamedConDecl
 rnConDecl (ConDecl name wkr tvs cxt details locn)
   = pushSrcLocRn locn $
 rnConDecl :: RdrNameConDecl -> RnMS RenamedConDecl
 rnConDecl (ConDecl name wkr tvs cxt details locn)
   = pushSrcLocRn locn $

diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs
index 817ae8f..57c7274 100644 (file)
--- a/ghc/compiler/simplCore/SimplUtils.lhs
+++ b/ghc/compiler/simplCore/SimplUtils.lhs
@@ -41,7 +41,7 @@ import Type           ( Type, seqType, splitRepFunTys, isStrictType,
                        )
 import TcType          ( isDictTy )
 import OccName         ( UserFS )
                        )
 import TcType          ( isDictTy )
 import OccName         ( UserFS )

-import TyCon           ( tyConDataConsIfAvailable, isAlgTyCon, isNewTyCon )
+import TyCon           ( tyConDataCons_maybe, isAlgTyCon, isNewTyCon )

 import DataCon         ( dataConRepArity, dataConSig, dataConArgTys )
 import Var             ( mkSysTyVar, tyVarKind )
 import Util            ( lengthExceeds, mapAccumL )
 import DataCon         ( dataConRepArity, dataConSig, dataConArgTys )
 import Var             ( mkSysTyVar, tyVarKind )
 import Util            ( lengthExceeds, mapAccumL )

@@ -405,10 +405,10 @@ canUpdateInPlace ty
   | otherwise
   = case splitTyConApp_maybe ty of 
        Nothing         -> False 
   | otherwise
   = case splitTyConApp_maybe ty of 
        Nothing         -> False 

-       Just (tycon, _) -> case tyConDataConsIfAvailable tycon of
-                               [dc]  -> arity == 1 || arity == 2
-                                     where
-                                        arity = dataConRepArity dc
+       Just (tycon, _) -> case tyConDataCons_maybe tycon of
+                               Just [dc]  -> arity == 1 || arity == 2
+                                          where
+                                             arity = dataConRepArity dc

                                other -> False
 \end{code}
 
                                other -> False
 \end{code}
 

@@ -891,8 +891,8 @@ mkAlts scrut handled_cons case_bndr alts
                                --      case x of { DEFAULT -> e }
                                -- and we don't want to fill in a default for them!
 
                                --      case x of { DEFAULT -> e }
                                -- and we don't want to fill in a default for them!
 

-    [missing_con] <- [con | con <- tyConDataConsIfAvailable tycon,
-                           not (con `elem` handled_data_cons)]
+    Just all_cons <- tyConDataCons_maybe tycon,
+    [missing_con] <- [con | con <- all_cons, not (con `elem` handled_data_cons)]

                        -- There is just one missing constructor!
 
   = tick (FillInCaseDefault case_bndr) `thenSmpl_`
                        -- There is just one missing constructor!
 
   = tick (FillInCaseDefault case_bndr) `thenSmpl_`

diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs
index c08e43b..5dc8b8b 100644 (file)
--- a/ghc/compiler/typecheck/TcEnv.lhs
+++ b/ghc/compiler/typecheck/TcEnv.lhs
@@ -49,7 +49,7 @@ import Id             ( isDataConWrapId_maybe )
 import Var             ( TyVar, Id, idType )
 import VarSet
 import DataCon         ( DataCon )
 import Var             ( TyVar, Id, idType )
 import VarSet
 import DataCon         ( DataCon )

-import TyCon           ( TyCon )
+import TyCon           ( TyCon, DataConDetails )

 import Class           ( Class, ClassOpItem )
 import Name            ( Name, NamedThing(..), 
                          getSrcLoc, mkLocalName, isLocalName, nameIsLocalOrFrom
 import Class           ( Class, ClassOpItem )
 import Name            ( Name, NamedThing(..), 
                          getSrcLoc, mkLocalName, isLocalName, nameIsLocalOrFrom

@@ -172,7 +172,7 @@ This data type is used to help tie the knot
 
 \begin{code}
 data TyThingDetails = SynTyDetails Type
 
 \begin{code}
 data TyThingDetails = SynTyDetails Type

-                   | DataTyDetails ThetaType [DataCon] [Id]
+                   | DataTyDetails ThetaType (DataConDetails DataCon) [Id]

                    | ClassDetails ThetaType [Id] [ClassOpItem] DataCon
                    | ForeignTyDetails  -- Nothing yet
 \end{code}
                    | ClassDetails ThetaType [Id] [ClassOpItem] DataCon
                    | ForeignTyDetails  -- Nothing yet
 \end{code}

diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs
index 807787f..5101ab3 100644 (file)
--- a/ghc/compiler/typecheck/TcTyClsDecls.lhs
+++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs
@@ -35,7 +35,7 @@ import TcType         ( Type, Kind, TcKind, mkArrowKind, liftedTypeKind, zipFunTys )
 import Type            ( splitTyConApp_maybe )
 import Variance         ( calcTyConArgVrcs )
 import Class           ( Class, mkClass, classTyCon )
 import Type            ( splitTyConApp_maybe )
 import Variance         ( calcTyConArgVrcs )
 import Class           ( Class, mkClass, classTyCon )

-import TyCon           ( TyCon, ArgVrcs, AlgTyConFlavour(..), 
+import TyCon           ( TyCon, ArgVrcs, AlgTyConFlavour(..), DataConDetails(..), visibleDataCons,

                          tyConKind, tyConTyVars, tyConDataCons, isNewTyCon,
                          mkSynTyCon, mkAlgTyCon, mkClassTyCon, mkForeignTyCon, 
                        )
                          tyConKind, tyConTyVars, tyConDataCons, isNewTyCon,
                          mkSynTyCon, mkAlgTyCon, mkClassTyCon, mkForeignTyCon, 
                        )

@@ -267,7 +267,7 @@ kcTyClDecl (ForeignType {}) = returnTc ()
 kcTyClDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = context, tcdCons = con_decls})
   = kcTyClDeclBody decl                        $ \ result_kind ->
     kcHsContext context                        `thenTc_` 
 kcTyClDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = context, tcdCons = con_decls})
   = kcTyClDeclBody decl                        $ \ result_kind ->
     kcHsContext context                        `thenTc_` 

-    mapTc_ kc_con_decl con_decls
+    mapTc_ kc_con_decl (visibleDataCons con_decls)

   where
     kc_con_decl (ConDecl _ _ ex_tvs ex_ctxt details loc)
       = kcHsTyVars ex_tvs              `thenNF_Tc` \ kind_env ->
   where
     kc_con_decl (ConDecl _ _ ex_tvs ex_ctxt details loc)
       = kcHsTyVars ex_tvs              `thenNF_Tc` \ kind_env ->

@@ -327,12 +327,12 @@ buildTyConOrClass dflags is_rec kenv rec_vrcs rec_details
         argvrcs                    = lookupWithDefaultFM rec_vrcs bogusVrcs tycon
 
 buildTyConOrClass dflags is_rec kenv rec_vrcs  rec_details
         argvrcs                    = lookupWithDefaultFM rec_vrcs bogusVrcs tycon
 
 buildTyConOrClass dflags is_rec kenv rec_vrcs  rec_details

-                 (TyData {tcdND = data_or_new, tcdName = tycon_name, tcdTyVars = tyvar_names,
-                          tcdNCons = nconstrs, tcdSysNames = sys_names})
+                 (TyData {tcdND = data_or_new, tcdName = tycon_name, 
+                          tcdTyVars = tyvar_names, tcdSysNames = sys_names})

   = ATyCon tycon
   where
        tycon = mkAlgTyCon tycon_name tycon_kind tyvars ctxt argvrcs
   = ATyCon tycon
   where
        tycon = mkAlgTyCon tycon_name tycon_kind tyvars ctxt argvrcs

-                          data_cons nconstrs sel_ids
+                          data_cons sel_ids

                           flavour is_rec gen_info
 
        gen_info | not (dopt Opt_Generics dflags) = Nothing
                           flavour is_rec gen_info
 
        gen_info | not (dopt Opt_Generics dflags) = Nothing

@@ -348,8 +348,11 @@ buildTyConOrClass dflags is_rec kenv rec_vrcs  rec_details
        -- so flavour has to be able to answer this question without consulting rec_details
        flavour = case data_or_new of
                    NewType  -> NewTyCon (mkNewTyConRep tycon)
        -- so flavour has to be able to answer this question without consulting rec_details
        flavour = case data_or_new of
                    NewType  -> NewTyCon (mkNewTyConRep tycon)

-                   DataType | all (null . dataConOrigArgTys) data_cons -> EnumTyCon
-                            | otherwise                                -> DataTyCon
+                   DataType | all_nullary data_cons -> EnumTyCon
+                            | otherwise             -> DataTyCon
+
+       all_nullary (DataCons cons) = all (null . dataConOrigArgTys) cons
+       all_nullary other           = False     -- Safe choice for unknown data types

                        -- NB (null . dataConOrigArgTys).  It used to say isNullaryDataCon
                        -- but that looks at the *representation* arity, and that in turn
                        -- depends on deciding whether to unpack the args, and that 
                        -- NB (null . dataConOrigArgTys).  It used to say isNullaryDataCon
                        -- but that looks at the *representation* arity, and that in turn
                        -- depends on deciding whether to unpack the args, and that 

diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs
index f525f4e..0ed2fef 100644 (file)
--- a/ghc/compiler/typecheck/TcTyDecls.lhs
+++ b/ghc/compiler/typecheck/TcTyDecls.lhs
@@ -31,7 +31,9 @@ import FieldLabel
 import Var             ( TyVar, idType )
 import Name            ( Name, NamedThing(..) )
 import Outputable
 import Var             ( TyVar, idType )
 import Name            ( Name, NamedThing(..) )
 import Outputable

-import TyCon           ( TyCon, tyConName, tyConTheta, getSynTyConDefn, tyConTyVars, tyConDataCons, isSynTyCon )
+import TyCon           ( TyCon, DataConDetails(..), visibleDataCons,
+                         tyConName, tyConTheta, getSynTyConDefn, 
+                         tyConTyVars, tyConDataCons, isSynTyCon )

 import VarSet          ( intersectVarSet, isEmptyVarSet )
 import PrelNames       ( unpackCStringName, unpackCStringUtf8Name )
 import ListSetOps      ( equivClasses )
 import VarSet          ( intersectVarSet, isEmptyVarSet )
 import PrelNames       ( unpackCStringName, unpackCStringUtf8Name )
 import ListSetOps      ( equivClasses )

@@ -53,14 +55,14 @@ tcTyDecl unf_env (TySynonym {tcdName = tycon_name, tcdSynRhs = rhs})
     returnTc (tycon_name, SynTyDetails rhs_ty)
 
 tcTyDecl unf_env (TyData {tcdND = new_or_data, tcdCtxt = context,
     returnTc (tycon_name, SynTyDetails rhs_ty)
 
 tcTyDecl unf_env (TyData {tcdND = new_or_data, tcdCtxt = context,

-                                 tcdName = tycon_name, tcdCons = con_decls})
+                         tcdName = tycon_name, tcdCons = con_decls})

   = tcLookupTyCon tycon_name                   `thenNF_Tc` \ tycon ->
     let
        tyvars = tyConTyVars tycon
     in
     tcExtendTyVarEnv tyvars                            $
   = tcLookupTyCon tycon_name                   `thenNF_Tc` \ tycon ->
     let
        tyvars = tyConTyVars tycon
     in
     tcExtendTyVarEnv tyvars                            $

-    tcHsTheta context                                          `thenTc` \ ctxt ->
-    mapTc (tcConDecl new_or_data tycon tyvars ctxt) con_decls  `thenTc` \ data_cons ->
+    tcHsTheta context                                  `thenTc` \ ctxt ->
+    tcConDecls new_or_data tycon tyvars ctxt con_decls `thenTc` \ data_cons ->

     let
        sel_ids = mkRecordSelectors unf_env tycon data_cons
     in
     let
        sel_ids = mkRecordSelectors unf_env tycon data_cons
     in

@@ -76,7 +78,8 @@ mkRecordSelectors unf_env tycon data_cons
      [ mkRecordSelId tycon field unpack_id unpackUtf8_id
      | field <- nubBy eq_name fields ]
   where
      [ mkRecordSelId tycon field unpack_id unpackUtf8_id
      | field <- nubBy eq_name fields ]
   where

-    fields = [ field | con <- data_cons, field <- dataConFieldLabels con ]
+    fields = [ field | con <- visibleDataCons data_cons, 
+                      field <- dataConFieldLabels con ]

     eq_name field1 field2 = fieldLabelName field1 == fieldLabelName field2
 
     unpack_id     = tcLookupRecId unf_env unpackCStringName
     eq_name field1 field2 = fieldLabelName field1 == fieldLabelName field2
 
     unpack_id     = tcLookupRecId unf_env unpackCStringName

@@ -155,49 +158,59 @@ kcConDetails new_or_data ex_ctxt details
            -- going to remove the constructor while coercing it to a lifted type.
 
 
            -- going to remove the constructor while coercing it to a lifted type.
 
 

-tcConDecl :: NewOrData -> TyCon -> [TyVar] -> ThetaType -> RenamedConDecl -> TcM DataCon
-tcConDecl new_or_data tycon tyvars ctxt (ConDecl name wkr_name ex_tvs ex_ctxt details src_loc)
-  = tcAddSrcLoc src_loc                                                        $
-    tcHsTyVars ex_tvs (kcConDetails new_or_data ex_ctxt details)       $ \ ex_tyvars ->
-    tcHsTheta ex_ctxt                                                  `thenTc` \ ex_theta ->
-    case details of
-       VanillaCon btys    -> tc_datacon ex_tyvars ex_theta btys
-       InfixCon bty1 bty2 -> tc_datacon ex_tyvars ex_theta [bty1,bty2]
-       RecCon fields      -> tc_rec_con ex_tyvars ex_theta fields
+tcConDecls :: NewOrData -> TyCon -> [TyVar] -> ThetaType 
+          -> DataConDetails RenamedConDecl -> TcM (DataConDetails DataCon)
+
+tcConDecls new_or_data tycon tyvars ctxt con_decls
+  = case con_decls of
+       Unknown     -> returnTc Unknown
+       HasCons n   -> returnTc (HasCons n)
+       DataCons cs -> mapTc tc_con_decl cs     `thenTc` \ data_cons ->
+                      returnTc (DataCons data_cons)

   where
   where

-    tc_datacon ex_tyvars ex_theta btys
-      = mapTc tcHsType (map getBangType btys)  `thenTc` \ arg_tys ->
-       mk_data_con ex_tyvars ex_theta (map getBangStrictness btys) arg_tys []
-
-    tc_rec_con ex_tyvars ex_theta fields
-      = checkTc (null ex_tyvars) (exRecConErr name)    `thenTc_`
-       mapTc tc_field (fields `zip` allFieldLabelTags) `thenTc` \ field_labels_s ->
-       let
-           field_labels = concat field_labels_s
-           arg_stricts = [str | (ns, bty) <- fields, 
-                                let str = getBangStrictness bty, 
-                                n <- ns        -- One for each.  E.g   x,y,z :: !Int
-                         ]
-       in
-       mk_data_con ex_tyvars ex_theta arg_stricts 
-                   (map fieldLabelType field_labels) field_labels
-
-    tc_field ((field_label_names, bty), tag)
-      = tcHsType (getBangType bty)                     `thenTc` \ field_ty ->
-       returnTc [mkFieldLabel (getName name) tycon field_ty tag | name <- field_label_names]
-
-    mk_data_con ex_tyvars ex_theta arg_stricts arg_tys fields
-      = let
-          data_con = mkDataCon name arg_stricts fields
-                          tyvars (thinContext arg_tys ctxt)
-                          ex_tyvars ex_theta
-                          arg_tys
-                          tycon data_con_id data_con_wrap_id
-
-          data_con_id      = mkDataConId wkr_name data_con
-          data_con_wrap_id = mkDataConWrapId data_con
-       in
-       returnNF_Tc data_con
+    tc_con_decl (ConDecl name wkr_name ex_tvs ex_ctxt details src_loc)
+      = tcAddSrcLoc src_loc                                            $
+       tcHsTyVars ex_tvs (kcConDetails new_or_data ex_ctxt details)    $ \ ex_tyvars ->
+       tcHsTheta ex_ctxt                                               `thenTc` \ ex_theta ->
+       case details of
+           VanillaCon btys    -> tc_datacon ex_tyvars ex_theta btys
+           InfixCon bty1 bty2 -> tc_datacon ex_tyvars ex_theta [bty1,bty2]
+           RecCon fields      -> tc_rec_con ex_tyvars ex_theta fields
+      where
+       
+       tc_datacon ex_tyvars ex_theta btys
+         = mapTc tcHsType (map getBangType btys)       `thenTc` \ arg_tys ->
+           mk_data_con ex_tyvars ex_theta (map getBangStrictness btys) arg_tys []
+    
+       tc_rec_con ex_tyvars ex_theta fields
+         = checkTc (null ex_tyvars) (exRecConErr name) `thenTc_`
+           mapTc tc_field (fields `zip` allFieldLabelTags)     `thenTc` \ field_labels_s ->
+           let
+               field_labels = concat field_labels_s
+               arg_stricts = [str | (ns, bty) <- fields, 
+                                    let str = getBangStrictness bty, 
+                                    n <- ns    -- One for each.  E.g   x,y,z :: !Int
+                             ]
+           in
+           mk_data_con ex_tyvars ex_theta arg_stricts 
+                       (map fieldLabelType field_labels) field_labels
+    
+       tc_field ((field_label_names, bty), tag)
+         = tcHsType (getBangType bty)                  `thenTc` \ field_ty ->
+           returnTc [mkFieldLabel (getName name) tycon field_ty tag | name <- field_label_names]
+    
+       mk_data_con ex_tyvars ex_theta arg_stricts arg_tys fields
+         = let
+              data_con = mkDataCon name arg_stricts fields
+                              tyvars (thinContext arg_tys ctxt)
+                              ex_tyvars ex_theta
+                              arg_tys
+                              tycon data_con_id data_con_wrap_id
+    
+              data_con_id      = mkDataConId wkr_name data_con
+              data_con_wrap_id = mkDataConWrapId data_con
+           in
+           returnNF_Tc data_con

 
 -- The context for a data constructor should be limited to
 -- the type variables mentioned in the arg_tys
 
 -- The context for a data constructor should be limited to
 -- the type variables mentioned in the arg_tys

diff --git a/ghc/compiler/types/Generics.lhs b/ghc/compiler/types/Generics.lhs
index 8afbc4b..0f262d0 100644 (file)
--- a/ghc/compiler/types/Generics.lhs
+++ b/ghc/compiler/types/Generics.lhs
@@ -15,7 +15,7 @@ import Type             ( Type, isUnLiftedType, tyVarsOfType, tyVarsOfTypes,
 import TcType          ( tcSplitTyConApp_maybe, tcSplitSigmaTy, tcSplitSigmaTy )
 import DataCon          ( DataCon, dataConOrigArgTys, dataConWrapId, dataConId, isExistentialDataCon )
 
 import TcType          ( tcSplitTyConApp_maybe, tcSplitSigmaTy, tcSplitSigmaTy )
 import DataCon          ( DataCon, dataConOrigArgTys, dataConWrapId, dataConId, isExistentialDataCon )
 

-import TyCon            ( TyCon, tyConTyVars, tyConDataConsIfAvailable, 
+import TyCon            ( TyCon, tyConTyVars, tyConDataCons_maybe, 

                          tyConGenInfo, isNewTyCon, newTyConRep, isBoxedTupleTyCon
                        )
 import Name            ( Name, mkSysLocalName )
                          tyConGenInfo, isNewTyCon, newTyConRep, isBoxedTupleTyCon
                        )
 import Name            ( Name, mkSysLocalName )

@@ -35,6 +35,7 @@ import TysWiredIn       ( genericTyCons,
 import IdInfo           ( noCafNoTyGenIdInfo, setUnfoldingInfo, setArityInfo )
 import CoreUnfold       ( mkTopUnfolding ) 
 
 import IdInfo           ( noCafNoTyGenIdInfo, setUnfoldingInfo, setArityInfo )
 import CoreUnfold       ( mkTopUnfolding ) 
 

+import Maybe           ( isNothing )

 import SrcLoc          ( builtinSrcLoc )
 import Unique          ( mkBuiltinUnique )
 import Util             ( takeList )
 import SrcLoc          ( builtinSrcLoc )
 import Unique          ( mkBuiltinUnique )
 import Util             ( takeList )

@@ -238,8 +239,8 @@ mkTyConGenInfo :: TyCon -> [Name] -> Maybe (EP Id)
 -- for the fromT and toT conversion functions.
 
 mkTyConGenInfo tycon [from_name, to_name]
 -- for the fromT and toT conversion functions.
 
 mkTyConGenInfo tycon [from_name, to_name]

-  | null datacons      -- Abstractly imported types don't have
-  = Nothing            -- to/from operations, (and should not need them)
+  | isNothing maybe_datacons   -- Abstractly imported types don't have
+  = Nothing                    -- to/from operations, (and should not need them)

 
        -- If any of the constructor has an unboxed type as argument,
        -- then we can't build the embedding-projection pair, because
 
        -- If any of the constructor has an unboxed type as argument,
        -- then we can't build the embedding-projection pair, because

@@ -254,10 +255,12 @@ mkTyConGenInfo tycon [from_name, to_name]
   = Just (EP { fromEP = mkVanillaGlobal from_name from_ty from_id_info,
               toEP   = mkVanillaGlobal to_name   to_ty   to_id_info })
   where
   = Just (EP { fromEP = mkVanillaGlobal from_name from_ty from_id_info,
               toEP   = mkVanillaGlobal to_name   to_ty   to_id_info })
   where

-    tyvars      = tyConTyVars tycon                    -- [a, b, c]
-    datacons    = tyConDataConsIfAvailable tycon       -- [C, D]
-    tycon_ty    = mkTyConApp tycon tyvar_tys           -- T a b c
-    tyvar_tys    = mkTyVarTys tyvars
+    maybe_datacons = tyConDataCons_maybe tycon
+    Just datacons  = maybe_datacons            -- [C, D]
+
+    tyvars        = tyConTyVars tycon          -- [a, b, c]
+    tycon_ty      = mkTyConApp tycon tyvar_tys -- T a b c
+    tyvar_tys      = mkTyVarTys tyvars

 
     from_id_info = noCafNoTyGenIdInfo `setUnfoldingInfo` mkTopUnfolding from_fn
                                      `setArityInfo`     exprArity from_fn
 
     from_id_info = noCafNoTyGenIdInfo `setUnfoldingInfo` mkTopUnfolding from_fn
                                      `setArityInfo`     exprArity from_fn

diff --git a/ghc/compiler/types/TyCon.lhs b/ghc/compiler/types/TyCon.lhs
index 10158c5..8a03de1 100644 (file)
--- a/ghc/compiler/types/TyCon.lhs
+++ b/ghc/compiler/types/TyCon.lhs
@@ -5,7 +5,10 @@
 
 \begin{code}
 module TyCon(
 
 \begin{code}
 module TyCon(

-       TyCon, KindCon, SuperKindCon, ArgVrcs, AlgTyConFlavour(..),
+       TyCon, KindCon, SuperKindCon, ArgVrcs, 
+
+       AlgTyConFlavour(..), 
+       DataConDetails(..), visibleDataCons,

 
        isFunTyCon, isUnLiftedTyCon, isBoxedTyCon, isProductTyCon,
        isAlgTyCon, isDataTyCon, isSynTyCon, isNewTyCon, isPrimTyCon,
 
        isFunTyCon, isUnLiftedTyCon, isBoxedTyCon, isProductTyCon,
        isAlgTyCon, isDataTyCon, isSynTyCon, isNewTyCon, isPrimTyCon,

@@ -15,7 +18,7 @@ module TyCon(
 
        mkForeignTyCon, isForeignTyCon,
 
 
        mkForeignTyCon, isForeignTyCon,
 

-       mkAlgTyCon, --mkAlgTyCon, 
+       mkAlgTyCon,

        mkClassTyCon,
        mkFunTyCon,
        mkPrimTyCon,
        mkClassTyCon,
        mkFunTyCon,
        mkPrimTyCon,

@@ -32,7 +35,7 @@ module TyCon(
        tyConUnique,
        tyConTyVars,
        tyConArgVrcs_maybe,
        tyConUnique,
        tyConTyVars,
        tyConArgVrcs_maybe,

-       tyConDataCons, tyConDataConsIfAvailable, tyConFamilySize,
+       tyConDataConDetails, tyConDataCons, tyConDataCons_maybe, tyConFamilySize,

        tyConSelIds,
        tyConTheta,
        tyConPrimRep,
        tyConSelIds,
        tyConTheta,
        tyConPrimRep,

@@ -65,6 +68,7 @@ import Name           ( Name, nameUnique, NamedThing(getName) )
 import PrelNames       ( Unique, Uniquable(..), anyBoxConKey )
 import PrimRep         ( PrimRep(..), isFollowableRep )
 import Util             ( lengthIs )
 import PrelNames       ( Unique, Uniquable(..), anyBoxConKey )
 import PrimRep         ( PrimRep(..), isFollowableRep )
 import Util             ( lengthIs )

+import Maybes          ( expectJust )

 import Outputable
 import FastString
 \end{code}
 import Outputable
 import FastString
 \end{code}

@@ -99,25 +103,10 @@ data TyCon
        tyConArgVrcs  :: ArgVrcs,
        algTyConTheta :: [PredType],
 
        tyConArgVrcs  :: ArgVrcs,
        algTyConTheta :: [PredType],
 

-       dataCons :: [DataCon],
-               -- Its data constructors, with fully polymorphic types
-               --      This list can be empty, when we import a data type
-               --      abstractly, either
-               --           (a) the interface is hand-written and doesn't give
-               --               the constructors, or
-               --           (b) in a quest for fast compilation we don't import 
-               --               the constructors
+       dataCons :: DataConDetails DataCon,

 
        selIds :: [Id], -- Its record selectors (if any)
 
 
        selIds :: [Id], -- Its record selectors (if any)
 

-       noOfDataCons :: Int,
-               -- Number of data constructors.  Usually this is the
-               -- same as the length of the dataCons field, but the
-               -- latter may be empty if we imported the type
-               -- abstractly.  But even if we import abstractly we
-               -- still need to know the number of constructors so we
-               -- can get the return convention right.  Tiresome!
-

        algTyConFlavour :: AlgTyConFlavour,
        algTyConRec     :: RecFlag,     -- Tells whether the data type is part of 
                                        -- a mutually-recursive group or not
        algTyConFlavour :: AlgTyConFlavour,
        algTyConRec     :: RecFlag,     -- Tells whether the data type is part of 
                                        -- a mutually-recursive group or not

@@ -202,8 +191,23 @@ data AlgTyConFlavour
                        -- The rep type isn't entirely simple:
                        --  for a recursive newtype we pick () as the rep type
                        --      newtype T = MkT T
                        -- The rep type isn't entirely simple:
                        --  for a recursive newtype we pick () as the rep type
                        --      newtype T = MkT T

+
+data DataConDetails datacon
+  = DataCons [datacon] -- Its data constructors, with fully polymorphic types
+                       -- A type can have zero constructors
+
+  | Unknown            -- We're importing this data type from an hi-boot file
+                       -- and we don't know what its constructors are
+
+  | HasCons Int                -- In a quest for compilation speed we have imported
+                       -- only the number of constructors (to get return 
+                       -- conventions right) but not the constructors themselves
+
+visibleDataCons (DataCons cs) = cs
+visibleDataCons other        = []

 \end{code}
 
 \end{code}
 

+

 %************************************************************************
 %*                                                                     *
 \subsection{TyCon Construction}
 %************************************************************************
 %*                                                                     *
 \subsection{TyCon Construction}

@@ -255,7 +259,7 @@ tyConGenIds tycon = case tyConGenInfo tycon of
 -- This is the making of a TyCon. Just the same as the old mkAlgTyCon,
 -- but now you also have to pass in the generic information about the type
 -- constructor - you can get hold of it easily (see Generics module)
 -- This is the making of a TyCon. Just the same as the old mkAlgTyCon,
 -- but now you also have to pass in the generic information about the type
 -- constructor - you can get hold of it easily (see Generics module)

-mkAlgTyCon name kind tyvars theta argvrcs cons ncons sels flavour rec 
+mkAlgTyCon name kind tyvars theta argvrcs cons sels flavour rec 

              gen_info
   = AlgTyCon { 
        tyConName               = name,
              gen_info
   = AlgTyCon { 
        tyConName               = name,

@@ -267,7 +271,6 @@ mkAlgTyCon name kind tyvars theta argvrcs cons ncons sels flavour rec
        algTyConTheta           = theta,
        dataCons                = cons, 
        selIds                  = sels,
        algTyConTheta           = theta,
        dataCons                = cons, 
        selIds                  = sels,

-       noOfDataCons            = ncons,

        algTyConClass           = Nothing,
        algTyConFlavour         = flavour,
        algTyConRec             = rec,
        algTyConClass           = Nothing,
        algTyConFlavour         = flavour,
        algTyConRec             = rec,

@@ -283,9 +286,8 @@ mkClassTyCon name kind tyvars argvrcs con clas flavour rec
        tyConTyVars             = tyvars,
        tyConArgVrcs            = argvrcs,
        algTyConTheta           = [],
        tyConTyVars             = tyvars,
        tyConArgVrcs            = argvrcs,
        algTyConTheta           = [],

-       dataCons                = [con],
+       dataCons                = DataCons [con],

        selIds                  = [],
        selIds                  = [],

-       noOfDataCons            = 1,

        algTyConClass           = Just clas,
        algTyConFlavour         = flavour,
        algTyConRec             = rec,
        algTyConClass           = Just clas,
        algTyConFlavour         = flavour,
        algTyConRec             = rec,

@@ -408,9 +410,9 @@ newTyConRep (AlgTyCon {tyConTyVars = tvs, algTyConFlavour = NewTyCon rep}) = (tv
 --     may be  DataType or NewType, 
 --     may be  unboxed or not, 
 --     may be  recursive or not
 --     may be  DataType or NewType, 
 --     may be  unboxed or not, 
 --     may be  recursive or not

-isProductTyCon (AlgTyCon {dataCons = [data_con]}) = not (isExistentialDataCon data_con)
-isProductTyCon (TupleTyCon {})                           = True
-isProductTyCon other                             = False
+isProductTyCon (AlgTyCon {dataCons = DataCons [data_con]}) = not (isExistentialDataCon data_con)
+isProductTyCon (TupleTyCon {})                                    = True   
+isProductTyCon other                                      = False

 
 isSynTyCon (SynTyCon {}) = True
 isSynTyCon _            = False
 
 isSynTyCon (SynTyCon {}) = True
 isSynTyCon _            = False

@@ -442,22 +444,23 @@ isForeignTyCon other                                    = False
 \end{code}
 
 \begin{code}
 \end{code}
 
 \begin{code}

+tyConDataConDetails :: TyCon -> DataConDetails DataCon
+tyConDataConDetails (AlgTyCon {dataCons = cons}) = cons
+tyConDataConDetails (TupleTyCon {dataCon = con}) = DataCons [con]
+tyConDataConDetails other                       = Unknown
+

 tyConDataCons :: TyCon -> [DataCon]
 tyConDataCons :: TyCon -> [DataCon]

-tyConDataCons tycon = ASSERT2( cons `lengthIs` (tyConFamilySize tycon), ppr tycon )
-                     cons
-                   where
-                     cons = tyConDataConsIfAvailable tycon
-
-tyConDataConsIfAvailable (AlgTyCon {dataCons = cons}) = cons   -- Empty for abstract types
-tyConDataConsIfAvailable (TupleTyCon {dataCon = con}) = [con]
-tyConDataConsIfAvailable other                       = []
-       -- You may think this last equation should fail,
-       -- but it's quite convenient to return no constructors for
-       -- a synonym; see for example the call in TcTyClsDecls.
+tyConDataCons tycon = expectJust "tyConDataCons" (tyConDataCons_maybe tycon)
+
+tyConDataCons_maybe :: TyCon -> Maybe [DataCon]
+tyConDataCons_maybe (AlgTyCon {dataCons = DataCons cons}) = Just cons
+tyConDataCons_maybe (TupleTyCon {dataCon = con})         = Just [con]
+tyConDataCons_maybe other                                = Nothing

 
 tyConFamilySize  :: TyCon -> Int
 
 tyConFamilySize  :: TyCon -> Int

-tyConFamilySize (AlgTyCon {noOfDataCons = n}) = n
-tyConFamilySize (TupleTyCon {})              = 1
+tyConFamilySize (AlgTyCon {dataCons = DataCons cs}) = length cs
+tyConFamilySize (AlgTyCon {dataCons = HasCons n})   = n
+tyConFamilySize (TupleTyCon {})                    = 1

 #ifdef DEBUG
 tyConFamilySize other = pprPanic "tyConFamilySize:" (ppr other)
 #endif
 #ifdef DEBUG
 tyConFamilySize other = pprPanic "tyConFamilySize:" (ppr other)
 #endif

@@ -505,13 +508,12 @@ getSynTyConDefn (SynTyCon {tyConTyVars = tyvars, synTyConDefn = ty}) = (tyvars,t
 
 \begin{code}
 maybeTyConSingleCon :: TyCon -> Maybe DataCon
 
 \begin{code}
 maybeTyConSingleCon :: TyCon -> Maybe DataCon

-maybeTyConSingleCon (AlgTyCon {dataCons = [c]})  = Just c
-maybeTyConSingleCon (AlgTyCon {})               = Nothing
-maybeTyConSingleCon (TupleTyCon {dataCon = con}) = Just con
-maybeTyConSingleCon (PrimTyCon {})               = Nothing
-maybeTyConSingleCon (FunTyCon {})                = Nothing  -- case at funty
-maybeTyConSingleCon tc = pprPanic "maybeTyConSingleCon: unexpected tycon " $
-                         ppr tc
+maybeTyConSingleCon (AlgTyCon {dataCons = DataCons [c]})  = Just c
+maybeTyConSingleCon (AlgTyCon {})                        = Nothing
+maybeTyConSingleCon (TupleTyCon {dataCon = con})         = Just con
+maybeTyConSingleCon (PrimTyCon {})                       = Nothing
+maybeTyConSingleCon (FunTyCon {})                        = Nothing  -- case at funty
+maybeTyConSingleCon tc = pprPanic "maybeTyConSingleCon: unexpected tycon " $ ppr tc

 \end{code}
 
 \begin{code}
 \end{code}
 
 \begin{code}

diff --git a/ghc/compiler/types/Variance.lhs b/ghc/compiler/types/Variance.lhs
index ffc96d5..5f4b3f6 100644 (file)
--- a/ghc/compiler/types/Variance.lhs
+++ b/ghc/compiler/types/Variance.lhs
@@ -12,7 +12,7 @@ module Variance(
 #include "HsVersions.h"
 
 import TypeRep          ( Type(..), TyNote(..) )  -- friend
 #include "HsVersions.h"
 
 import TypeRep          ( Type(..), TyNote(..) )  -- friend

-import TyCon            ( TyCon, ArgVrcs, tyConArity, tyConDataConsIfAvailable, tyConTyVars,
+import TyCon            ( TyCon, ArgVrcs, tyConArity, tyConDataCons_maybe, tyConDataCons, tyConTyVars,

                           tyConArgVrcs_maybe, getSynTyConDefn, isSynTyCon, isAlgTyCon )
 import DataCon          ( dataConRepArgTys )
 
                           tyConArgVrcs_maybe, getSynTyConDefn, isSynTyCon, isAlgTyCon )
 import DataCon          ( dataConRepArgTys )
 

@@ -20,6 +20,7 @@ import FiniteMap
 import Var              ( TyVar )
 import VarSet
 import Maybes           ( expectJust )
 import Var              ( TyVar )
 import VarSet
 import Maybes           ( expectJust )

+import Maybe           ( isNothing )

 import Outputable
 \end{code}
 
 import Outputable
 \end{code}
 

@@ -47,7 +48,7 @@ calcTyConArgVrcs tycons
 
     initial_oi :: FiniteMap TyCon ArgVrcs
     initial_oi   = foldl (\fm tc -> addToFM fm tc (initial tc)) emptyFM tycons
 
     initial_oi :: FiniteMap TyCon ArgVrcs
     initial_oi   = foldl (\fm tc -> addToFM fm tc (initial tc)) emptyFM tycons

-    initial tc   = if isAlgTyCon tc && null (tyConDataConsIfAvailable tc) then
+    initial tc   = if isAlgTyCon tc && isNothing (tyConDataCons_maybe tc) then

                          -- make pessimistic assumption (and warn)
                          abstractVrcs tc
                        else
                          -- make pessimistic assumption (and warn)
                          abstractVrcs tc
                        else

@@ -79,7 +80,7 @@ calcTyConArgVrcs tycons
             map (\v -> anyVrc (\ty -> vrcInTy myfao v ty) argtys)
                 vs
       where
             map (\v -> anyVrc (\ty -> vrcInTy myfao v ty) argtys)
                 vs
       where

-               data_cons = tyConDataConsIfAvailable tc
+               data_cons = tyConDataCons tc

                vs        = tyConTyVars tc
                argtys    = concatMap dataConRepArgTys data_cons
                myfao tc  = lookupWithDefaultFM oi (expectJust "tcaoIter(Alg)" $
                vs        = tyConTyVars tc
                argtys    = concatMap dataConRepArgTys data_cons
                myfao tc  = lookupWithDefaultFM oi (expectJust "tcaoIter(Alg)" $