From 711e4d7a4d65472a3a1fb35bcad8e1c9a109c728 Mon Sep 17 00:00:00 2001 From: simonpj Date: Wed, 13 Feb 2002 15:19:21 +0000 Subject: [PATCH] [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. --- ghc/compiler/basicTypes/DataCon.lhs | 4 +- ghc/compiler/ghci/InteractiveUI.hs | 8 +-- ghc/compiler/hsSyn/HsDecls.lhs | 26 +++++--- ghc/compiler/main/HscStats.lhs | 5 +- ghc/compiler/main/HscTypes.lhs | 4 +- ghc/compiler/main/MkIface.lhs | 10 +-- ghc/compiler/parser/Parser.y | 7 +- ghc/compiler/parser/RdrHsSyn.lhs | 4 +- ghc/compiler/prelude/PrelRules.lhs | 5 +- ghc/compiler/prelude/TysWiredIn.lhs | 12 ++-- ghc/compiler/rename/ParseIface.y | 18 +++--- ghc/compiler/rename/RnHsSyn.lhs | 7 +- ghc/compiler/rename/RnIfaces.lhs | 5 +- ghc/compiler/rename/RnSource.lhs | 36 +++++++---- ghc/compiler/simplCore/SimplUtils.lhs | 14 ++-- ghc/compiler/typecheck/TcEnv.lhs | 4 +- ghc/compiler/typecheck/TcTyClsDecls.lhs | 17 +++-- ghc/compiler/typecheck/TcTyDecls.lhs | 107 +++++++++++++++++-------------- ghc/compiler/types/Generics.lhs | 17 +++-- ghc/compiler/types/TyCon.lhs | 94 ++++++++++++++------------- ghc/compiler/types/Variance.lhs | 7 +- 21 files changed, 227 insertions(+), 184 deletions(-) diff --git a/ghc/compiler/basicTypes/DataCon.lhs b/ghc/compiler/basicTypes/DataCon.lhs index efefb63..ac3ffa3 100644 --- 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 ) -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 diff --git a/ghc/compiler/ghci/InteractiveUI.hs b/ghc/compiler/ghci/InteractiveUI.hs index 1e98d0c..b915e6f 100644 --- a/ghc/compiler/ghci/InteractiveUI.hs +++ b/ghc/compiler/ghci/InteractiveUI.hs @@ -1,6 +1,6 @@ {-# 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 diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs index 7eae5ff..b4d98cf 100644 --- 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 ) +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 diff --git a/ghc/compiler/main/HscStats.lhs b/ghc/compiler/main/HscStats.lhs index 4f53d0a..f20d796 100644 --- 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 +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 {}) diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs index 930ea0a..6077dda 100644 --- 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 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 diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs index de344b7..7055df9 100644 --- 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, - 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) diff --git a/ghc/compiler/parser/Parser.y b/ghc/compiler/parser/Parser.y index 8b2ef62..ca4fbba 100644 --- a/ghc/compiler/parser/Parser.y +++ b/ghc/compiler/parser/Parser.y @@ -1,6 +1,6 @@ {- -*-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 diff --git a/ghc/compiler/parser/RdrHsSyn.lhs b/ghc/compiler/parser/RdrHsSyn.lhs index 6626fce..6b0e63c 100644 --- 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) -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 diff --git a/ghc/compiler/prelude/PrelRules.lhs b/ghc/compiler/prelude/PrelRules.lhs index 0ebec4f..ba53089 100644 --- 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 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 diff --git a/ghc/compiler/prelude/TysWiredIn.lhs b/ghc/compiler/prelude/TysWiredIn.lhs index ade3426..9d743a5 100644 --- 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 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 diff --git a/ghc/compiler/rename/ParseIface.y b/ghc/compiler/rename/ParseIface.y index ce9526c..0d01d6a 100644 --- 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 ) +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 : { ([],[]) } diff --git a/ghc/compiler/rename/RnHsSyn.lhs b/ghc/compiler/rename/RnHsSyn.lhs index 43364ae..d3f9c74 100644 --- 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 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) diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs index 81479de..ba2b1cd 100644 --- 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 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 diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index 85c7cb5..cc78801 100644 --- 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 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 $ diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs index 817ae8f..57c7274 100644 --- 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 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_` diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs index c08e43b..5dc8b8b 100644 --- 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 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} diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs index 807787f..5101ab3 100644 --- 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 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 diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs index f525f4e..0ed2fef 100644 --- 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 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 - ] - 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 diff --git a/ghc/compiler/types/Generics.lhs b/ghc/compiler/types/Generics.lhs index 8afbc4b..0f262d0 100644 --- 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 TyCon ( TyCon, tyConTyVars, tyConDataConsIfAvailable, +import TyCon ( TyCon, tyConTyVars, tyConDataCons_maybe, tyConGenInfo, isNewTyCon, newTyConRep, isBoxedTupleTyCon ) import Name ( Name, mkSysLocalName ) @@ -35,6 +35,7 @@ import TysWiredIn ( genericTyCons, import IdInfo ( noCafNoTyGenIdInfo, setUnfoldingInfo, setArityInfo ) import CoreUnfold ( mkTopUnfolding ) +import Maybe ( isNothing ) 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] - | 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 @@ -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 - 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 diff --git a/ghc/compiler/types/TyCon.lhs b/ghc/compiler/types/TyCon.lhs index 10158c5..8a03de1 100644 --- a/ghc/compiler/types/TyCon.lhs +++ b/ghc/compiler/types/TyCon.lhs @@ -5,7 +5,10 @@ \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, @@ -15,7 +18,7 @@ module TyCon( mkForeignTyCon, isForeignTyCon, - mkAlgTyCon, --mkAlgTyCon, + mkAlgTyCon, mkClassTyCon, mkFunTyCon, mkPrimTyCon, @@ -32,7 +35,7 @@ module TyCon( tyConUnique, tyConTyVars, tyConArgVrcs_maybe, - tyConDataCons, tyConDataConsIfAvailable, tyConFamilySize, + tyConDataConDetails, tyConDataCons, tyConDataCons_maybe, tyConFamilySize, 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 Maybes ( expectJust ) import Outputable import FastString \end{code} @@ -99,25 +103,10 @@ data TyCon 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 @@ -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 + +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} @@ -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) -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, @@ -267,7 +271,6 @@ mkAlgTyCon name kind tyvars theta argvrcs cons ncons sels flavour rec algTyConTheta = theta, dataCons = cons, selIds = sels, - noOfDataCons = ncons, algTyConClass = Nothing, algTyConFlavour = flavour, algTyConRec = rec, @@ -283,9 +286,8 @@ mkClassTyCon name kind tyvars argvrcs con clas flavour rec tyConTyVars = tyvars, tyConArgVrcs = argvrcs, algTyConTheta = [], - dataCons = [con], + dataCons = DataCons [con], selIds = [], - noOfDataCons = 1, 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 -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 @@ -442,22 +444,23 @@ isForeignTyCon other = 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 @@ -505,13 +508,12 @@ getSynTyConDefn (SynTyCon {tyConTyVars = tyvars, synTyConDefn = ty}) = (tyvars,t \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} diff --git a/ghc/compiler/types/Variance.lhs b/ghc/compiler/types/Variance.lhs index ffc96d5..5f4b3f6 100644 --- 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 -import TyCon ( TyCon, ArgVrcs, tyConArity, tyConDataConsIfAvailable, tyConTyVars, +import TyCon ( TyCon, ArgVrcs, tyConArity, tyConDataCons_maybe, tyConDataCons, tyConTyVars, tyConArgVrcs_maybe, getSynTyConDefn, isSynTyCon, isAlgTyCon ) import DataCon ( dataConRepArgTys ) @@ -20,6 +20,7 @@ import FiniteMap import Var ( TyVar ) import VarSet import Maybes ( expectJust ) +import Maybe ( isNothing ) 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 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 @@ -79,7 +80,7 @@ calcTyConArgVrcs tycons 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)" $ -- 1.7.10.4