From af5a215172aa3b964ece212f229bfee9f7c6b6b2 Mon Sep 17 00:00:00 2001 From: simonpj Date: Wed, 17 Mar 2004 13:59:19 +0000 Subject: [PATCH] [project @ 2004-03-17 13:59:06 by simonpj] ------------------------ More newtype clearing up ------------------------ * Change the representation of TyCons so that it accurately reflects * data (0 or more constrs) * newtype (1 constr) * abstract (unknown) Replaces DataConDetails and AlgTyConFlavour with AlgTyConRhs * Add IfaceSyn.IfaceConDecls, a kind of stripped-down analogue of AlgTyConRhs * Move NewOrData from BasicTypes to HsDecl (it's now an HsSyn thing) * Arrange that Type.newTypeRep and splitRecNewType_maybe unwrap just one layer of new-type-ness, leaving the caller to recurse. This still leaves typeRep and repType in Type.lhs; these functions are still vaguely disturbing and probably should get some attention. Lots of knock-on changes. Fixes bug in ds054. --- ghc/compiler/basicTypes/BasicTypes.lhs | 20 ----- ghc/compiler/deSugar/DsMeta.hs | 2 +- ghc/compiler/hsSyn/Convert.lhs | 2 +- ghc/compiler/hsSyn/HsDecls.lhs | 13 ++- ghc/compiler/hsSyn/HsSyn.lhs | 4 +- ghc/compiler/iface/BinIface.hs | 49 ++++------- ghc/compiler/iface/BuildTyCl.lhs | 127 +++++++++++++++------------- ghc/compiler/iface/IfaceSyn.lhs | 71 +++++++++------- ghc/compiler/iface/LoadIface.lhs | 16 ++-- ghc/compiler/iface/MkIface.lhs | 4 +- ghc/compiler/iface/TcIface.lhs | 25 +++--- ghc/compiler/parser/Parser.y.pp | 2 +- ghc/compiler/parser/RdrHsSyn.lhs | 24 +++--- ghc/compiler/prelude/TysWiredIn.lhs | 5 +- ghc/compiler/typecheck/TcClassDcl.lhs | 2 +- ghc/compiler/typecheck/TcDeriv.lhs | 1 - ghc/compiler/typecheck/TcRnDriver.lhs | 10 ++- ghc/compiler/typecheck/TcTyClsDecls.lhs | 21 +++-- ghc/compiler/typecheck/TcTyDecls.lhs | 12 +-- ghc/compiler/typecheck/TcType.lhs | 4 +- ghc/compiler/types/TyCon.lhs | 137 +++++++++++++++---------------- ghc/compiler/types/Type.lhs | 46 +++++++---- 22 files changed, 311 insertions(+), 286 deletions(-) diff --git a/ghc/compiler/basicTypes/BasicTypes.lhs b/ghc/compiler/basicTypes/BasicTypes.lhs index fbc6bc8..bce1fa0 100644 --- a/ghc/compiler/basicTypes/BasicTypes.lhs +++ b/ghc/compiler/basicTypes/BasicTypes.lhs @@ -27,8 +27,6 @@ module BasicTypes( IPName(..), ipNameName, mapIPName, - NewOrData(..), - RecFlag(..), isRec, isNonRec, boolToRecFlag, TopLevelFlag(..), isTopLevel, isNotTopLevel, @@ -193,24 +191,6 @@ compareFixity (Fixity prec1 dir1) (Fixity prec2 dir2) %************************************************************************ %* * -\subsection[NewType/DataType]{NewType/DataType flag} -%* * -%************************************************************************ - -\begin{code} -data NewOrData - = NewType -- "newtype Blah ..." - | DataType -- "data Blah ..." - deriving( Eq ) -- Needed because Demand derives Eq - -instance Outputable NewOrData where - ppr NewType = ptext SLIT("newtype") - ppr DataType = ptext SLIT("data") -\end{code} - - -%************************************************************************ -%* * \subsection[Top-level/local]{Top-level/not-top level flag} %* * %************************************************************************ diff --git a/ghc/compiler/deSugar/DsMeta.hs b/ghc/compiler/deSugar/DsMeta.hs index 614ad3b..94f3496 100644 --- a/ghc/compiler/deSugar/DsMeta.hs +++ b/ghc/compiler/deSugar/DsMeta.hs @@ -51,7 +51,7 @@ import CoreUtils ( exprType ) import SrcLoc ( noSrcLoc, unLoc, Located(..), SrcSpan, srcLocSpan ) import Maybe ( catMaybes ) import Unique ( mkPreludeTyConUnique, mkPreludeMiscIdUnique, getKey, Uniquable(..) ) -import BasicTypes ( NewOrData(..), isBoxed ) +import BasicTypes ( isBoxed ) import Packages ( thPackage ) import Outputable import Bag ( bagToList ) diff --git a/ghc/compiler/hsSyn/Convert.lhs b/ghc/compiler/hsSyn/Convert.lhs index 4b8f04c..c2d35d5 100644 --- a/ghc/compiler/hsSyn/Convert.lhs +++ b/ghc/compiler/hsSyn/Convert.lhs @@ -23,7 +23,7 @@ import SrcLoc ( SrcLoc, generatedSrcLoc, noLoc, unLoc, Located(..), noSrcSpan, SrcSpan, srcLocSpan, noSrcLoc ) import Type ( Type ) import TysWiredIn ( unitTyCon, tupleTyCon, trueDataCon, falseDataCon ) -import BasicTypes( Boxity(..), RecFlag(Recursive), NewOrData(..) ) +import BasicTypes( Boxity(..), RecFlag(Recursive) ) import ForeignCall ( Safety(..), CCallConv(..), CCallTarget(..), CExportSpec(..)) import HsDecls ( CImportSpec(..), ForeignImport(..), ForeignExport(..), diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs index 474131a..930dcdc 100644 --- a/ghc/compiler/hsSyn/HsDecls.lhs +++ b/ghc/compiler/hsSyn/HsDecls.lhs @@ -9,7 +9,7 @@ Definitions for: @TyDecl@ and @oCnDecl@, @ClassDecl@, \begin{code} module HsDecls ( HsDecl(..), LHsDecl, TyClDecl(..), LTyClDecl, - InstDecl(..), LInstDecl, + InstDecl(..), LInstDecl, NewOrData(..), RuleDecl(..), LRuleDecl, RuleBndr(..), DefaultDecl(..), LDefaultDecl, HsGroup(..), SpliceDecl(..), ForeignDecl(..), LForeignDecl, ForeignImport(..), ForeignExport(..), @@ -38,7 +38,7 @@ import HsImpExp ( pprHsVar ) import HsTypes import HscTypes ( DeprecTxt ) import CoreSyn ( RuleName ) -import BasicTypes ( NewOrData(..), Activation(..) ) +import BasicTypes ( Activation(..) ) import ForeignCall ( CCallTarget(..), DNCallSpec, CCallConv, Safety, CExportSpec(..)) @@ -323,6 +323,11 @@ data TyClDecl name tcdSigs :: [LSig name], -- Methods' signatures tcdMeths :: LHsBinds name -- Default methods } + +data NewOrData + = NewType -- "newtype Blah ..." + | DataType -- "data Blah ..." + deriving( Eq ) -- Needed because Demand derives Eq \end{code} Simple classifiers @@ -431,6 +436,10 @@ pp_tydecl pp_head pp_decl_rhs derivings Just ds -> hsep [ptext SLIT("deriving"), ppr_hs_context (unLoc ds)] ]) + +instance Outputable NewOrData where + ppr NewType = ptext SLIT("newtype") + ppr DataType = ptext SLIT("data") \end{code} diff --git a/ghc/compiler/hsSyn/HsSyn.lhs b/ghc/compiler/hsSyn/HsSyn.lhs index ed04dff..c5ea96e 100644 --- a/ghc/compiler/hsSyn/HsSyn.lhs +++ b/ghc/compiler/hsSyn/HsSyn.lhs @@ -17,7 +17,7 @@ module HsSyn ( module HsPat, module HsTypes, module HsUtils, - Fixity, NewOrData, + Fixity, HsModule(..), HsExtCore(..) ) where @@ -33,7 +33,7 @@ import HsLit import HsPat import HsTypes import HscTypes ( DeprecTxt ) -import BasicTypes ( Fixity, NewOrData ) +import BasicTypes ( Fixity ) import HsUtils -- others: diff --git a/ghc/compiler/iface/BinIface.hs b/ghc/compiler/iface/BinIface.hs index 315f35e..f5294d9 100644 --- a/ghc/compiler/iface/BinIface.hs +++ b/ghc/compiler/iface/BinIface.hs @@ -14,7 +14,6 @@ import BasicTypes import NewDemand import IfaceSyn import VarEnv -import TyCon ( DataConDetails(..) ) import Class ( DefMeth(..) ) import CostCentre import Module ( moduleName, mkModule ) @@ -51,7 +50,6 @@ readBinIface hi_path = getBinFileWithDict hi_path {-! for IPName derive: Binary !-} {-! for Fixity derive: Binary !-} {-! for FixityDirection derive: Binary !-} -{-! for NewOrData derive: Binary !-} {-! for Boxity derive: Binary !-} {-! for StrictnessMark derive: Binary !-} {-! for Activation derive: Binary !-} @@ -62,9 +60,6 @@ readBinIface hi_path = getBinFileWithDict hi_path {-! for DmdResult derive: Binary !-} {-! for StrictSig derive: Binary !-} --- TyCon -{-! for DataConDetails derive: Binary !-} - -- Class {-! for DefMeth derive: Binary !-} @@ -318,17 +313,6 @@ instance Binary TupCon where ac <- get bh return (TupCon ab ac) -instance Binary NewOrData where - put_ bh NewType = do - putByte bh 0 - put_ bh DataType = do - putByte bh 1 - get bh = do - h <- getByte bh - case h of - 0 -> do return NewType - _ -> do return DataType - instance Binary RecFlag where put_ bh Recursive = do putByte bh 0 @@ -891,7 +875,7 @@ instance Binary IfaceDecl where put_ bh idinfo put_ bh (IfaceForeign ae af) = error "Binary.put_(IfaceDecl): IfaceForeign" - put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7 a8) = do + put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7) = do putByte bh 2 put_ bh a1 put_ bh a2 @@ -900,7 +884,6 @@ instance Binary IfaceDecl where put_ bh a5 put_ bh a6 put_ bh a7 - put_ bh a8 put_ bh (IfaceSyn aq ar as at) = do putByte bh 3 @@ -933,8 +916,7 @@ instance Binary IfaceDecl where a5 <- get bh a6 <- get bh a7 <- get bh - a8 <- get bh - return (IfaceData a1 a2 a3 a4 a5 a6 a7 a8) + return (IfaceData a1 a2 a3 a4 a5 a6 a7) 3 -> do aq <- get bh ar <- get bh @@ -959,6 +941,21 @@ instance Binary IfaceInst where dfun <- get bh return (IfaceInst ty dfun) +instance Binary IfaceConDecls where + put_ bh IfAbstractTyCon = putByte bh 0 + put_ bh (IfDataTyCon cs) = do { putByte bh 1 + ; put_ bh cs } + put_ bh (IfNewTyCon c) = do { putByte bh 2 + ; put_ bh c } + get bh = do + h <- getByte bh + case h of + 0 -> return IfAbstractTyCon + 1 -> do aa <- get bh + return (IfDataTyCon aa) + _ -> do aa <- get bh + return (IfNewTyCon aa) + instance Binary IfaceConDecl where put_ bh (IfaceConDecl a1 a2 a3 a4 a5 a6) = do put_ bh a1 @@ -1005,16 +1002,4 @@ instance Binary IfaceRule where a6 <- get bh return (IfaceRule a1 a2 a3 a4 a5 a6) -instance (Binary datacon) => Binary (DataConDetails datacon) where - put_ bh (DataCons aa) = do - putByte bh 0 - put_ bh aa - put_ bh Unknown = do - putByte bh 1 - get bh = do - h <- getByte bh - case h of - 0 -> do aa <- get bh - return (DataCons aa) - _ -> do return Unknown diff --git a/ghc/compiler/iface/BuildTyCl.lhs b/ghc/compiler/iface/BuildTyCl.lhs index 184dadb..a81570d 100644 --- a/ghc/compiler/iface/BuildTyCl.lhs +++ b/ghc/compiler/iface/BuildTyCl.lhs @@ -6,7 +6,7 @@ module BuildTyCl ( buildSynTyCon, buildAlgTyCon, buildDataCon, buildClass, - newTyConRhs -- Just a useful little function with no obvious home + mkAbstractTyConRhs, mkNewTyConRhs, mkDataTyConRhs ) where #include "HsVersions.h" @@ -18,10 +18,10 @@ import Subst ( substTyWith ) import Util ( zipLazy ) import FieldLabel ( allFieldLabelTags, mkFieldLabel, fieldLabelName ) import VarSet -import DataCon ( DataCon, dataConOrigArgTys, mkDataCon, dataConFieldLabels ) -import Var ( tyVarKind, TyVar ) +import DataCon ( DataCon, dataConTyCon, dataConOrigArgTys, mkDataCon, dataConFieldLabels ) +import Var ( tyVarKind, TyVar, Id ) import TysWiredIn ( unitTy ) -import BasicTypes ( RecFlag, NewOrData( ..), StrictnessMark(..) ) +import BasicTypes ( RecFlag, StrictnessMark(..) ) import Name ( Name ) import OccName ( mkDataConWrapperOcc, mkDataConWorkerOcc, mkClassTyConOcc, mkClassDataConOcc, mkSuperDictSelOcc ) @@ -29,7 +29,7 @@ import MkId ( mkDataConIds, mkRecordSelId, mkDictSelId ) import Class ( mkClass, Class( classTyCon), FunDep, DefMeth(..) ) import TyCon ( mkSynTyCon, mkAlgTyCon, visibleDataCons, tyConDataCons, isNewTyCon, mkClassTyCon, TyCon( tyConTyVars ), - ArgVrcs, DataConDetails( ..), AlgTyConFlavour(..) ) + ArgVrcs, AlgTyConRhs(..), newTyConRhs, visibleDataCons ) import Type ( mkArrowKinds, liftedTypeKind, tyVarsOfTypes, typeKind, tyVarsOfPred, splitTyConApp_maybe, mkPredTys, ThetaType, Type ) import Outputable @@ -47,29 +47,40 @@ buildSynTyCon name tvs rhs_ty arg_vrcs ------------------------------------------------------ -buildAlgTyCon :: NewOrData -> Name -> [TyVar] -> ThetaType - -> DataConDetails DataCon +buildAlgTyCon :: Name -> [TyVar] -> ThetaType + -> AlgTyConRhs -> ArgVrcs -> RecFlag -> Bool -- True <=> want generics functions -> TcRnIf m n TyCon -buildAlgTyCon new_or_data tc_name tvs ctxt cons arg_vrcs is_rec want_generics +buildAlgTyCon tc_name tvs ctxt rhs arg_vrcs is_rec want_generics = do { let { tycon = mkAlgTyCon tc_name kind tvs ctxt arg_vrcs - cons sel_ids flavour is_rec want_generics + rhs sel_ids is_rec want_generics ; kind = mkArrowKinds (map tyVarKind tvs) liftedTypeKind - ; sel_ids = mkRecordSelectors tycon cons - ; flavour = case new_or_data of - NewType -> NewTyCon (mkNewTyConRep tycon) - DataType -> DataTyCon (all_nullary cons) + ; sel_ids = mkRecordSelectors tycon rhs } ; return tycon } + +------------------------------------------------------ +mkAbstractTyConRhs :: AlgTyConRhs +mkAbstractTyConRhs = AbstractTyCon + +mkDataTyConRhs :: [DataCon] -> AlgTyConRhs +mkDataTyConRhs cons + = DataTyCon cons (all is_nullary cons) where - all_nullary (DataCons cons) = all (null . dataConOrigArgTys) cons - all_nullary Unknown = False -- Safe choice for unknown data types + is_nullary con = null (dataConOrigArgTys con) -- NB (null . dataConOrigArgTys). It used to say isNullaryDataCon -- but that looks at the *representation* arity, and isEnumerationType -- refers to the *source* code definition +mkNewTyConRhs :: DataCon -> AlgTyConRhs +mkNewTyConRhs con + = NewTyCon con -- The constructor + (head (dataConOrigArgTys con)) -- The RHS type + (mkNewTyConRep (dataConTyCon con)) -- The ultimate rep type + + ------------------------------------------------------ buildDataCon :: Name -> [StrictnessMark] @@ -117,6 +128,7 @@ thinContext arg_tys ctxt tyVarsOfPred pred `intersectVarSet` arg_tyvars ------------------------------------------------------ +mkRecordSelectors :: TyCon -> AlgTyConRhs -> [Id] mkRecordSelectors tycon data_cons = -- We'll check later that fields with the same name -- from different constructors have the same type. @@ -126,48 +138,10 @@ mkRecordSelectors tycon data_cons fields = [ field | con <- visibleDataCons data_cons, field <- dataConFieldLabels con ] eq_name field1 field2 = fieldLabelName field1 == fieldLabelName field2 - - ------------------------------------------------------- -newTyConRhs :: TyCon -> Type -- The defn of a newtype, as written by the programmer -newTyConRhs tc = head (dataConOrigArgTys (head (tyConDataCons tc))) - -mkNewTyConRep :: TyCon -- The original type constructor - -> Type -- Chosen representation type - -- (guaranteed not to be another newtype) - --- Find the representation type for this newtype TyCon --- Remember that the representation type is the *ultimate* representation --- type, looking through other newtypes. --- --- The non-recursive newtypes are easy, because they look transparent --- to splitTyConApp_maybe, but recursive ones really are represented as --- TyConApps (see TypeRep). --- --- The trick is to to deal correctly with recursive newtypes --- such as newtype T = MkT T - -mkNewTyConRep tc - | null (tyConDataCons tc) = unitTy - -- External Core programs can have newtypes with no data constructors - | otherwise = go [] tc - where - -- Invariant: tc is a NewTyCon - -- tcs have been seen before - go tcs tc - | tc `elem` tcs = unitTy - | otherwise - = case splitTyConApp_maybe rep_ty of - Nothing -> rep_ty - Just (tc', tys) | not (isNewTyCon tc') -> rep_ty - | otherwise -> go1 (tc:tcs) tc' tys - where - rep_ty = newTyConRhs tc - - go1 tcs tc tys = substTyWith (tyConTyVars tc) tys (go tcs tc) \end{code} +------------------------------------------------------ \begin{code} buildClass :: Name -> [TyVar] -> ThetaType -> [FunDep TyVar] -- Functional dependencies @@ -214,8 +188,7 @@ buildClass class_name tvs sc_theta fds sig_stuff tc_isrec tc_vrcs tycon ; tycon = mkClassTyCon tycon_name clas_kind tvs - tc_vrcs dict_con - clas flavour tc_isrec + tc_vrcs rhs clas tc_isrec -- A class can be recursive, and in the case of newtypes -- this matters. For example -- class C a where { op :: C b => a -> b -> Int } @@ -226,12 +199,48 @@ buildClass class_name tvs sc_theta fds sig_stuff tc_isrec tc_vrcs ; clas_kind = mkArrowKinds (map tyVarKind tvs) liftedTypeKind - ; flavour = case dict_component_tys of - [rep_ty] -> NewTyCon (mkNewTyConRep tycon) - other -> DataTyCon False -- Not an enumeration + ; rhs = case dict_component_tys of + [rep_ty] -> mkNewTyConRhs dict_con + other -> mkDataTyConRhs [dict_con] } ; return clas })} \end{code} +------------------------------------------------------ +\begin{code} +mkNewTyConRep :: TyCon -- The original type constructor + -> Type -- Chosen representation type + -- (guaranteed not to be another newtype) + +-- Find the representation type for this newtype TyCon +-- Remember that the representation type is the *ultimate* representation +-- type, looking through other newtypes. +-- +-- The non-recursive newtypes are easy, because they look transparent +-- to splitTyConApp_maybe, but recursive ones really are represented as +-- TyConApps (see TypeRep). +-- +-- The trick is to to deal correctly with recursive newtypes +-- such as newtype T = MkT T + +mkNewTyConRep tc + | null (tyConDataCons tc) = unitTy + -- External Core programs can have newtypes with no data constructors + | otherwise = go [] tc + where + -- Invariant: tc is a NewTyCon + -- tcs have been seen before + go tcs tc + | tc `elem` tcs = unitTy + | otherwise + = case splitTyConApp_maybe rep_ty of + Nothing -> rep_ty + Just (tc', tys) | not (isNewTyCon tc') -> rep_ty + | otherwise -> go1 (tc:tcs) tc' tys + where + (_,rep_ty) = newTyConRhs tc + + go1 tcs tc tys = substTyWith (tyConTyVars tc) tys (go tcs tc) +\end{code} diff --git a/ghc/compiler/iface/IfaceSyn.lhs b/ghc/compiler/iface/IfaceSyn.lhs index f384013..917b8b9 100644 --- a/ghc/compiler/iface/IfaceSyn.lhs +++ b/ghc/compiler/iface/IfaceSyn.lhs @@ -14,11 +14,14 @@ We could either use this, or parameterise @GenCoreExpr@ on @Types@ and module IfaceSyn ( module IfaceType, -- Re-export all this - IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), + IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), IfaceConDecls(..), IfaceExpr(..), IfaceAlt, IfaceNote(..), IfaceBinding(..), IfaceConAlt(..), IfaceIdInfo(..), IfaceInfoItem(..), IfaceRule(..), IfaceInst(..), + -- Misc + visibleIfConDecls, + -- Converting things to IfaceSyn tyThingToIfaceDecl, dfunToIfaceInst, coreRuleToIfaceRule, @@ -46,11 +49,11 @@ import NewDemand ( isTopSig ) import IdInfo ( IdInfo, CafInfo(..), WorkerInfo(..), arityInfo, cafInfo, newStrictnessInfo, workerInfo, unfoldingInfo, inlinePragInfo ) -import TyCon ( TyCon, ArgVrcs, DataConDetails(..), isRecursiveTyCon, isForeignTyCon, +import TyCon ( TyCon, ArgVrcs, AlgTyConRhs(..), isRecursiveTyCon, isForeignTyCon, isSynTyCon, isNewTyCon, isAlgTyCon, isPrimTyCon, isFunTyCon, isTupleTyCon, tupleTyConBoxity, tyConHasGenerics, tyConArgVrcs, tyConTheta, getSynTyConDefn, - tyConArity, tyConTyVars, tyConDataConDetails, tyConExtName ) + tyConArity, tyConTyVars, algTyConRhs, tyConExtName ) import DataCon ( dataConName, dataConSig, dataConFieldLabels, dataConStrictMarks, dataConTyCon ) import Class ( FunDep, DefMeth, classExtraBigSig, classTyCon ) @@ -64,7 +67,7 @@ import CostCentre ( CostCentre, pprCostCentreCore ) import Literal ( Literal ) import ForeignCall ( ForeignCall ) import TysPrim ( alphaTyVars ) -import BasicTypes ( Arity, Activation(..), StrictnessMark, NewOrData(..), +import BasicTypes ( Arity, Activation(..), StrictnessMark, RecFlag(..), boolToRecFlag, Boxity(..), tupleParens ) import Outputable @@ -89,11 +92,10 @@ data IfaceDecl ifType :: IfaceType, ifIdInfo :: IfaceIdInfo } - | IfaceData { ifND :: NewOrData, - ifCtxt :: IfaceContext, -- Context + | IfaceData { ifCtxt :: IfaceContext, -- Context ifName :: OccName, -- Type constructor ifTyVars :: [IfaceTvBndr], -- Type variables - ifCons :: DataConDetails IfaceConDecl, + ifCons :: IfaceConDecls, -- Includes new/data info ifRec :: RecFlag, -- Recursive or not? ifVrcs :: ArgVrcs, ifGeneric :: Bool -- True <=> generic converter functions available @@ -124,6 +126,16 @@ data IfaceClassOp = IfaceClassOp OccName DefMeth IfaceType -- Just False => ordinary polymorphic default method -- Just True => generic default method +data IfaceConDecls + = IfAbstractTyCon -- No info + | IfDataTyCon [IfaceConDecl] -- data type decls + | IfNewTyCon IfaceConDecl -- newtype decls + +visibleIfConDecls :: IfaceConDecls -> [IfaceConDecl] +visibleIfConDecls IfAbstractTyCon = [] +visibleIfConDecls (IfDataTyCon cs) = cs +visibleIfConDecls (IfNewTyCon c) = [c] + data IfaceConDecl = IfaceConDecl OccName -- Constructor name [IfaceTvBndr] -- Existental tyvars @@ -246,10 +258,15 @@ pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, ifSynRhs = mono_ty, i 4 (vcat [equals <+> ppr mono_ty, pprVrcs vrcs]) -pprIfaceDecl (IfaceData {ifND = new_or_data, ifCtxt = context, ifName = tycon, ifGeneric = gen, +pprIfaceDecl (IfaceData {ifCtxt = context, ifName = tycon, ifGeneric = gen, ifTyVars = tyvars, ifCons = condecls, ifRec = isrec, ifVrcs = vrcs}) - = hang (ppr new_or_data <+> pp_decl_head context tycon tyvars) + = hang (pp_nd <+> pp_decl_head context tycon tyvars) 4 (vcat [pprVrcs vrcs, pprRec isrec, pprGen gen, pp_condecls condecls]) + where + pp_nd = case condecls of + IfAbstractTyCon -> ptext SLIT("data") + IfDataTyCon _ -> ptext SLIT("data") + IfNewTyCon _ -> ptext SLIT("newtype") pprIfaceDecl (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars, ifFDs = fds, ifSigs = sigs, ifVrcs = vrcs, ifRec = isrec}) @@ -270,8 +287,9 @@ pp_decl_head :: IfaceContext -> OccName -> [IfaceTvBndr] -> SDoc pp_decl_head context thing tyvars = hsep [pprIfaceContext context, ppr thing, pprIfaceTvBndrs tyvars] -pp_condecls Unknown = ptext SLIT("{- abstract -}") -pp_condecls (DataCons cs) = equals <+> sep (punctuate (ptext SLIT(" |")) (map ppr cs)) +pp_condecls IfAbstractTyCon = ptext SLIT("{- abstract -}") +pp_condecls (IfDataTyCon cs) = equals <+> sep (punctuate (ptext SLIT(" |")) (map ppr cs)) +pp_condecls (IfNewTyCon c) = equals <+> ppr c instance Outputable IfaceConDecl where ppr (IfaceConDecl name ex_tvs ex_ctxt arg_tys strs fields) @@ -445,11 +463,10 @@ tyThingToIfaceDecl _ abstract_tcs ext (ATyCon tycon) ifSynRhs = toIfaceType ext syn_ty } | isAlgTyCon tycon - = IfaceData { ifND = new_or_data, - ifCtxt = toIfaceContext ext (tyConTheta tycon), + = IfaceData { ifCtxt = toIfaceContext ext (tyConTheta tycon), ifName = getOccName tycon, ifTyVars = toIfaceTvBndrs tyvars, - ifCons = ifaceConDecls (tyConDataConDetails tycon), + ifCons = ifaceConDecls (algTyConRhs tycon), ifRec = boolToRecFlag (isRecursiveTyCon tycon), ifVrcs = tyConArgVrcs tycon, ifGeneric = tyConHasGenerics tycon } @@ -460,11 +477,10 @@ tyThingToIfaceDecl _ abstract_tcs ext (ATyCon tycon) | isPrimTyCon tycon || isFunTyCon tycon -- Needed in GHCi for ':info Int#', for example - = IfaceData { ifND = DataType, - ifCtxt = [], + = IfaceData { ifCtxt = [], ifName = getOccName tycon, ifTyVars = toIfaceTvBndrs (take (tyConArity tycon) alphaTyVars), - ifCons = Unknown, + ifCons = IfAbstractTyCon, ifGeneric = False, ifRec = NonRecursive, ifVrcs = tyConArgVrcs tycon } @@ -473,14 +489,13 @@ tyThingToIfaceDecl _ abstract_tcs ext (ATyCon tycon) where tyvars = tyConTyVars tycon (_, syn_ty) = getSynTyConDefn tycon - new_or_data | isNewTyCon tycon = NewType - | otherwise = DataType - - abstract = getName tycon `elemNameSet` abstract_tcs + abstract = getName tycon `elemNameSet` abstract_tcs - ifaceConDecls _ | abstract = Unknown - ifaceConDecls Unknown = Unknown - ifaceConDecls (DataCons cs) = DataCons (map ifaceConDecl cs) + ifaceConDecls _ | abstract = IfAbstractTyCon + ifaceConDecls (NewTyCon con _ _) = IfNewTyCon (ifaceConDecl con) + ifaceConDecls (DataTyCon cons _) = IfDataTyCon (map ifaceConDecl cons) + ifaceConDecls AbstractTyCon = pprPanic "ifaceConDecls" (ppr tycon) + -- We're exporting this thing, so it's locally defined and should not be abstract ifaceConDecl data_con = IfaceConDecl (getOccName (dataConName data_con)) @@ -723,7 +738,6 @@ eqIfDecl d1@(IfaceForeign {}) d2@(IfaceForeign {}) eqIfDecl d1@(IfaceData {}) d2@(IfaceData {}) = bool (ifName d1 == ifName d2 && - ifND d1 == ifND d2 && ifRec d1 == ifRec d2 && ifVrcs d1 == ifVrcs d2 && ifGeneric d1 == ifGeneric d2) &&& @@ -769,9 +783,10 @@ eqIfRule (IfaceRule n1 a1 bs1 f1 es1 rhs1) eq_ifaceExpr env rhs1 rhs2) eqIfRule _ _ = NotEqual -eq_hsCD env (DataCons c1) (DataCons c2) = eqListBy (eq_ConDecl env) c1 c2 -eq_hsCD env Unknown Unknown = Equal -eq_hsCD env d1 d2 = NotEqual +eq_hsCD env (IfDataTyCon c1) (IfDataTyCon c2) = eqListBy (eq_ConDecl env) c1 c2 +eq_hsCD env (IfNewTyCon c1) (IfNewTyCon c2) = eq_ConDecl env c1 c2 +eq_hsCD env IfAbstractTyCon IfAbstractTyCon = Equal +eq_hsCD env d1 d2 = NotEqual eq_ConDecl env (IfaceConDecl n1 tvs1 cxt1 args1 ss1 lbls1) (IfaceConDecl n2 tvs2 cxt2 args2 ss2 lbls2) diff --git a/ghc/compiler/iface/LoadIface.lhs b/ghc/compiler/iface/LoadIface.lhs index 945e7ea..bf5f694 100644 --- a/ghc/compiler/iface/LoadIface.lhs +++ b/ghc/compiler/iface/LoadIface.lhs @@ -20,9 +20,9 @@ import CmdLineOpts ( DynFlags( verbosity ), DynFlag( Opt_IgnoreInterfacePragmas opt_InPackage ) import Parser ( parseIface ) -import IfaceSyn ( IfaceDecl(..), IfaceConDecl(..), IfaceClassOp(..), IfaceInst(..), - IfaceRule(..), IfaceExpr(..), IfaceTyCon(..), IfaceIdInfo(..), - IfaceType(..), IfacePredType(..), IfaceExtName, mkIfaceExtName ) +import IfaceSyn ( IfaceDecl(..), IfaceConDecls(..), IfaceConDecl(..), IfaceClassOp(..), + IfaceInst(..), IfaceRule(..), IfaceExpr(..), IfaceTyCon(..), IfaceIdInfo(..), + IfaceType(..), IfacePredType(..), IfaceExtName, visibleIfConDecls, mkIfaceExtName ) import IfaceEnv ( newGlobalBinder, lookupIfaceExt, lookupIfaceTc ) import HscTypes ( HscEnv(..), ModIface(..), emptyModIface, ExternalPackageState(..), emptyTypeEnv, emptyPool, @@ -55,7 +55,7 @@ import OccName ( OccName, mkClassTyConOcc, mkClassDataConOcc, mkSuperDictSelOcc, mkDataConWrapperOcc, mkDataConWorkerOcc ) import Class ( Class, className ) -import TyCon ( DataConDetails(..), tyConName ) +import TyCon ( tyConName ) import SrcLoc ( mkSrcLoc, importedSrcLoc ) import Maybes ( isJust, mapCatMaybes ) import StringBuffer ( hGetStringBuffer ) @@ -300,11 +300,9 @@ ifaceDeclSubBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_occ, ifSigs = sigs tc_occ = mkClassTyConOcc cls_occ dc_occ = mkClassDataConOcc cls_occ -ifaceDeclSubBndrs (IfaceData {ifCons = Unknown}) = [] -ifaceDeclSubBndrs (IfaceData {ifCons = DataCons cons}) - = foldr ((++) . conDeclBndrs) [] cons - -ifaceDeclSubBndrs other = [] +ifaceDeclSubBndrs (IfaceData {ifCons = cons}) = foldr ((++) . conDeclBndrs) [] + (visibleIfConDecls cons) +ifaceDeclSubBndrs other = [] conDeclBndrs (IfaceConDecl con_occ _ _ _ _ fields) = fields ++ diff --git a/ghc/compiler/iface/MkIface.lhs b/ghc/compiler/iface/MkIface.lhs index f937379..1d77a03 100644 --- a/ghc/compiler/iface/MkIface.lhs +++ b/ghc/compiler/iface/MkIface.lhs @@ -177,7 +177,7 @@ import HsSyn import IfaceSyn ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), IfaceRule(..), IfaceInst(..), IfaceExtName(..), IfaceTyCon(..), eqIfDecl, eqIfRule, eqIfInst, IfaceEq(..), (&&&), bool, - eqMaybeBy, eqListBy, + eqMaybeBy, eqListBy, visibleIfConDecls, tyThingToIfaceDecl, dfunToIfaceInst, coreRuleToIfaceRule ) import LoadIface ( readIface, loadInterface, ifaceInstGates ) import BasicTypes ( Version, initialVersion, bumpVersion ) @@ -535,7 +535,7 @@ addVersionInfo (Just old_iface@(ModIface { mi_mod_vers = old_mod_vers, eq_ind_occs [op | IfaceClassOp op _ _ <- sigs] eq_indirects (IfaceData {ifName = tc_occ, ifCons = cons}) = same_insts tc_occ &&& same_fixity tc_occ &&& -- The TyCon can have a fixity too - eq_ind_occs [occ | IfaceConDecl occ _ _ _ _ _ <- visibleDataCons cons] + eq_ind_occs [occ | IfaceConDecl occ _ _ _ _ _ <- visibleIfConDecls cons] eq_indirects other = Equal -- Synonyms and foreign declarations eq_ind_occ :: OccName -> IfaceEq -- For class ops and Ids; check fixity and rules diff --git a/ghc/compiler/iface/TcIface.lhs b/ghc/compiler/iface/TcIface.lhs index 244c919..1f9b0ed 100644 --- a/ghc/compiler/iface/TcIface.lhs +++ b/ghc/compiler/iface/TcIface.lhs @@ -18,7 +18,8 @@ import IfaceEnv ( lookupIfaceTop, newGlobalBinder, lookupOrig, tcIfaceTyVar, tcIfaceTyCon, tcIfaceClass, tcIfaceExtId, tcIfaceDataCon, tcIfaceLclId, newIfaceName, newIfaceNames ) -import BuildTyCl ( buildSynTyCon, buildAlgTyCon, buildDataCon, buildClass ) +import BuildTyCl ( buildSynTyCon, buildAlgTyCon, buildDataCon, buildClass, + mkAbstractTyConRhs, mkDataTyConRhs, mkNewTyConRhs ) import TcRnMonad import Type ( liftedTypeKind, splitTyConApp, mkTyVarTys, mkGenTyConApp, mkTyVarTys, ThetaType, pprClassPred ) @@ -45,7 +46,7 @@ import IdInfo ( IdInfo, CafInfo(..), WorkerInfo(..), setArityInfo, setInlinePragInfo, setCafInfo, vanillaIdInfo, newStrictnessInfo ) import Class ( Class ) -import TyCon ( DataConDetails(..), tyConDataCons, tyConTyVars, isTupleTyCon, mkForeignTyCon ) +import TyCon ( AlgTyConRhs(..), tyConDataCons, tyConTyVars, isTupleTyCon, mkForeignTyCon ) import DataCon ( dataConWorkId, dataConExistentialTyVars, dataConArgTys ) import TysWiredIn ( tupleCon ) import Var ( TyVar, mkTyVar, tyVarKind ) @@ -335,7 +336,7 @@ tcIfaceDecl (IfaceId {ifName = occ_name, ifType = iface_type, ifIdInfo = info}) ; info <- tcIdInfo name ty info ; return (AnId (mkVanillaGlobal name ty info)) } -tcIfaceDecl (IfaceData {ifND = new_or_data, ifName = occ_name, +tcIfaceDecl (IfaceData {ifName = occ_name, ifTyVars = tv_bndrs, ifCtxt = rdr_ctxt, ifCons = rdr_cons, ifVrcs = arg_vrcs, ifRec = is_rec, @@ -358,7 +359,7 @@ tcIfaceDecl (IfaceData {ifND = new_or_data, ifName = occ_name, ; tycon <- fixM ( \ tycon -> do { cons <- tcIfaceDataCons tycon tyvars ctxt rdr_cons - ; tycon <- buildAlgTyCon new_or_data tc_name tyvars ctxt cons + ; tycon <- buildAlgTyCon tc_name tyvars ctxt cons arg_vrcs is_rec want_generic ; return tycon }) @@ -404,12 +405,13 @@ tcIfaceDecl (IfaceForeign {ifName = rdr_name, ifExtName = ext_name}) ; return (ATyCon (mkForeignTyCon name ext_name liftedTypeKind 0 [])) } -tcIfaceDataCons tycon tyvars ctxt Unknown - = returnM Unknown - -tcIfaceDataCons tycon tyvars ctxt (DataCons cs) - = mappM tc_con_decl cs `thenM` \ data_cons -> - returnM (DataCons data_cons) +tcIfaceDataCons tycon tyvars ctxt if_cons + = case if_cons of + IfAbstractTyCon -> return mkAbstractTyConRhs + IfDataTyCon cons -> do { data_cons <- mappM tc_con_decl cons + ; return (mkDataTyConRhs data_cons) } + IfNewTyCon con -> do { data_con <- tc_con_decl con + ; return (mkNewTyConRhs data_con) } where tc_con_decl (IfaceConDecl occ ex_tvs ex_ctxt args stricts field_lbls) = bindIfaceTyVars ex_tvs $ \ ex_tyvars -> do @@ -492,6 +494,7 @@ loadImportedInsts cls tys -- we call loadImportedInsts when looking up even predicates like (C a) -- But without undecidable instances it's rare to see C (a b) and -- somethat interesting +{- (comment out; happens a lot in some code) #ifdef DEBUG ; dflags <- getDOpts ; WARN( not (dopt Opt_AllowUndecidableInstances dflags) && null tc_gates, @@ -499,7 +502,7 @@ loadImportedInsts cls tys <+> pprClassPred cls tys ) return () #endif - +-} -- Suck in the instances ; let { (inst_pool', iface_insts) = selectInsts (eps_insts eps) cls_gate tc_gates } diff --git a/ghc/compiler/parser/Parser.y.pp b/ghc/compiler/parser/Parser.y.pp index fd7dab7..4826a93 100644 --- a/ghc/compiler/parser/Parser.y.pp +++ b/ghc/compiler/parser/Parser.y.pp @@ -32,7 +32,7 @@ import Module import CmdLineOpts ( opt_SccProfilingOn ) import Type ( Kind, mkArrowKind, liftedTypeKind ) import BasicTypes ( Boxity(..), Fixity(..), FixityDirection(..), IPName(..), - NewOrData(..), Activation(..) ) + Activation(..) ) import OrdList import Bag ( emptyBag ) import Panic diff --git a/ghc/compiler/parser/RdrHsSyn.lhs b/ghc/compiler/parser/RdrHsSyn.lhs index 45b015b..3e8c930 100644 --- a/ghc/compiler/parser/RdrHsSyn.lhs +++ b/ghc/compiler/parser/RdrHsSyn.lhs @@ -51,7 +51,7 @@ module RdrHsSyn ( import HsSyn -- Lots of it import IfaceType import HscTypes ( ModIface(..), emptyModIface, mkIfaceVerCache ) -import IfaceSyn ( IfaceDecl(..), IfaceIdInfo(..), IfaceConDecl(..) ) +import IfaceSyn ( IfaceDecl(..), IfaceIdInfo(..), IfaceConDecl(..), IfaceConDecls(..) ) import RdrName ( RdrName, isRdrTyVar, mkUnqual, rdrNameOcc, isRdrTyVar, isRdrDataCon, isUnqual, getRdrName, isQual, setRdrNameSpace, rdrNameModule ) @@ -65,7 +65,6 @@ import ForeignCall ( CCallConv, Safety, CCallTarget(..), CExportSpec(..), import OccName ( OccName, srcDataName, varName, isDataOcc, isTcOcc, occNameUserString, isValOcc ) import BasicTypes ( initialVersion, StrictnessMark(..) ) -import TyCon ( DataConDetails(..) ) import Module ( ModuleName ) import SrcLoc import CStrings ( CLabelString ) @@ -242,11 +241,10 @@ hsIfaceDecl (TyClD decl@(TySynonym {})) ifVrcs = [] } hsIfaceDecl (TyClD decl@(TyData {})) - = IfaceData { ifND = tcdND decl, - ifName = rdrNameOcc (tcdName decl), + = IfaceData { ifName = rdrNameOcc (tcdName decl), ifTyVars = hsIfaceTvs (tcdTyVars decl), ifCtxt = hsIfaceCtxt (unLoc (tcdCtxt decl)), - ifCons = hsIfaceCons (tcdCons decl), + ifCons = hsIfaceCons (tcdND decl) (tcdCons decl), ifRec = NonRecursive, ifVrcs = [], ifGeneric = False } -- I'm not sure that [] is right for ifVrcs, but @@ -262,12 +260,16 @@ hsIfaceDecl (TyClD decl@(ClassDecl {})) hsIfaceDecl decl = pprPanic "hsIfaceDecl" (ppr decl) -hsIfaceCons :: [LConDecl RdrName] -> DataConDetails IfaceConDecl -hsIfaceCons cons - | null cons -- data T a, meaning "constructors unspecified", not "no constructors" - = Unknown - | otherwise -- data T a = C1 | C2 - = DataCons (map (hsIfaceCon . unLoc) cons) +hsIfaceCons :: NewOrData -> [LConDecl RdrName] -> IfaceConDecls +hsIfaceCons DataType [] -- data T a, meaning "constructors unspecified", + = IfAbstractTyCon -- not "no constructors" + +hsIfaceCons DataType cons -- data type + = IfDataTyCon (map (hsIfaceCon . unLoc) cons) + +hsIfaceCons NewType [con] -- newtype + = IfNewTyCon (hsIfaceCon (unLoc con)) + hsIfaceCon :: ConDecl RdrName -> IfaceConDecl hsIfaceCon (ConDecl lname ex_tvs ex_ctxt details) diff --git a/ghc/compiler/prelude/TysWiredIn.lhs b/ghc/compiler/prelude/TysWiredIn.lhs index c8ffc3b..29d069d 100644 --- a/ghc/compiler/prelude/TysWiredIn.lhs +++ b/ghc/compiler/prelude/TysWiredIn.lhs @@ -65,7 +65,7 @@ import Name ( Name, nameUnique, nameOccName, import OccName ( mkOccFS, tcName, dataName, mkTupleOcc, mkDataConWorkerOcc ) import DataCon ( DataCon, mkDataCon, dataConWorkId, dataConSourceArity ) import Var ( TyVar, tyVarKind ) -import TyCon ( TyCon, AlgTyConFlavour(..), DataConDetails(..), tyConDataCons, +import TyCon ( TyCon, AlgTyConRhs(DataTyCon), tyConDataCons, mkTupleTyCon, mkAlgTyCon, tyConName ) @@ -176,9 +176,8 @@ pcTyCon is_enum is_rec name tyvars argvrcs cons tyvars [] -- No context argvrcs - (DataCons cons) + (DataTyCon cons is_enum) [] -- No record selectors - (DataTyCon is_enum) is_rec True -- All the wired-in tycons have generics diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs index ee506bc..b24701d 100644 --- a/ghc/compiler/typecheck/TcClassDcl.lhs +++ b/ghc/compiler/typecheck/TcClassDcl.lhs @@ -13,7 +13,7 @@ module TcClassDcl ( tcClassSigs, tcClassDecl2, #include "HsVersions.h" import HsSyn -import BasicTypes ( RecFlag(..), NewOrData(..) ) +import BasicTypes ( RecFlag(..) ) import RnHsSyn ( maybeGenericMatch, extractHsTyVars ) import RnExpr ( rnLExpr ) import RnEnv ( lookupTopBndrRn, lookupImportedName ) diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs index 38567e6..0f104c6 100644 --- a/ghc/compiler/typecheck/TcDeriv.lhs +++ b/ghc/compiler/typecheck/TcDeriv.lhs @@ -29,7 +29,6 @@ import RnEnv ( bindLocalNames ) import TcRnMonad ( thenM, returnM, mapAndUnzipM ) import HscTypes ( DFunId, FixityEnv ) -import BasicTypes ( NewOrData(..) ) import Class ( className, classArity, classKey, classTyVars, classSCTheta, Class ) import Subst ( mkTyVarSubst, substTheta ) import ErrUtils ( dumpIfSet_dyn ) diff --git a/ghc/compiler/typecheck/TcRnDriver.lhs b/ghc/compiler/typecheck/TcRnDriver.lhs index 2f7aef2..94681d8 100644 --- a/ghc/compiler/typecheck/TcRnDriver.lhs +++ b/ghc/compiler/typecheck/TcRnDriver.lhs @@ -87,7 +87,8 @@ import Inst ( tcStdSyntaxName ) import RnExpr ( rnStmts, rnLExpr ) import RnNames ( exportsToAvails ) import LoadIface ( loadSrcInterface ) -import IfaceSyn ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), IfaceExtName(..), +import IfaceSyn ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), + IfaceExtName(..), IfaceConDecls(..), tyThingToIfaceDecl ) import RnEnv ( lookupOccRn, dataTcOccs, lookupFixityRn ) import Id ( Id, isImplicitId ) @@ -864,8 +865,11 @@ getModuleContents hsc_env ictxt mod exports_only --------------------- filter_decl occs decl@(IfaceClass {ifSigs = sigs}) = decl { ifSigs = filter (keep_sig occs) sigs } -filter_decl occs decl@(IfaceData {ifCons = DataCons cons}) - = decl { ifCons = DataCons (filter (keep_con occs) cons) } +filter_decl occs decl@(IfaceData {ifCons = IfDataTyCon cons}) + = decl { ifCons = IfDataTyCon (filter (keep_con occs) cons) } +filter_decl occs decl@(IfaceData {ifCons = IfNewTyCon con}) + | keep_con occs con = decl + | otherwise = decl {ifCons = IfAbstractTyCon} -- Hmm? filter_decl occs decl = decl diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs index 5acb6a0..311d2b1 100644 --- a/ghc/compiler/typecheck/TcTyClsDecls.lhs +++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs @@ -11,13 +11,14 @@ module TcTyClsDecls ( #include "HsVersions.h" import HsSyn ( TyClDecl(..), HsConDetails(..), HsTyVarBndr(..), - ConDecl(..), Sig(..), BangType(..), HsBang(..), + ConDecl(..), Sig(..), BangType(..), HsBang(..), NewOrData(..), tyClDeclTyVars, getBangType, getBangStrictness, isSynDecl, LTyClDecl, tcdName, LHsTyVarBndr ) -import BasicTypes ( RecFlag(..), NewOrData(..), StrictnessMark(..) ) +import BasicTypes ( RecFlag(..), StrictnessMark(..) ) import HscTypes ( implicitTyThings ) -import BuildTyCl ( buildClass, buildAlgTyCon, buildSynTyCon, buildDataCon ) +import BuildTyCl ( buildClass, buildAlgTyCon, buildSynTyCon, buildDataCon, + mkDataTyConRhs, mkNewTyConRhs ) import TcRnMonad import TcEnv ( TcTyThing(..), TyThing(..), tcLookupLocated, tcLookupLocatedGlobal, @@ -37,7 +38,7 @@ import Type ( splitTyConApp_maybe, pprThetaArrow, pprParendType ) import FieldLabel ( fieldLabelName, fieldLabelType ) import Generics ( validGenericMethodType, canDoGenerics ) import Class ( Class, className, classTyCon, DefMeth(..), classBigSig, classTyVars ) -import TyCon ( TyCon, ArgVrcs, DataConDetails(..), +import TyCon ( TyCon, ArgVrcs, tyConDataCons, mkForeignTyCon, isProductTyCon, isRecursiveTyCon, tyConTheta, getSynTyConDefn, tyConDataCons, isSynTyCon, tyConName ) import DataCon ( DataCon, dataConWrapId, dataConName, dataConSig, dataConFieldLabels ) @@ -359,10 +360,14 @@ tcTyClDecl1 calc_vrcs calc_isrec { ctxt' <- tcHsKindedContext ctxt ; want_generic <- doptM Opt_Generics ; tycon <- fixM (\ tycon -> do - { cons' <- mappM (addLocM (tcConDecl new_or_data tycon tvs' ctxt')) cons - ; buildAlgTyCon new_or_data tc_name tvs' ctxt' - (DataCons cons') arg_vrcs is_rec - (want_generic && canDoGenerics cons') + { data_cons <- mappM (addLocM (tcConDecl new_or_data tycon tvs' ctxt')) cons + ; let tc_rhs = case new_or_data of + DataType -> mkDataTyConRhs data_cons + NewType -> ASSERT( isSingleton data_cons ) + mkNewTyConRhs (head data_cons) + ; buildAlgTyCon tc_name tvs' ctxt' + tc_rhs arg_vrcs is_rec + (want_generic && canDoGenerics data_cons) }) ; return (ATyCon tycon) } diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs index 586974b..1501d56 100644 --- a/ghc/compiler/typecheck/TcTyDecls.lhs +++ b/ghc/compiler/typecheck/TcTyDecls.lhs @@ -14,8 +14,7 @@ files for imported data types. module TcTyDecls( calcTyConArgVrcs, calcRecFlags, - calcClassCycles, calcSynCycles, - newTyConRhs + calcClassCycles, calcSynCycles ) where #include "HsVersions.h" @@ -24,11 +23,10 @@ import TypeRep ( Type(..), TyNote(..), PredType(..) ) -- friend import HsSyn ( TyClDecl(..), HsPred(..), LTyClDecl, isClassDecl ) import RnHsSyn ( extractHsTyNames ) import Type ( predTypeRep ) -import BuildTyCl ( newTyConRhs ) import HscTypes ( TyThing(..) ) import TyCon ( TyCon, ArgVrcs, tyConArity, tyConDataCons, tyConTyVars, getSynTyConDefn, isSynTyCon, isAlgTyCon, isHiBootTyCon, - tyConName, isNewTyCon, isProductTyCon, tyConArgVrcs ) + tyConName, isNewTyCon, isProductTyCon, tyConArgVrcs, newTyConRhs ) import Class ( classTyCon ) import DataCon ( dataConRepArgTys, dataConOrigArgTys ) import Var ( TyVar ) @@ -219,7 +217,7 @@ calcRecFlags tyclss nt_edges = [(t, mk_nt_edges t) | t <- new_tycons] mk_nt_edges nt -- Invariant: nt is a newtype - = concatMap (mk_nt_edges1 nt) (tcTyConsOfType (newTyConRhs nt)) + = concatMap (mk_nt_edges1 nt) (tcTyConsOfType (new_tc_rhs nt)) -- tyConsOfType looks through synonyms mk_nt_edges1 nt tc @@ -247,13 +245,15 @@ calcRecFlags tyclss | tc `elem` prod_tycons = [tc] -- Local product | tc `elem` new_tycons = if is_rec_nt tc -- Local newtype then [] - else mk_prod_edges1 ptc (newTyConRhs tc) + else mk_prod_edges1 ptc (new_tc_rhs tc) | isHiBootTyCon tc = [ptc] -- Make it self-recursive if -- it mentions an hi-boot TyCon -- At this point we know that either it's a local non-product data type, -- or it's imported. Either way, it can't form part of a cycle | otherwise = [] +new_tc_rhs tc = snd (newTyConRhs tc) -- Ignore the type variables + getTyCon (ATyCon tc) = tc getTyCon (AClass cl) = classTyCon cl diff --git a/ghc/compiler/typecheck/TcType.lhs b/ghc/compiler/typecheck/TcType.lhs index 7fdd14a..e41c696 100644 --- a/ghc/compiler/typecheck/TcType.lhs +++ b/ghc/compiler/typecheck/TcType.lhs @@ -866,7 +866,9 @@ toDNType ty checkRepTyCon :: (TyCon -> Bool) -> Type -> Bool -- Look through newtypes -- Non-recursive ones are transparent to splitTyConApp, - -- but recursive ones aren't + -- but recursive ones aren't. Manuel had: + -- newtype T = MkT (Ptr T) + -- and wanted it to work... checkRepTyCon check_tc ty | Just (tc,_) <- splitTyConApp_maybe (repType ty) = check_tc tc | otherwise = False diff --git a/ghc/compiler/types/TyCon.lhs b/ghc/compiler/types/TyCon.lhs index 681d6e3..396df9c 100644 --- a/ghc/compiler/types/TyCon.lhs +++ b/ghc/compiler/types/TyCon.lhs @@ -7,14 +7,13 @@ module TyCon( TyCon, ArgVrcs, - AlgTyConFlavour(..), - DataConDetails(..), visibleDataCons, + AlgTyConRhs(..), visibleDataCons, isFunTyCon, isUnLiftedTyCon, isProductTyCon, isAlgTyCon, isDataTyCon, isSynTyCon, isNewTyCon, isPrimTyCon, isEnumerationTyCon, isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, tupleTyConBoxity, - isRecursiveTyCon, newTyConRep, isHiBootTyCon, + isRecursiveTyCon, newTyConRep, newTyConRhs, isHiBootTyCon, mkForeignTyCon, isForeignTyCon, @@ -31,7 +30,7 @@ module TyCon( tyConUnique, tyConTyVars, tyConArgVrcs, - tyConDataConDetails, tyConDataCons, tyConDataCons_maybe, tyConFamilySize, + algTyConRhs, tyConDataCons, tyConDataCons_maybe, tyConFamilySize, tyConSelIds, tyConTheta, tyConPrimRep, @@ -83,7 +82,7 @@ data TyCon } - | AlgTyCon { -- Tuples, data type, and newtype decls. + | AlgTyCon { -- Data type, and newtype decls. -- All lifted, all boxed tyConUnique :: Unique, tyConName :: Name, @@ -94,15 +93,14 @@ data TyCon argVrcs :: ArgVrcs, algTyConTheta :: [PredType], - dataCons :: DataConDetails DataCon, + selIds :: [Id], -- Its record selectors (if any) - selIds :: [Id], -- Its record selectors (if any) + algTyConRhs :: AlgTyConRhs, -- Data constructors in here - algTyConFlavour :: AlgTyConFlavour, - algTyConRec :: RecFlag, -- Tells whether the data type is part of + algTyConRec :: RecFlag, -- Tells whether the data type is part of -- a mutually-recursive group or not - hasGenerics :: Bool, -- True <=> generic to/from functions are available + hasGenerics :: Bool, -- True <=> generic to/from functions are available -- (in the exports of the data type's source module) algTyConClass :: Maybe Class @@ -119,8 +117,8 @@ data TyCon primTyConRep :: PrimRep, -- Many primitive tycons are unboxed, but some are -- boxed (represented by pointers). The PrimRep tells. - isUnLifted :: Bool, -- Most primitive tycons are unlifted, - -- but foreign-imported ones may not be + isUnLifted :: Bool, -- Most primitive tycons are unlifted, + -- but foreign-imported ones may not be tyConExtName :: Maybe FastString -- Just xx for foreign-imported types } @@ -152,10 +150,23 @@ data TyCon type ArgVrcs = [(Bool,Bool)] -- Tyvar variance info: [(occPos,occNeg)] -- [] means "no information, assume the worst" -data AlgTyConFlavour - = DataTyCon Bool -- Data type; True <=> an enumeration type +data AlgTyConRhs + = AbstractTyCon -- We know nothing about this data type, except + -- that it's represented by a pointer + -- Used when we export a data type abstractly into + -- an hi file - | NewTyCon Type -- Newtype, with its *ultimate* representation type + | DataTyCon + [DataCon] -- The constructors; can be empty if the user declares + -- the type to have no constructors + Bool -- Cached: True <=> an enumeration type + + | NewTyCon -- Newtypes always have exactly one constructor + DataCon -- The unique constructor; it has no existentials + Type -- Cached: the argument type of the constructor + -- = the representation type of the tycon + + Type -- Cached: the *ultimate* representation type -- By 'ultimate' I mean that the rep type is not itself -- a newtype or type synonym. -- The rep type isn't entirely simple: @@ -168,18 +179,12 @@ data AlgTyConFlavour -- The rep type is [(a,Int)] -- NB: the rep type isn't necessarily the original RHS of the -- newtype decl, because the rep type looks through other - -- newtypes. If you want hte original RHS, look at the - -- argument type of the data constructor. - -data DataConDetails datacon - = DataCons [datacon] -- Its data constructors, with fully polymorphic types - -- A type can have zero constructors - - | Unknown -- Used only when We're importing this data type from an - -- hi-boot file, so we don't know what its constructors are + -- newtypes. -visibleDataCons (DataCons cs) = cs -visibleDataCons other = [] +visibleDataCons :: AlgTyConRhs -> [DataCon] +visibleDataCons AbstractTyCon = [] +visibleDataCons (DataTyCon cs _) = cs +visibleDataCons (NewTyCon c _ _) = [c] \end{code} @@ -208,7 +213,7 @@ mkFunTyCon name kind -- 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 sels flavour is_rec gen_info +mkAlgTyCon name kind tyvars theta argvrcs rhs sels is_rec gen_info = AlgTyCon { tyConName = name, tyConUnique = nameUnique name, @@ -217,15 +222,14 @@ mkAlgTyCon name kind tyvars theta argvrcs cons sels flavour is_rec gen_info tyConTyVars = tyvars, argVrcs = argvrcs, algTyConTheta = theta, - dataCons = cons, + algTyConRhs = rhs, selIds = sels, algTyConClass = Nothing, - algTyConFlavour = flavour, algTyConRec = is_rec, hasGenerics = gen_info } -mkClassTyCon name kind tyvars argvrcs con clas flavour is_rec +mkClassTyCon name kind tyvars argvrcs rhs clas is_rec = AlgTyCon { tyConName = name, tyConUnique = nameUnique name, @@ -234,10 +238,9 @@ mkClassTyCon name kind tyvars argvrcs con clas flavour is_rec tyConTyVars = tyvars, argVrcs = argvrcs, algTyConTheta = [], - dataCons = DataCons [con], + algTyConRhs = rhs, selIds = [], algTyConClass = Just clas, - algTyConFlavour = flavour, algTyConRec = is_rec, hasGenerics = False } @@ -319,15 +322,6 @@ isUnLiftedTyCon (PrimTyCon {isUnLifted = is_unlifted}) = is_unlifted isUnLiftedTyCon (TupleTyCon {tyConBoxed = boxity}) = not (isBoxed boxity) isUnLiftedTyCon _ = False -#ifdef UNUSED --- isBoxedTyCon should not be applied to SynTyCon, nor KindCon -isBoxedTyCon :: TyCon -> Bool -isBoxedTyCon (AlgTyCon {}) = True -isBoxedTyCon (FunTyCon {}) = True -isBoxedTyCon (TupleTyCon {tyConBoxed = boxity}) = isBoxed boxity -isBoxedTyCon (PrimTyCon {primTyConRep = rep}) = isFollowableRep rep -#endif - -- isAlgTyCon returns True for both @data@ and @newtype@ isAlgTyCon :: TyCon -> Bool isAlgTyCon (AlgTyCon {}) = True @@ -342,16 +336,17 @@ isDataTyCon :: TyCon -> Bool -- True for all @data@ types -- False for newtypes -- unboxed tuples -isDataTyCon (AlgTyCon {algTyConFlavour = new_or_data}) - = case new_or_data of - NewTyCon _ -> False - other -> True +isDataTyCon (AlgTyCon {algTyConRhs = rhs}) + = case rhs of + DataTyCon _ _ -> True + NewTyCon _ _ _ -> False + AbstractTyCon -> panic "isDataTyCon" isDataTyCon (TupleTyCon {tyConBoxed = boxity}) = isBoxed boxity isDataTyCon other = False isNewTyCon :: TyCon -> Bool -isNewTyCon (AlgTyCon {algTyConFlavour = NewTyCon _}) = True +isNewTyCon (AlgTyCon {algTyConRhs = NewTyCon _ _ _}) = True isNewTyCon other = False isProductTyCon :: TyCon -> Bool @@ -362,17 +357,20 @@ isProductTyCon :: TyCon -> Bool -- may be DataType or NewType, -- may be unboxed or not, -- may be recursive or not -isProductTyCon (AlgTyCon {dataCons = DataCons [data_con]}) = not (isExistentialDataCon data_con) -isProductTyCon (TupleTyCon {}) = True -isProductTyCon other = False +isProductTyCon tc@(AlgTyCon {}) = case algTyConRhs tc of + DataTyCon [data_con] _ -> not (isExistentialDataCon data_con) + NewTyCon _ _ _ -> True + other -> False +isProductTyCon (TupleTyCon {}) = True +isProductTyCon other = False isSynTyCon :: TyCon -> Bool isSynTyCon (SynTyCon {}) = True isSynTyCon _ = False isEnumerationTyCon :: TyCon -> Bool -isEnumerationTyCon (AlgTyCon {algTyConFlavour = DataTyCon is_enum}) = is_enum -isEnumerationTyCon other = False +isEnumerationTyCon (AlgTyCon {algTyConRhs = DataTyCon _ is_enum}) = is_enum +isEnumerationTyCon other = False isTupleTyCon :: TyCon -> Bool -- The unit tycon didn't used to be classed as a tuple tycon @@ -397,8 +395,8 @@ isRecursiveTyCon other = False isHiBootTyCon :: TyCon -> Bool -- Used for knot-tying in hi-boot files -isHiBootTyCon (AlgTyCon {dataCons = Unknown}) = True -isHiBootTyCon other = False +isHiBootTyCon (AlgTyCon {algTyConRhs = AbstractTyCon}) = True +isHiBootTyCon other = False isForeignTyCon :: TyCon -> Bool -- isForeignTyCon identifies foreign-imported type constructors @@ -413,24 +411,21 @@ tyConHasGenerics (AlgTyCon {hasGenerics = hg}) = hg tyConHasGenerics (TupleTyCon {hasGenerics = hg}) = hg tyConHasGenerics other = False -- Synonyms -tyConDataConDetails :: TyCon -> DataConDetails DataCon -tyConDataConDetails (AlgTyCon {dataCons = cons}) = cons -tyConDataConDetails (TupleTyCon {dataCon = con}) = DataCons [con] -tyConDataConDetails other = pprPanic "tyConDataConDetails" (ppr other) - tyConDataCons :: TyCon -> [DataCon] -- It's convenient for tyConDataCons to return the -- empty list for type synonyms etc tyConDataCons tycon = tyConDataCons_maybe tycon `orElse` [] tyConDataCons_maybe :: TyCon -> Maybe [DataCon] -tyConDataCons_maybe (AlgTyCon {dataCons = DataCons cons}) = Just cons -tyConDataCons_maybe (TupleTyCon {dataCon = con}) = Just [con] -tyConDataCons_maybe other = Nothing +tyConDataCons_maybe (AlgTyCon {algTyConRhs = DataTyCon cons _}) = Just cons +tyConDataCons_maybe (AlgTyCon {algTyConRhs = NewTyCon con _ _}) = Just [con] +tyConDataCons_maybe (TupleTyCon {dataCon = con}) = Just [con] +tyConDataCons_maybe other = Nothing tyConFamilySize :: TyCon -> Int -tyConFamilySize (AlgTyCon {dataCons = DataCons cs}) = length cs -tyConFamilySize (TupleTyCon {}) = 1 +tyConFamilySize (AlgTyCon {algTyConRhs = DataTyCon cons _}) = length cons +tyConFamilySize (AlgTyCon {algTyConRhs = NewTyCon _ _ _}) = 1 +tyConFamilySize (TupleTyCon {}) = 1 #ifdef DEBUG tyConFamilySize other = pprPanic "tyConFamilySize:" (ppr other) #endif @@ -442,7 +437,10 @@ tyConSelIds other_tycon = [] \begin{code} newTyConRep :: TyCon -> ([TyVar], Type) -newTyConRep (AlgTyCon {tyConTyVars = tvs, algTyConFlavour = NewTyCon rep}) = (tvs, rep) +newTyConRep (AlgTyCon {tyConTyVars = tvs, algTyConRhs = NewTyCon _ _ rep}) = (tvs, rep) + +newTyConRhs :: TyCon -> ([TyVar], Type) +newTyConRhs (AlgTyCon {tyConTyVars = tvs, algTyConRhs = NewTyCon _ rhs _}) = (tvs, rhs) tyConPrimRep :: TyCon -> PrimRep tyConPrimRep (PrimTyCon {primTyConRep = rep}) = rep @@ -479,11 +477,12 @@ getSynTyConDefn (SynTyCon {tyConTyVars = tyvars, synTyConDefn = ty}) = (tyvars,t \begin{code} maybeTyConSingleCon :: TyCon -> Maybe DataCon -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 (AlgTyCon {algTyConRhs = DataTyCon [c] _}) = Just c +maybeTyConSingleCon (AlgTyCon {algTyConRhs = NewTyCon 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} diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs index 8104513..bb3c670 100644 --- a/ghc/compiler/types/Type.lhs +++ b/ghc/compiler/types/Type.lhs @@ -84,9 +84,9 @@ import Name ( NamedThing(..), mkInternalName, tidyOccName ) import Class ( Class, classTyCon ) import TyCon ( TyCon, isRecursiveTyCon, isPrimTyCon, isUnboxedTupleTyCon, isUnLiftedTyCon, - isFunTyCon, isNewTyCon, newTyConRep, + isFunTyCon, isNewTyCon, newTyConRep, newTyConRhs, isAlgTyCon, isSynTyCon, tyConArity, - tyConKind, getSynTyConDefn, + tyConKind, getSynTyConDefn, tyConPrimRep, ) @@ -398,6 +398,12 @@ typePrimRep ty = case repType ty of AppTy _ _ -> PtrRep -- ?? TyVarTy _ -> PtrRep other -> pprPanic "typePrimRep" (ppr ty) + +-- new_type_rep doesn't ask any questions: +-- it just expands newtype, whether recursive or not +new_type_rep new_tycon tys = ASSERT( tys `lengthIs` tyConArity new_tycon ) + case newTyConRep new_tycon of + (tvs, rep_ty) -> substTyWith tvs tys rep_ty \end{code} @@ -512,6 +518,8 @@ mkPredTys preds = map PredTy preds predTypeRep :: PredType -> Type -- Convert a PredType to its "representation type"; -- the post-type-checking type used by all the Core passes of GHC. +-- Unwraps only the outermost level; for example, the result might +-- be a NewTcApp; c.f. newTypeRep predTypeRep (IParam _ ty) = ty predTypeRep (ClassP clas tys) = mkTyConApp (classTyCon clas) tys -- Result might be a NewTcApp, but the consumer will @@ -529,24 +537,33 @@ predTypeRep (ClassP clas tys) = mkTyConApp (classTyCon clas) tys splitRecNewType_maybe :: Type -> Maybe Type -- Newtypes are always represented by a NewTcApp -- Sometimes we want to look through a recursive newtype, and that's what happens here +-- It only strips *one layer* off, so the caller will usually call itself recursively -- Only applied to types of kind *, hence the newtype is always saturated splitRecNewType_maybe (NoteTy _ ty) = splitRecNewType_maybe ty splitRecNewType_maybe (PredTy p) = splitRecNewType_maybe (predTypeRep p) splitRecNewType_maybe (NewTcApp tc tys) | isRecursiveTyCon tc = ASSERT( tys `lengthIs` tyConArity tc && isNewTyCon tc ) - -- The assert should hold because repType should - -- only be applied to *types* (of kind *) - Just (new_type_rep tc tys) + -- The assert should hold because splitRecNewType_maybe + -- should only be applied to *types* (of kind *) + Just (new_type_rhs tc tys) splitRecNewType_maybe other = Nothing ----------------------------- newTypeRep :: TyCon -> [Type] -> Type -- A local helper function (not exported) --- Expands a newtype application to +-- Expands *the outermoset level of* a newtype application to -- *either* a vanilla TyConApp (recursive newtype, or non-saturated) --- *or* the newtype representation (otherwise) --- Either way, the result is not a NewTcApp +-- *or* the newtype representation (otherwise), meaning the +-- type written in the RHS of the newtype decl, +-- which may itself be a newtype +-- +-- Example: newtype R = MkR S +-- newtype S = MkS T +-- newtype T = MkT (T -> T) +-- newTypeRep on R gives NewTcApp S +-- on S gives NewTcApp T +-- on T gives TyConApp T -- -- NB: the returned TyConApp is always deconstructed immediately by the -- caller... a TyConApp with a newtype type constructor never lives @@ -554,17 +571,16 @@ newTypeRep :: TyCon -> [Type] -> Type newTypeRep tc tys | not (isRecursiveTyCon tc), -- Not recursive and saturated tys `lengthIs` tyConArity tc -- treat as equivalent to expansion - = new_type_rep tc tys + = new_type_rhs tc tys | otherwise = TyConApp tc tys -- ToDo: Consider caching this substitution in a NType ----------------------------- --- new_type_rep doesn't ask any questions: --- it just expands newtype, whether recursive or not -new_type_rep new_tycon tys = ASSERT( tys `lengthIs` tyConArity new_tycon ) - case newTyConRep new_tycon of - (tvs, rep_ty) -> substTyWith tvs tys rep_ty +-- new_type_rhs doesn't ask any questions: +-- it just expands newtype one level, whether recursive or not +new_type_rhs tc tys + = case newTyConRhs tc of + (tvs, rep_ty) -> substTyWith tvs tys rep_ty \end{code} -- 1.7.10.4