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 )
-- 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
--
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 )
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
-- others:
import Name ( NamedThing )
import FunDeps ( pprFundeps )
+import TyCon ( DataConDetails(..), visibleDataCons )
import Class ( FunDep, DefMeth(..) )
import CStrings ( CLabelString )
import Outputable
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
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 = []
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 {})
(==) _ _ = 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
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
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 [
\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
#include "HsVersions.h"
import HsSyn
+import TyCon ( DataConDetails(..) )
import Outputable
import Char ( isSpace )
import Util ( count )
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 {})
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 )
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
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 }
tcdCtxt = [],
tcdName = getName tycon,
tcdTyVars = toHsTyVars (take (tyConArity tycon) alphaTyVars),
- tcdCons = [],
- tcdNCons = 0,
+ tcdCons = Unknown,
tcdDerivs = Nothing,
tcdSysNames = [],
tcdLoc = noSrcLoc }
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.
CCallConv(..), CCallTarget(..), defaultCCallConv,
)
import OccName ( UserFS, varName, tcName, dataName, tcClsName, tvName )
+import TyCon ( DataConDetails(..) )
import SrcLoc ( SrcLoc )
import Module
import CmdLineOpts ( opt_SccProfilingOn )
| 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
-- 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
)
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
\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
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
)
tyvars
[] -- No context
argvrcs
- cons
- (length cons)
+ (DataCons cons)
[] -- No record selectors
new_or_data
is_rec
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
RdrAvailInfo )
import RdrName ( RdrName, mkRdrUnqual, mkIfaceOrig )
+import TyCon ( DataConDetails(..) )
import Name ( OccName )
import OccName ( mkSysOccFS,
tcName, varName, dataName, clsName, tvName,
| 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 }
----------------------------------------------------------------------------
-constrs :: { [RdrNameConDecl] {- empty for handwritten abstract -} }
- : { [] }
- | '=' constrs1 { $2 }
+constrs :: { DataConDetails RdrNameConDecl }
+ : { Unknown }
+ | '=' { DataCons [] }
+ | '=' constrs1 { DataCons $2 }
constrs1 :: { [RdrNameConDecl] }
constrs1 : constr { [$1] }
| 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 : { ([],[]) }
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
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)
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(..)
-- 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
import RnMonad
import Class ( FunDep, DefMeth (..) )
+import TyCon ( DataConDetails(..), visibleDataCons )
import DataCon ( dataConId )
import Name ( Name, NamedThing(..) )
import NameSet
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' ->
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')
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 $
)
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 )
| 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}
-- 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_`
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
\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}
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,
)
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 ->
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
-- 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
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 )
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
[ 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
-- 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
- ]
- 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
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 )
import IdInfo ( noCafNoTyGenIdInfo, setUnfoldingInfo, setArityInfo )
import CoreUnfold ( mkTopUnfolding )
+import Maybe ( isNothing )
import SrcLoc ( builtinSrcLoc )
import Unique ( mkBuiltinUnique )
import Util ( takeList )
-- 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
= 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
\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,
mkForeignTyCon, isForeignTyCon,
- mkAlgTyCon, --mkAlgTyCon,
+ mkAlgTyCon,
mkClassTyCon,
mkFunTyCon,
mkPrimTyCon,
tyConUnique,
tyConTyVars,
tyConArgVrcs_maybe,
- tyConDataCons, tyConDataConsIfAvailable, tyConFamilySize,
+ tyConDataConDetails, tyConDataCons, tyConDataCons_maybe, tyConFamilySize,
tyConSelIds,
tyConTheta,
tyConPrimRep,
import PrelNames ( Unique, Uniquable(..), anyBoxConKey )
import PrimRep ( PrimRep(..), isFollowableRep )
import Util ( lengthIs )
+import Maybes ( expectJust )
import Outputable
import FastString
\end{code}
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)
- 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
-- 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}
+
%************************************************************************
%* *
\subsection{TyCon Construction}
-- 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,
algTyConTheta = theta,
dataCons = cons,
selIds = sels,
- noOfDataCons = ncons,
algTyConClass = Nothing,
algTyConFlavour = flavour,
algTyConRec = rec,
tyConTyVars = tyvars,
tyConArgVrcs = argvrcs,
algTyConTheta = [],
- dataCons = [con],
+ dataCons = DataCons [con],
selIds = [],
- noOfDataCons = 1,
algTyConClass = Just clas,
algTyConFlavour = flavour,
algTyConRec = rec,
-- 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
\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 = 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 (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
\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}
#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 )
import Var ( TyVar )
import VarSet
import Maybes ( expectJust )
+import Maybe ( isNothing )
import Outputable
\end{code}
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
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)" $
projects / ghc-hetmet.git / commitdiff