Commit 711e4d7a authored by simonpj's avatar simonpj
Browse files

[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.
parent e7030995
......@@ -30,7 +30,7 @@ import Type ( Type, ThetaType,
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 )
......@@ -399,7 +399,7 @@ splitProductType_maybe ty
-- 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
......
{-# 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
--
......@@ -30,7 +30,7 @@ import Util
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 )
......@@ -680,8 +680,8 @@ browseModule m exports_only = do
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
......
......@@ -42,6 +42,7 @@ import ForeignCall ( CCallTarget(..), DNCallSpec, CCallConv, Safety,
-- others:
import Name ( NamedThing )
import FunDeps ( pprFundeps )
import TyCon ( DataConDetails(..), visibleDataCons )
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
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
......@@ -376,7 +376,7 @@ tyClDeclSysNames :: TyClDecl name pat -> [(name, SrcLoc)]
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 = []
......@@ -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) &&
eqListBy (eq_ConDecl env) (tcdCons d1) (tcdCons d2)
eq_hsCD env (tcdCons d1) (tcdCons d2)
)
(==) d1@(TySynonym {}) d2@(TySynonym {})
......@@ -424,6 +424,11 @@ instance (NamedThing name, Ord name) => Eq (TyClDecl name pat) where
(==) _ _ = 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
......@@ -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,
tcdTyVars = tyvars, tcdCons = condecls, tcdNCons = ncons,
tcdTyVars = tyvars, tcdCons = condecls,
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
......@@ -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_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 [
......@@ -554,12 +560,12 @@ data ConDetails name
\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
= 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
......
......@@ -9,6 +9,7 @@ module HscStats ( ppSourceStats ) where
#include "HsVersions.h"
import HsSyn
import TyCon ( DataConDetails(..) )
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)
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 {})
......
......@@ -65,7 +65,7 @@ import Rules ( RuleBase )
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 )
......@@ -371,7 +371,7 @@ implicitTyThingIds things
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
......
......@@ -199,8 +199,7 @@ ifaceTyThing (ATyCon tycon) = ty_decl
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 }
......@@ -217,8 +216,7 @@ ifaceTyThing (ATyCon tycon) = ty_decl
tcdCtxt = [],
tcdName = getName tycon,
tcdTyVars = toHsTyVars (take (tyConArity tycon) alphaTyVars),
tcdCons = [],
tcdNCons = 0,
tcdCons = Unknown,
tcdDerivs = Nothing,
tcdSysNames = [],
tcdLoc = noSrcLoc }
......@@ -230,6 +228,10 @@ ifaceTyThing (ATyCon tycon) = ty_decl
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)
......
{- -*-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.
......@@ -25,6 +25,7 @@ import ForeignCall ( Safety(..), CExportSpec(..),
CCallConv(..), CCallTarget(..), defaultCCallConv,
)
import OccName ( UserFS, varName, tcName, dataName, tcClsName, tvName )
import TyCon ( DataConDetails(..) )
import SrcLoc ( SrcLoc )
import Module
import CmdLineOpts ( opt_SccProfilingOn )
......@@ -357,11 +358,11 @@ topdecl :: { RdrBinding }
| 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
(mkTyData NewType $3 [$5] 1 $6 $1))) }
(mkTyData NewType $3 (DataCons [$5]) $6 $1))) }
| srcloc 'class' tycl_hdr fds where
{% let
......
......@@ -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)
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,
tcdTyVars = tyvars, tcdCons = list_con, tcdNCons = i,
tcdTyVars = tyvars, tcdCons = data_cons,
tcdDerivs = maybe, tcdLoc = src, tcdSysNames = [name1, name2] }
mkClassOpSigDM op ty loc
......
......@@ -32,13 +32,14 @@ import Literal ( Literal(..), isLitLitLit, mkMachInt, mkMachWord
)
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 Maybes ( orElse )
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 )
case filter correct_tag (tyConDataConsIfAvailable tycon) of
case filter correct_tag (tyConDataCons_maybe tycon `orElse` []) of
[] -> Nothing -- Abstract type
......
......@@ -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 TyCon ( TyCon, AlgTyConFlavour(..), tyConDataCons,
import TyCon ( TyCon, AlgTyConFlavour(..), DataConDetails(..), tyConDataCons,
mkTupleTyCon, mkAlgTyCon, tyConName
)
......@@ -165,8 +165,7 @@ pcTyCon new_or_data is_rec name tyvars argvrcs cons
tyvars
[] -- No context
argvrcs
cons
(length cons)
(DataCons cons)
[] -- No record selectors
new_or_data
is_rec
......@@ -575,11 +574,10 @@ parrTyCon = tycon
parrTyConName
kind
tyvars
[] -- No context
[] -- No context
[(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
......
......@@ -52,6 +52,7 @@ import HscTypes ( WhetherHasOrphans, IsBootInterface, GenAvailInfo(..),
RdrAvailInfo )
import RdrName ( RdrName, mkRdrUnqual, mkIfaceOrig )
import TyCon ( DataConDetails(..) )
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
{ mkTyData DataType $3 $4 (length $4) Nothing $1 }
{ mkTyData DataType $3 $4 Nothing $1 }
| 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 }
......@@ -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] }
......@@ -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 ()
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 '}'
{ [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 : { ([],[]) }
......
......@@ -11,6 +11,7 @@ module RnHsSyn where
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
......@@ -131,9 +132,9 @@ tyClDeclFVs (IfaceSig {tcdType = ty, tcdIdInfo = id_infos})
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)
......
......@@ -39,7 +39,7 @@ import IdInfo ( GlobalIdDetails(..) )
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(..)
......@@ -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})
= delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) cons)
= delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt)
(visibleDataCons cons))
(hsTyVarNames tvs)
`addOneToNameSet` tycon
where
......
......@@ -32,6 +32,7 @@ import RnEnv ( lookupTopBndrRn, lookupOccRn, lookupIfaceName,
import RnMonad
import Class ( FunDep, DefMeth (..) )
import TyCon ( DataConDetails(..), visibleDataCons )
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,
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' ->
......@@ -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_`
-- 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',
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)
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')
......@@ -458,6 +449,23 @@ finishSourceTyClDecl _ tycl_decl = returnRn (tycl_decl, emptyFVs)
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 $
......
......@@ -41,7 +41,7 @@ import Type ( Type, seqType, splitRepFunTys, isStrictType,
)
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 )
......@@ -405,10 +405,10 @@ canUpdateInPlace ty
| 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}
......@@ -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!
[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_`
......
......@@ -49,7 +49,7 @@ import Id ( isDataConWrapId_maybe )
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
......@@ -172,7 +172,7 @@ This data type is used to help tie the knot
\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}
......
......@@ -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 TyCon ( TyCon, ArgVrcs, AlgTyConFlavour(..),
import TyCon ( TyCon, ArgVrcs, AlgTyConFlavour(..), DataConDetails(..), visibleDataCons,
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_`
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 ->
......@@ -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
(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
data_cons nconstrs sel_ids
data_cons sel_ids
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)
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
......
......@@ -31,7 +31,9 @@ import FieldLabel
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 )
......@@ -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,
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 $
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
......@@ -76,7 +78,8 @@ mkRecordSelectors unf_env tycon data_cons
[ 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
......@@ -155,49 +158,59 @@ kcConDetails new_or_data ex_ctxt details
-- 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
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
]