diff options
| author | Ben Gamari <ben@smart-cactus.org> | 2015-08-26 18:24:34 +0200 |
|---|---|---|
| committer | Ben Gamari <ben@smart-cactus.org> | 2015-10-29 16:14:51 +0100 |
| commit | bef2f03e4d56d88a7e9752a7afd6a0a35616da6c (patch) | |
| tree | 9ae33978cf43d8268a6c5afa42e7a6c8a7e227a1 | |
| parent | 40e6214c06bc197dbdfcf9f7345dad1ad271922b (diff) | |
| download | haskell-bef2f03e4d56d88a7e9752a7afd6a0a35616da6c.tar.gz | |
Generate Typeable info at definition sites
This patch implements the idea floated in Trac #9858, namely that we
should generate type-representation information at the data type
declaration site, rather than when solving a Typeable constraint.
However, this turned out quite a bit harder than I expected. I still
think it's the right thing to do, and it's done now, but it was quite
a struggle.
See particularly
* Note [Grand plan for Typeable] in TcTypeable (which is a new module)
* Note [The overall promotion story] in DataCon (clarifies existing stuff)
The most painful bit was that to generate Typeable instances (ie
TyConRepName bindings) for every TyCon is tricky for types in ghc-prim
etc:
* We need to have enough data types around to *define* a TyCon
* Many of these types are wired-in
Also, to minimise the code generated for each data type, I wanted to
generate pure data, not CAFs with unpackCString# stuff floating about.
Performance
~~~~~~~~~~~
Three perf/compiler tests start to allocate quite a bit more. This isn't
surprising, because they all allocate zillions of data types, with
practically no other code, esp. T1969
* T3294: GHC allocates 110% more (filed #11030 to track this)
* T1969: GHC allocates 30% more
* T4801: GHC allocates 14% more
* T5321FD: GHC allocates 13% more
* T783: GHC allocates 12% more
* T9675: GHC allocates 12% more
* T5642: GHC allocates 10% more
* T9961: GHC allocates 6% more
* T9203: Program allocates 54% less
I'm treating this as acceptable. The payoff comes in Typeable-heavy
code.
Remaining to do
~~~~~~~~~~~~~~~
* I think that "TyCon" and "Module" are over-generic names to use for
the runtime type representations used in GHC.Typeable. Better might be
"TrTyCon" and "TrModule". But I have not yet done this
* Add more info the the "TyCon" e.g. source location where it was
defined
* Use the new "Module" type to help with Trac Trac #10068
* It would be possible to generate TyConRepName (ie Typeable
instances) selectively rather than all the time. We'd need to persist
the information in interface files. Lacking a motivating reason I have
not done this, but it would not be difficult.
Refactoring
~~~~~~~~~~~
As is so often the case, I ended up refactoring more than I intended.
In particular
* In TyCon, a type *family* (whether type or data) is repesented by a
FamilyTyCon
* a algebraic data type (including data/newtype instances) is
represented by AlgTyCon This wasn't true before; a data family
was represented as an AlgTyCon. There are some corresponding
changes in IfaceSyn.
* Also get rid of the (unhelpfully named) tyConParent.
* In TyCon define 'Promoted', isomorphic to Maybe, used when things are
optionally promoted; and use it elsewhere in GHC.
* Cleanup handling of knownKeyNames
* Each TyCon, including promoted TyCons, contains its TyConRepName, if
it has one. This is, in effect, the name of its Typeable instance.
Requires update of the haddock submodule.
Differential Revision: https://phabricator.haskell.org/D757
109 files changed, 2637 insertions, 1359 deletions
diff --git a/compiler/basicTypes/DataCon.hs b/compiler/basicTypes/DataCon.hs index 76bdaa0a80..9a827e03ee 100644 --- a/compiler/basicTypes/DataCon.hs +++ b/compiler/basicTypes/DataCon.hs @@ -35,7 +35,8 @@ module DataCon ( dataConSrcBangs, dataConSourceArity, dataConRepArity, dataConRepRepArity, dataConIsInfix, - dataConWorkId, dataConWrapId, dataConWrapId_maybe, dataConImplicitIds, + dataConWorkId, dataConWrapId, dataConWrapId_maybe, + dataConImplicitTyThings, dataConRepStrictness, dataConImplBangs, dataConBoxer, splitDataProductType_maybe, @@ -46,16 +47,18 @@ module DataCon ( isBanged, isMarkedStrict, eqHsBang, isSrcStrict, isSrcUnpacked, -- ** Promotion related functions - promoteKind, promoteDataCon, promoteDataCon_maybe + promoteDataCon, promoteDataCon_maybe, + promoteType, promoteKind, + isPromotableType, computeTyConPromotability, ) where #include "HsVersions.h" import {-# SOURCE #-} MkId( DataConBoxer ) import Type +import ForeignCall( CType ) import TypeRep( Type(..) ) -- Used in promoteType import PrelNames( liftedTypeKindTyConKey ) -import ForeignCall( CType ) import Coercion import Kind import Unify @@ -72,11 +75,11 @@ import BasicTypes import FastString import Module import VarEnv +import NameSet import Binary import qualified Data.Data as Data import qualified Data.Typeable -import Data.Maybe import Data.Char import Data.Word import Data.List( mapAccumL, find ) @@ -399,8 +402,8 @@ data DataCon -- Used for Template Haskell and 'deriving' only -- The actual fixity is stored elsewhere - dcPromoted :: Maybe TyCon -- The promoted TyCon if this DataCon is promotable - -- See Note [Promoted data constructors] in TyCon + dcPromoted :: Promoted TyCon -- The promoted TyCon if this DataCon is promotable + -- See Note [Promoted data constructors] in TyCon } deriving Data.Typeable.Typeable @@ -671,7 +674,9 @@ isMarkedStrict _ = True -- All others are strict -- | Build a new data constructor mkDataCon :: Name -> Bool -- ^ Is the constructor declared infix? - -> [HsSrcBang] -- ^ Strictness/unpack annotations, from user + -> Promoted TyConRepName -- ^ Whether promoted, and if so the TyConRepName + -- for the promoted TyCon + -> [HsSrcBang] -- ^ Strictness/unpack annotations, from user -> [FieldLabel] -- ^ Field labels for the constructor, -- if it is a record, otherwise empty -> [TyVar] -- ^ Universally quantified type variables @@ -688,7 +693,7 @@ mkDataCon :: Name -> DataCon -- Can get the tag from the TyCon -mkDataCon name declared_infix +mkDataCon name declared_infix prom_info arg_stricts -- Must match orig_arg_tys 1-1 fields univ_tvs ex_tvs @@ -733,15 +738,12 @@ mkDataCon name declared_infix mkTyConApp rep_tycon (mkTyVarTys univ_tvs) mb_promoted -- See Note [Promoted data constructors] in TyCon - | isJust (promotableTyCon_maybe rep_tycon) - -- The TyCon is promotable only if all its datacons - -- are, so the promoteType for prom_kind should succeed - = Just (mkPromotedDataCon con name (getUnique name) prom_kind roles) - | otherwise - = Nothing - prom_kind = promoteType (dataConUserType con) - roles = map (const Nominal) (univ_tvs ++ ex_tvs) ++ - map (const Representational) orig_arg_tys + = case prom_info of + NotPromoted -> NotPromoted + Promoted rep_nm -> Promoted (mkPromotedDataCon con name rep_nm prom_kind prom_roles) + prom_kind = promoteType (dataConUserType con) + prom_roles = map (const Nominal) (univ_tvs ++ ex_tvs) ++ + map (const Representational) orig_arg_tys eqSpecPreds :: [(TyVar,Type)] -> ThetaType eqSpecPreds spec = [ mkEqPred (mkTyVarTy tv) ty | (tv,ty) <- spec ] @@ -824,11 +826,13 @@ dataConWrapId dc = case dcRep dc of -- | Find all the 'Id's implicitly brought into scope by the data constructor. Currently, -- the union of the 'dataConWorkId' and the 'dataConWrapId' -dataConImplicitIds :: DataCon -> [Id] -dataConImplicitIds (MkData { dcWorkId = work, dcRep = rep}) - = case rep of - NoDataConRep -> [work] - DCR { dcr_wrap_id = wrap } -> [wrap,work] +dataConImplicitTyThings :: DataCon -> [TyThing] +dataConImplicitTyThings (MkData { dcWorkId = work, dcRep = rep }) + = [AnId work] ++ wrap_ids + where + wrap_ids = case rep of + NoDataConRep -> [] + DCR { dcr_wrap_id = wrap } -> [AnId wrap] -- | The labels for the fields of this particular 'DataCon' dataConFieldLabels :: DataCon -> [FieldLabel] @@ -1073,60 +1077,112 @@ dataConCannotMatch tys con {- ************************************************************************ * * - Building an algebraic data type + Promotion + + These functions are here becuase + - isPromotableTyCon calls dataConFullSig + - mkDataCon calls promoteType + - It's nice to keep the promotion stuff together * * ************************************************************************ -buildAlgTyCon is here because it is called from TysWiredIn, which in turn -depends on DataCon, but not on BuildTyCl. --} - -buildAlgTyCon :: Name - -> [TyVar] -- ^ Kind variables and type variables - -> [Role] - -> Maybe CType - -> ThetaType -- ^ Stupid theta - -> AlgTyConRhs - -> RecFlag - -> Bool -- ^ True <=> this TyCon is promotable - -> Bool -- ^ True <=> was declared in GADT syntax - -> TyConParent - -> TyCon - -buildAlgTyCon tc_name ktvs roles cType stupid_theta rhs - is_rec is_promotable gadt_syn parent - = tc - where - kind = mkPiKinds ktvs liftedTypeKind - - -- tc and mb_promoted_tc are mutually recursive - tc = mkAlgTyCon tc_name kind ktvs roles cType stupid_theta - rhs parent is_rec gadt_syn - mb_promoted_tc +Note [The overall promotion story] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Here is the overall plan. + +* Compared to a TyCon T, the promoted 'T has + same Name (and hence Unique) + same TyConRepName + In future the two will collapse into one anyhow. + +* Compared to a DataCon K, the promoted 'K (a type constructor) has + same Name (and hence Unique) + But it has a fresh TyConRepName; after all, the DataCon doesn't have + a TyConRepName at all. (See Note [Grand plan for Typeable] in TcTypeable + for TyConRepName.) + + Why does 'K have the same unique as K? It's acceptable because we don't + mix types and terms, so we won't get them confused. And it's helpful mainly + so that we know when to print 'K as a qualified name in error message. The + PrintUnqualified stuff depends on whether K is lexically in scope.. but 'K + never is! + +* It follows that the tick-mark (eg 'K) is not part of the Occ name of + either promoted data constructors or type constructors. Instead, + pretty-printing: the pretty-printer prints a tick in front of + - promoted DataCons (always) + - promoted TyCons (with -dppr-debug) + See TyCon.pprPromotionQuote + +* For a promoted data constructor K, the pipeline goes like this: + User writes (in a type): K or 'K + Parser produces OccName: K{tc} or K{d}, respectively + Renamer makes Name: M.K{d}_r62 (i.e. same unique as DataCon K) + and K{tc} has been turned into K{d} + provided it was unambiguous + Typechecker makes TyCon: PromotedDataCon MK{d}_r62 + + +Note [Checking whether a group is promotable] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We only want to promote a TyCon if all its data constructors +are promotable; it'd be very odd to promote some but not others. - mb_promoted_tc - | is_promotable = Just (mkPromotedTyCon tc (promoteKind kind)) - | otherwise = Nothing +But the data constructors may mention this or other TyCons. -{- -************************************************************************ -* * - Promoting of data types to the kind level -* * -************************************************************************ +So we treat the recursive uses as all OK (ie promotable) and +do one pass to check that each TyCon is promotable. -These two 'promoted..' functions are here because - * They belong together - * 'promoteDataCon' depends on DataCon stuff +Currently type synonyms are not promotable, though that +could change. -} promoteDataCon :: DataCon -> TyCon -promoteDataCon (MkData { dcPromoted = Just tc }) = tc +promoteDataCon (MkData { dcPromoted = Promoted tc }) = tc promoteDataCon dc = pprPanic "promoteDataCon" (ppr dc) -promoteDataCon_maybe :: DataCon -> Maybe TyCon +promoteDataCon_maybe :: DataCon -> Promoted TyCon promoteDataCon_maybe (MkData { dcPromoted = mb_tc }) = mb_tc +computeTyConPromotability :: NameSet -> TyCon -> Bool +computeTyConPromotability rec_tycons tc + = isAlgTyCon tc -- Only algebraic; not even synonyms + -- (we could reconsider the latter) + && ok_kind (tyConKind tc) + && case algTyConRhs tc of + DataTyCon { data_cons = cs } -> all ok_con cs + TupleTyCon { data_con = c } -> ok_con c + NewTyCon { data_con = c } -> ok_con c + AbstractTyCon {} -> False + where + ok_kind kind = all isLiftedTypeKind args && isLiftedTypeKind res + where -- Checks for * -> ... -> * -> * + (args, res) = splitKindFunTys kind + + -- See Note [Promoted data constructors] in TyCon + ok_con con = all (isLiftedTypeKind . tyVarKind) ex_tvs + && null eq_spec -- No constraints + && null theta + && all (isPromotableType rec_tycons) orig_arg_tys + where + (_, ex_tvs, eq_spec, theta, orig_arg_tys, _) = dataConFullSig con + + +isPromotableType :: NameSet -> Type -> Bool +-- Must line up with promoteType +-- But the function lives here because we must treat the +-- *recursive* tycons as promotable +isPromotableType rec_tcs con_arg_ty + = go con_arg_ty + where + go (TyConApp tc tys) = tys `lengthIs` tyConArity tc + && (tyConName tc `elemNameSet` rec_tcs + || isPromotableTyCon tc) + && all go tys + go (FunTy arg res) = go arg && go res + go (TyVarTy {}) = True + go _ = False + {- Note [Promoting a Type to a Kind] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1156,7 +1212,7 @@ promoteType ty kvs = [ mkKindVar (tyVarName tv) superKind | tv <- tvs ] env = zipVarEnv tvs kvs - go (TyConApp tc tys) | Just prom_tc <- promotableTyCon_maybe tc + go (TyConApp tc tys) | Promoted prom_tc <- promotableTyCon_maybe tc = mkTyConApp prom_tc (map go tys) go (FunTy arg res) = mkArrowKind (go arg) (go res) go (TyVarTy tv) | Just kv <- lookupVarEnv env tv @@ -1208,3 +1264,41 @@ splitDataProductType_maybe ty = Just (tycon, ty_args, con, dataConInstArgTys con ty_args) | otherwise = Nothing + +{- +************************************************************************ +* * + Building an algebraic data type +* * +************************************************************************ + +buildAlgTyCon is here because it is called from TysWiredIn, which can +depend on this module, but not on BuildTyCl. +-} + +buildAlgTyCon :: Name + -> [TyVar] -- ^ Kind variables and type variables + -> [Role] + -> Maybe CType + -> ThetaType -- ^ Stupid theta + -> AlgTyConRhs + -> RecFlag + -> Bool -- ^ True <=> this TyCon is promotable + -> Bool -- ^ True <=> was declared in GADT syntax + -> AlgTyConFlav + -> TyCon + +buildAlgTyCon tc_name ktvs roles cType stupid_theta rhs + is_rec is_promotable gadt_syn parent + = tc + where + kind = mkPiKinds ktvs liftedTypeKind + + -- tc and mb_promoted_tc are mutually recursive + tc = mkAlgTyCon tc_name kind ktvs roles cType stupid_theta + rhs parent is_rec gadt_syn + mb_promoted_tc + + mb_promoted_tc + | is_promotable = Promoted (mkPromotedTyCon tc (promoteKind kind)) + | otherwise = NotPromoted diff --git a/compiler/basicTypes/OccName.hs b/compiler/basicTypes/OccName.hs index 67942df518..e2997096aa 100644 --- a/compiler/basicTypes/OccName.hs +++ b/compiler/basicTypes/OccName.hs @@ -72,6 +72,7 @@ module OccName ( mkPReprTyConOcc, mkPADFunOcc, mkRecFldSelOcc, + mkTyConRepUserOcc, mkTyConRepSysOcc, -- ** Deconstruction occNameFS, occNameString, occNameSpace, @@ -586,7 +587,8 @@ mkDataConWrapperOcc, mkWorkerOcc, mkGenR, mkGen1R, mkGenRCo, mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc, mkNewTyCoOcc, mkInstTyCoOcc, mkEqPredCoOcc, mkClassOpAuxOcc, - mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc + mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc, + mkTyConRepUserOcc, mkTyConRepSysOcc :: OccName -> OccName -- These derived variables have a prefix that no Haskell value could have @@ -609,11 +611,24 @@ mkNewTyCoOcc = mk_simple_deriv tcName "NTCo:" -- Coercion for newtypes mkInstTyCoOcc = mk_simple_deriv tcName "TFCo:" -- Coercion for type functions mkEqPredCoOcc = mk_simple_deriv tcName "$co" --- used in derived instances +-- Used in derived instances mkCon2TagOcc = mk_simple_deriv varName "$con2tag_" mkTag2ConOcc = mk_simple_deriv varName "$tag2con_" mkMaxTagOcc = mk_simple_deriv varName "$maxtag_" +-- TyConRepName stuff; see Note [Grand plan for Typeable] in TcTypeable +-- incluing the wrinkle about mkSpecialTyConRepName +mkTyConRepSysOcc occ = mk_simple_deriv varName prefix occ + where + prefix | isDataOcc occ = "$tc'" + | otherwise = "$tc" + +mkTyConRepUserOcc occ = mk_simple_deriv varName prefix occ + where + -- *User-writable* prefix, for types in gHC_TYPES + prefix | isDataOcc occ = "tc'" + | otherwise = "tc" + -- Generic deriving mechanism -- | Generate a module-unique name, to be used e.g. while generating new names diff --git a/compiler/basicTypes/Unique.hs b/compiler/basicTypes/Unique.hs index 12629ff91a..5705c6fbaf 100644 --- a/compiler/basicTypes/Unique.hs +++ b/compiler/basicTypes/Unique.hs @@ -48,10 +48,13 @@ module Unique ( mkPreludeTyConUnique, mkPreludeClassUnique, mkPArrDataConUnique, - mkVarOccUnique, mkDataOccUnique, mkTvOccUnique, mkTcOccUnique, + mkVarOccUnique, mkDataOccUnique, mkTvOccUnique, mkTcOccUnique, mkRegSingleUnique, mkRegPairUnique, mkRegClassUnique, mkRegSubUnique, mkCostCentreUnique, + tyConRepNameUnique, + dataConWorkerUnique, dataConRepNameUnique, + mkBuiltinUnique, mkPseudoUniqueD, mkPseudoUniqueE, @@ -99,9 +102,10 @@ unpkUnique :: Unique -> (Char, Int) -- The reverse mkUniqueGrimily :: Int -> Unique -- A trap-door for UniqSupply getKey :: Unique -> Int -- for Var -incrUnique :: Unique -> Unique -deriveUnique :: Unique -> Int -> Unique -newTagUnique :: Unique -> Char -> Unique +incrUnique :: Unique -> Unique +stepUnique :: Unique -> Int -> Unique +deriveUnique :: Unique -> Int -> Unique +newTagUnique :: Unique -> Char -> Unique mkUniqueGrimily = MkUnique @@ -109,9 +113,11 @@ mkUniqueGrimily = MkUnique getKey (MkUnique x) = x incrUnique (MkUnique i) = MkUnique (i + 1) +stepUnique (MkUnique i) n = MkUnique (i + n) -- deriveUnique uses an 'X' tag so that it won't clash with -- any of the uniques produced any other way +-- SPJ says: this looks terribly smelly to me! deriveUnique (MkUnique i) delta = mkUnique 'X' (i + delta) -- newTagUnique changes the "domain" of a unique to a different char @@ -305,14 +311,19 @@ mkPArrDataConUnique :: Int -> Unique mkAlphaTyVarUnique i = mkUnique '1' i mkPreludeClassUnique i = mkUnique '2' i --- Prelude type constructors occupy *three* slots. --- The first is for the tycon itself; the latter two --- are for the generic to/from Ids. See TysWiredIn.mk_tc_gen_info. +-------------------------------------------------- +-- Wired-in data constructor keys occupy *three* slots: +-- * u: the DataCon itself +-- * u+1: its worker Id +-- * u+2: the TyConRepName of the promoted TyCon +-- Prelude data constructors are too simple to need wrappers. +mkPreludeTyConUnique i = mkUnique '3' (3*i) +mkTupleTyConUnique Boxed a = mkUnique '4' (3*a) +mkTupleTyConUnique Unboxed a = mkUnique '5' (3*a) +mkCTupleTyConUnique a = mkUnique 'k' (3*a) -mkPreludeTyConUnique i = mkUnique '3' (3*i) -mkTupleTyConUnique Boxed a = mkUnique '4' (3*a) -mkTupleTyConUnique Unboxed a = mkUnique '5' (3*a) -mkCTupleTyConUnique a = mkUnique 'k' (3*a) +tyConRepNameUnique :: Unique -> Unique +tyConRepNameUnique u = incrUnique u -- Data constructor keys occupy *two* slots. The first is used for the -- data constructor itself and its wrapper function (the function that @@ -320,10 +331,22 @@ mkCTupleTyConUnique a = mkUnique 'k' (3*a) -- used for the worker function (the function that builds the constructor -- representation). -mkPreludeDataConUnique i = mkUnique '6' (2*i) -- Must be alphabetic -mkTupleDataConUnique Boxed a = mkUnique '7' (2*a) -- ditto (*may* be used in C labels) -mkTupleDataConUnique Unboxed a = mkUnique '8' (2*a) +-------------------------------------------------- +-- Wired-in data constructor keys occupy *three* slots: +-- * u: the DataCon itself +-- * u+1: its worker Id +-- * u+2: the TyConRepName of the promoted TyCon +-- Prelude data constructors are too simple to need wrappers. + +mkPreludeDataConUnique i = mkUnique '6' (3*i) -- Must be alphabetic +mkTupleDataConUnique Boxed a = mkUnique '7' (3*a) -- ditto (*may* be used in C labels) +mkTupleDataConUnique Unboxed a = mkUnique '8' (3*a) + +dataConRepNameUnique, dataConWorkerUnique :: Unique -> Unique +dataConWorkerUnique u = incrUnique u +dataConRepNameUnique u = stepUnique u 2 +-------------------------------------------------- mkPrimOpIdUnique op = mkUnique '9' op mkPreludeMiscIdUnique i = mkUnique '0' i diff --git a/compiler/coreSyn/MkCore.hs b/compiler/coreSyn/MkCore.hs index fb797f11ce..8670e2104e 100644 --- a/compiler/coreSyn/MkCore.hs +++ b/compiler/coreSyn/MkCore.hs @@ -126,12 +126,12 @@ mkCoreLets binds body = foldr mkCoreLet body binds -- | Construct an expression which represents the application of one expression -- to the other -mkCoreApp :: CoreExpr -> CoreExpr -> CoreExpr +mkCoreApp :: SDoc -> CoreExpr -> CoreExpr -> CoreExpr -- Respects the let/app invariant by building a case expression where necessary -- See CoreSyn Note [CoreSyn let/app invariant] -mkCoreApp fun (Type ty) = App fun (Type ty) -mkCoreApp fun (Coercion co) = App fun (Coercion co) -mkCoreApp fun arg = ASSERT2( isFunTy fun_ty, ppr fun $$ ppr arg ) +mkCoreApp _ fun (Type ty) = App fun (Type ty) +mkCoreApp _ fun (Coercion co) = App fun (Coercion co) +mkCoreApp d fun arg = ASSERT2( isFunTy fun_ty, ppr fun $$ ppr arg $$ d ) mk_val_app fun arg arg_ty res_ty where fun_ty = exprType fun diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs index 4fa09cb42a..93b50dfc7c 100644 --- a/compiler/deSugar/DsBinds.hs +++ b/compiler/deSugar/DsBinds.hs @@ -44,10 +44,11 @@ import TyCon import TcEvidence import TcType import Type -import Kind (returnsConstraintKind) +import Kind( isKind ) import Coercion hiding (substCo) import TysWiredIn ( eqBoxDataCon, coercibleDataCon, mkListTy - , mkBoxedTupleTy, charTy, typeNatKind, typeSymbolKind ) + , mkBoxedTupleTy, charTy + , typeNatKind, typeSymbolKind ) import Id import MkId(proxyHashId) import Class @@ -70,15 +71,12 @@ import FastString import Util import MonadUtils import Control.Monad(liftM,when) -import Fingerprint(Fingerprint(..), fingerprintString) -{- -************************************************************************ +{-********************************************************************** * * -\subsection[dsMonoBinds]{Desugaring a @MonoBinds@} + Desugaring a MonoBinds * * -************************************************************************ --} +**********************************************************************-} dsTopLHsBinds :: LHsBinds Id -> DsM (OrdList (Id,CoreExpr)) dsTopLHsBinds binds = ds_lhs_binds binds @@ -815,7 +813,7 @@ dsHsWrapper (WpCompose c1 c2) e = do { e1 <- dsHsWrapper c2 e ; dsHsWrapper c1 e1 } dsHsWrapper (WpFun c1 c2 t1 _) e = do { x <- newSysLocalDs t1 ; e1 <- dsHsWrapper c1 (Var x) - ; e2 <- dsHsWrapper c2 (e `mkCoreAppDs` e1) + ; e2 <- dsHsWrapper c2 (mkCoreAppDs (text "dsHsWrapper") e e1) ; return (Lam x e2) } dsHsWrapper (WpCast co) e = ASSERT(tcCoercionRole co == Representational) dsTcCoercion co (mkCastDs e) @@ -853,154 +851,145 @@ sccEvBinds bs = stronglyConnCompFromEdgedVertices edges = (b, var, varSetElems (evVarsOfTerm term)) ---------------------------------------- +{-********************************************************************** +* * + Desugaring EvTerms +* * +**********************************************************************-} + dsEvTerm :: EvTerm -> DsM CoreExpr -dsEvTerm (EvId v) = return (Var v) +dsEvTerm (EvId v) = return (Var v) +dsEvTerm (EvCallStack cs) = dsEvCallStack cs +dsEvTerm (EvTypeable ty ev) = dsEvTypeable ty ev +dsEvTerm (EvLit (EvNum n)) = mkIntegerExpr n +dsEvTerm (EvLit (EvStr s)) = mkStringExprFS s dsEvTerm (EvCast tm co) = do { tm' <- dsEvTerm tm ; dsTcCoercion co $ mkCastDs tm' } - -- 'v' is always a lifted evidence variable so it is - -- unnecessary to call varToCoreExpr v here. + -- 'v' is always a lifted evidence variable so it is + -- unnecessary to call varToCoreExpr v here. + +dsEvTerm (EvDFunApp df tys tms) + = return (Var df `mkTyApps` tys `mkApps` (map Var tms)) -dsEvTerm (EvDFunApp df tys tms) = return (Var df `mkTyApps` tys `mkApps` (map Var tms)) dsEvTerm (EvCoercion (TcCoVarCo v)) = return (Var v) -- See Note [Simple coercions] dsEvTerm (EvCoercion co) = dsTcCoercion co mkEqBox + dsEvTerm (EvSuperClass d n) = do { d' <- dsEvTerm d ; let (cls, tys) = getClassPredTys (exprType d') sc_sel_id = classSCSelId cls n -- Zero-indexed ; return $ Var sc_sel_id `mkTyApps` tys `App` d' } -dsEvTerm (EvDelayedError ty msg) = return $ Var errorId `mkTyApps` [ty] `mkApps` [litMsg] +dsEvTerm (EvDelayedError ty msg) + = return $ Var errorId `mkTyApps` [ty] `mkApps` [litMsg] where errorId = tYPE_ERROR_ID litMsg = Lit (MachStr (fastStringToByteString msg)) -dsEvTerm (EvLit l) = - case l of - EvNum n -> mkIntegerExpr n - EvStr s -> mkStringExprFS s - -dsEvTerm (EvCallStack cs) = dsEvCallStack cs - -dsEvTerm (EvTypeable ev) = dsEvTypeable ev - -dsEvTypeable :: EvTypeable -> DsM CoreExpr -dsEvTypeable ev = - do tyCl <- dsLookupTyCon typeableClassName - typeRepTc <- dsLookupTyCon typeRepTyConName - let tyRepType = mkTyConApp typeRepTc [] - - (ty, rep) <- - case ev of - - EvTypeableTyCon tc ks -> - do ctr <- dsLookupGlobalId mkPolyTyConAppName - mkTyCon <- dsLookupGlobalId mkTyConName - dflags <- getDynFlags - let mkRep cRep kReps tReps = - mkApps (Var ctr) [ cRep, mkListExpr tyRepType kReps - , mkListExpr tyRepType tReps ] - - let kindRep k = - case splitTyConApp_maybe k of - Nothing -> panic "dsEvTypeable: not a kind constructor" - Just (kc,ks) -> - do kcRep <- tyConRep dflags mkTyCon kc - reps <- mapM kindRep ks - return (mkRep kcRep [] reps) - - tcRep <- tyConRep dflags mkTyCon tc - - kReps <- mapM kindRep ks - - return ( mkTyConApp tc ks - , mkRep tcRep kReps [] - ) - - EvTypeableTyApp t1 t2 -> - do e1 <- getRep tyCl t1 - e2 <- getRep tyCl t2 - ctr <- dsLookupGlobalId mkAppTyName - - return ( mkAppTy (snd t1) (snd t2) - , mkApps (Var ctr) [ e1, e2 ] - ) - - EvTypeableTyLit t -> - do e <- tyLitRep t - return (snd t, e) - - -- TyRep -> Typeable t - -- see also: Note [Memoising typeOf] - repName <- newSysLocalDs tyRepType - let proxyT = mkProxyPrimTy (typeKind ty) ty - method = bindNonRec repName rep - $ mkLams [mkWildValBinder proxyT] (Var repName) - - -- package up the method as `Typeable` dictionary - return $ mkCastDs method $ mkSymCo $ getTypeableCo tyCl ty - +{-********************************************************************** +* * + Desugaring Typeable dictionaries +* * +**********************************************************************-} + +dsEvTypeable :: Type -> EvTypeable -> DsM CoreExpr +-- Return a CoreExpr :: Typeable ty +-- This code is tightly coupled to the representation +-- of TypeRep, in base library Data.Typeable.Internals +dsEvTypeable ty ev + = do { tyCl <- dsLookupTyCon typeableClassName -- Typeable + ; let kind = typeKind ty + Just typeable_data_con + = tyConSingleDataCon_maybe tyCl -- "Data constructor" + -- for Typeable + + ; rep_expr <- ds_ev_typeable ty ev + + -- Build Core for (let r::TypeRep = rep in \proxy. rep) + -- See Note [Memoising typeOf] + ; repName <- newSysLocalDs (exprType rep_expr) + ; let proxyT = mkProxyPrimTy kind ty + method = bindNonRec repName rep_expr + $ mkLams [mkWildValBinder proxyT] (Var repName) + + -- Package up the method as `Typeable` dictionary + ; return $ mkConApp typeable_data_con [Type kind, Type ty, method] } + + +ds_ev_typeable :: Type -> EvTypeable -> DsM CoreExpr +-- Returns a CoreExpr :: TypeRep ty +ds_ev_typeable ty EvTypeableTyCon + | Just (tc, ks) <- splitTyConApp_maybe ty + = ASSERT( all isKind ks ) + do { ctr <- dsLookupGlobalId mkPolyTyConAppName + -- mkPolyTyConApp :: TyCon -> [KindRep] -> [TypeRep] -> TypeRep + ; tyRepTc <- dsLookupTyCon typeRepTyConName -- TypeRep (the TyCon) + ; let tyRepType = mkTyConApp tyRepTc [] -- TypeRep (the Type) + mkRep cRep kReps tReps + = mkApps (Var ctr) [ cRep + , mkListExpr tyRepType kReps + , mkListExpr tyRepType tReps ] + + kindRep k -- Returns CoreExpr :: TypeRep for that kind k + = case splitTyConApp_maybe k of + Nothing -> panic "dsEvTypeable: not a kind constructor" + Just (kc,ks) -> do { kcRep <- tyConRep kc + ; reps <- mapM kindRep ks + ; return (mkRep kcRep [] reps) } + + ; tcRep <- tyConRep tc + ; kReps <- mapM kindRep ks + ; return (mkRep tcRep kReps []) } + +ds_ev_typeable ty (EvTypeableTyApp ev1 ev2) + | Just (t1,t2) <- splitAppTy_maybe ty + = do { e1 <- getRep ev1 t1 + ; e2 <- getRep ev2 t2 + ; ctr <- dsLookupGlobalId mkAppTyName + ; return ( mkApps (Var ctr) [ e1, e2 ] ) } + +ds_ev_typeable ty (EvTypeableTyLit ev) + = do { fun <- dsLookupGlobalId tr_fun + ; dict <- dsEvTerm ev -- Of type KnownNat/KnownSym + ; let proxy = mkTyApps (Var proxyHashId) [ty_kind, ty] + ; return (mkApps (mkTyApps (Var fun) [ty]) [ dict, proxy ]) } where - -- co: method -> Typeable k t - getTypeableCo tc t = - case instNewTyCon_maybe tc [typeKind t, t] of - Just (_,co) -> co - _ -> panic "Class `Typeable` is not a `newtype`." - - -- Typeable t -> TyRep - getRep tc (ev,t) = - do typeableExpr <- dsEvTerm ev - let co = getTypeableCo tc t - method = mkCastDs typeableExpr co - proxy = mkTyApps (Var proxyHashId) [typeKind t, t] - return (mkApps method [proxy]) - - -- KnownNat t -> TyRep (also used for KnownSymbol) - tyLitRep (ev,t) = - do dict <- dsEvTerm ev - fun <- dsLookupGlobalId $ - case typeKind t of - k | eqType k typeNatKind -> typeNatTypeRepName - | eqType k typeSymbolKind -> typeSymbolTypeRepName - | otherwise -> panic "dsEvTypeable: unknown type lit kind" - let finst = mkTyApps (Var fun) [t] - proxy = mkTyApps (Var proxyHashId) [typeKind t, t] - return (mkApps finst [ dict, proxy ]) - - -- This part could be cached - tyConRep dflags mkTyCon tc = - do pkgStr <- mkStringExprFS pkg_fs - modStr <- mkStringExprFS modl_fs - nameStr <- mkStringExprFS name_fs - return (mkApps (Var mkTyCon) [ int64 high, int64 low - , pkgStr, modStr, nameStr - ]) - where - tycon_name = tyConName tc - modl = nameModule tycon_name - pkg = moduleUnitId modl - - modl_fs = moduleNameFS (moduleName modl) - pkg_fs = unitIdFS pkg - name_fs = occNameFS (nameOccName tycon_name) - hash_name_fs - | isPromotedTyCon tc = appendFS (mkFastString "$k") name_fs - | isPromotedDataCon tc = appendFS (mkFastString "$c") name_fs - | isTupleTyCon tc && - returnsConstraintKind (tyConKind tc) - = appendFS (mkFastString "$p") name_fs - | otherwise = name_fs - - hashThis = unwords $ map unpackFS [pkg_fs, modl_fs, hash_name_fs] - Fingerprint high low = fingerprintString hashThis - - int64 - | wORD_SIZE dflags == 4 = mkWord64LitWord64 - | otherwise = mkWordLit dflags . fromIntegral - - + ty_kind = typeKind ty + + -- tr_fun is the Name of + -- typeNatTypeRep :: KnownNat a => Proxy# a -> TypeRep + -- of typeSymbolTypeRep :: KnownSymbol a => Proxy# a -> TypeRep + tr_fun | ty_kind `eqType` typeNatKind = typeNatTypeRepName + | ty_kind `eqType` typeSymbolKind = typeSymbolTypeRepName + | otherwise = panic "dsEvTypeable: unknown type lit kind" + + +ds_ev_typeable ty ev + = pprPanic "dsEvTypeable" (ppr ty $$ ppr ev) + +getRep :: EvTerm -> Type -- EvTerm for Typeable ty, and ty + -> DsM CoreExpr -- Return CoreExpr :: TypeRep (of ty) + -- namely (typeRep# dict proxy) +-- Remember that +-- typeRep# :: forall k (a::k). Typeable k a -> Proxy k a -> TypeRep +getRep ev ty + = do { typeable_expr <- dsEvTerm ev + ; typeRepId <- dsLookupGlobalId typeRepIdName + ; let ty_args = [typeKind ty, ty] + ; return (mkApps (mkTyApps (Var typeRepId) ty_args) + [ typeable_expr + , mkTyApps (Var proxyHashId) ty_args ]) } + +tyConRep :: TyCon -> DsM CoreExpr +-- Returns CoreExpr :: TyCon +tyConRep tc + | Just tc_rep_nm <- tyConRepName_maybe tc + = do { tc_rep_id <- dsLookupGlobalId tc_rep_nm + ; return (Var tc_rep_id) } + | otherwise + = pprPanic "tyConRep" (ppr tc) {- Note [Memoising typeOf] ~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1012,8 +1001,11 @@ help GHC by manually keeping the 'rep' *outside* the lambda. -} - - +{-********************************************************************** +* * + Desugaring EvCallStack evidence +* * +**********************************************************************-} dsEvCallStack :: EvCallStack -> DsM CoreExpr -- See Note [Overview of implicit CallStacks] in TcEvidence.hs @@ -1025,7 +1017,7 @@ dsEvCallStack cs = do let srcLocTy = mkTyConTy srcLocTyCon let mkSrcLoc l = liftM (mkCoreConApps srcLocDataCon) - (sequence [ mkStringExpr (showPpr df $ moduleUnitId m) + (sequence [ mkStringExprFS (unitIdFS $ moduleUnitId m) , mkStringExprFS (moduleNameFS $ moduleName m) , mkStringExprFS (srcSpanFile l) , return $ mkIntExprInt df (srcSpanStartLine l) @@ -1071,7 +1063,12 @@ dsEvCallStack cs = do EvCsPushCall name loc tm -> mkPush (occNameFS $ getOccName name) loc tm EvCsEmpty -> panic "Cannot have an empty CallStack" ---------------------------------------- +{-********************************************************************** +* * + Desugaring Coercions +* * +**********************************************************************-} + dsTcCoercion :: TcCoercion -> (Coercion -> CoreExpr) -> DsM CoreExpr -- This is the crucial function that moves -- from TcCoercions to Coercions; see Note [TcCoercions] in Coercion diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs index f47843aa06..6e415d7b4c 100644 --- a/compiler/deSugar/DsExpr.hs +++ b/compiler/deSugar/DsExpr.hs @@ -217,8 +217,8 @@ dsExpr (HsLamCase arg matches) ; ([discrim_var], matching_code) <- matchWrapper CaseAlt matches ; return $ Lam arg_var $ bindNonRec discrim_var (Var arg_var) matching_code } -dsExpr (HsApp fun arg) - = mkCoreAppDs <$> dsLExpr fun <*> dsLExpr arg +dsExpr e@(HsApp fun arg) + = mkCoreAppDs (text "HsApp" <+> ppr e) <$> dsLExpr fun <*> dsLExpr arg {- @@ -260,15 +260,15 @@ If \tr{expr} is actually just a variable, say, then the simplifier will sort it out. -} -dsExpr (OpApp e1 op _ e2) +dsExpr e@(OpApp e1 op _ e2) = -- for the type of y, we need the type of op's 2nd argument - mkCoreAppsDs <$> dsLExpr op <*> mapM dsLExpr [e1, e2] + mkCoreAppsDs (text "opapp" <+> ppr e) <$> dsLExpr op <*> mapM dsLExpr [e1, e2] dsExpr (SectionL expr op) -- Desugar (e !) to ((!) e) - = mkCoreAppDs <$> dsLExpr op <*> dsLExpr expr + = mkCoreAppDs (text "sectionl" <+> ppr expr) <$> dsLExpr op <*> dsLExpr expr -- dsLExpr (SectionR op expr) -- \ x -> op x expr -dsExpr (SectionR op expr) = do +dsExpr e@(SectionR op expr) = do core_op <- dsLExpr op -- for the type of x, we need the type of op's 2nd argument let (x_ty:y_ty:_, _) = splitFunTys (exprType core_op) @@ -277,7 +277,7 @@ dsExpr (SectionR op expr) = do x_id <- newSysLocalDs x_ty y_id <- newSysLocalDs y_ty return (bindNonRec y_id y_core $ - Lam x_id (mkCoreAppsDs core_op [Var x_id, Var y_id])) + Lam x_id (mkCoreAppsDs (text "sectionr" <+> ppr e) core_op [Var x_id, Var y_id])) dsExpr (ExplicitTuple tup_args boxity) = do { let go (lam_vars, args) (L _ (Missing ty)) diff --git a/compiler/deSugar/DsUtils.hs b/compiler/deSugar/DsUtils.hs index bce5186f08..503e29de46 100644 --- a/compiler/deSugar/DsUtils.hs +++ b/compiler/deSugar/DsUtils.hs @@ -241,7 +241,7 @@ mkCoLetMatchResult bind = adjustMatchResult (mkCoreLet bind) -- let var' = viewExpr var in mr mkViewMatchResult :: Id -> CoreExpr -> Id -> MatchResult -> MatchResult mkViewMatchResult var' viewExpr var = - adjustMatchResult (mkCoreLet (NonRec var' (mkCoreAppDs viewExpr (Var var)))) + adjustMatchResult (mkCoreLet (NonRec var' (mkCoreAppDs (text "mkView" <+> ppr var') viewExpr (Var var)))) mkEvalMatchResult :: Id -> Type -> MatchResult -> MatchResult mkEvalMatchResult var ty @@ -343,7 +343,7 @@ mkPatSynCase var ty alt fail = do matcher <- dsLExpr $ mkLHsWrap wrapper $ nlHsTyApp matcher [ty] let MatchResult _ mkCont = match_result cont <- mkCoreLams bndrs <$> mkCont fail - return $ mkCoreAppsDs matcher [Var var, ensure_unstrict cont, Lam voidArgId fail] + return $ mkCoreAppsDs (text "patsyn" <+> ppr var) matcher [Var var, ensure_unstrict cont, Lam voidArgId fail] where MkCaseAlt{ alt_pat = psyn, alt_bndrs = bndrs, @@ -536,8 +536,8 @@ into which stupidly tries to bind the datacon 'True'. -} -mkCoreAppDs :: CoreExpr -> CoreExpr -> CoreExpr -mkCoreAppDs (Var f `App` Type ty1 `App` Type ty2 `App` arg1) arg2 +mkCoreAppDs :: SDoc -> CoreExpr -> CoreExpr -> CoreExpr +mkCoreAppDs _ (Var f `App` Type ty1 `App` Type ty2 `App` arg1) arg2 | f `hasKey` seqIdKey -- Note [Desugaring seq (1), (2)] = Case arg1 case_bndr ty2 [(DEFAULT,[],arg2)] where @@ -545,10 +545,10 @@ mkCoreAppDs (Var f `App` Type ty1 `App` Type ty2 `App` arg1) arg2 Var v1 | isLocalId v1 -> v1 -- Note [Desugaring seq (2) and (3)] _ -> mkWildValBinder ty1 -mkCoreAppDs fun arg = mkCoreApp fun arg -- The rest is done in MkCore +mkCoreAppDs s fun arg = mkCoreApp s fun arg -- The rest is done in MkCore -mkCoreAppsDs :: CoreExpr -> [CoreExpr] -> CoreExpr -mkCoreAppsDs fun args = foldl mkCoreAppDs fun args +mkCoreAppsDs :: SDoc -> CoreExpr -> [CoreExpr] -> CoreExpr +mkCoreAppsDs s fun args = foldl (mkCoreAppDs s) fun args mkCastDs :: CoreExpr -> Coercion -> CoreExpr -- We define a desugarer-specific verison of CoreUtils.mkCast, diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index e31d848a08..5506078004 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -414,6 +414,7 @@ Library TcErrors TcTyClsDecls TcTyDecls + TcTypeable TcType TcEvidence TcUnify diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs index be01baa4ea..a2ed9488b8 100644 --- a/compiler/hsSyn/HsUtils.hs +++ b/compiler/hsSyn/HsUtils.hs @@ -41,7 +41,7 @@ module HsUtils( mkPatSynBind, -- Literals - mkHsIntegral, mkHsFractional, mkHsIsString, mkHsString, + mkHsIntegral, mkHsFractional, mkHsIsString, mkHsString, mkHsStringPrimLit, -- Patterns mkNPat, mkNPlusKPat, nlVarPat, nlLitPat, nlConVarPat, nlConVarPatName, nlConPat, @@ -319,6 +319,10 @@ unqualQuasiQuote = mkRdrUnqual (mkVarOccFS (fsLit "quasiquote")) mkHsString :: String -> HsLit mkHsString s = HsString s (mkFastString s) +mkHsStringPrimLit :: FastString -> HsLit +mkHsStringPrimLit fs + = HsStringPrim (unpackFS fs) (fastStringToByteString fs) + ------------- userHsTyVarBndrs :: SrcSpan -> [name] -> [Located (HsTyVarBndr name)] -- Caller sets location diff --git a/compiler/iface/BuildTyCl.hs b/compiler/iface/BuildTyCl.hs index 11873077ce..6085b0cc3c 100644 --- a/compiler/iface/BuildTyCl.hs +++ b/compiler/iface/BuildTyCl.hs @@ -14,7 +14,7 @@ module BuildTyCl ( TcMethInfo, buildClass, distinctAbstractTyConRhs, totallyAbstractTyConRhs, mkNewTyConRhs, mkDataTyConRhs, - newImplicitBinder + newImplicitBinder, newTyConRepName ) where #include "HsVersions.h" @@ -22,6 +22,7 @@ module BuildTyCl ( import IfaceEnv import FamInstEnv( FamInstEnvs ) import TysWiredIn( isCTupleTyConName ) +import PrelNames( tyConRepModOcc ) import DataCon import PatSyn import Var @@ -36,6 +37,7 @@ import Id import Coercion import TcType +import SrcLoc( noSrcSpan ) import DynFlags import TcRnMonad import UniqSupply @@ -49,7 +51,8 @@ buildSynonymTyCon :: Name -> [TyVar] -> [Role] -> TyCon buildSynonymTyCon tc_name tvs roles rhs rhs_kind = mkSynonymTyCon tc_name kind tvs roles rhs - where kind = mkPiKinds tvs rhs_kind + where + kind = mkPiKinds tvs rhs_kind buildFamilyTyCon :: Name -- ^ Type family name @@ -57,7 +60,7 @@ buildFamilyTyCon :: Name -- ^ Type family name -> Maybe Name -- ^ Result variable name -> FamTyConFlav -- ^ Open, closed or in a boot file? -> Kind -- ^ Kind of the RHS - -> TyConParent -- ^ Parent, if exists + -> Maybe Class -- ^ Parent, if exists -> Injectivity -- ^ Injectivity annotation -- See [Injectivity annotation] in HsDecls -> TyCon @@ -132,7 +135,9 @@ mkNewTyConRhs tycon_name tycon con ------------------------------------------------------ buildDataCon :: FamInstEnvs - -> Name -> Bool + -> Name + -> Bool -- Declared infix + -> Promoted TyConRepName -- Promotable -> [HsSrcBang] -> Maybe [HsImplBang] -- See Note [Bangs on imported data constructors] in MkId @@ -148,7 +153,7 @@ buildDataCon :: FamInstEnvs -- a) makes the worker Id -- b) makes the wrapper Id if necessary, including -- allocating its unique (hence monadic) -buildDataCon fam_envs src_name declared_infix src_bangs impl_bangs field_lbls +buildDataCon fam_envs src_name declared_infix prom_info src_bangs impl_bangs field_lbls univ_tvs ex_tvs eq_spec ctxt arg_tys res_ty rep_tycon = do { wrap_name <- newImplicitBinder src_name mkDataConWrapperOcc ; work_name <- newImplicitBinder src_name mkDataConWorkerOcc @@ -156,11 +161,12 @@ buildDataCon fam_envs src_name declared_infix src_bangs impl_bangs field_lbls -- code, which (for Haskell source anyway) will be in the DataName name -- space, and puts it into the VarName name space + ; traceIf (text "buildDataCon 1" <+> ppr src_name) ; us <- newUniqueSupply ; dflags <- getDynFlags ; let stupid_ctxt = mkDataConStupidTheta rep_tycon arg_tys univ_tvs - data_con = mkDataCon src_name declared_infix + data_con = mkDataCon src_name declared_infix prom_info src_bangs field_lbls univ_tvs ex_tvs eq_spec ctxt arg_tys res_ty rep_tycon @@ -169,6 +175,7 @@ buildDataCon fam_envs src_name declared_infix src_bangs impl_bangs field_lbls dc_rep = initUs_ us (mkDataConRep dflags fam_envs wrap_name impl_bangs data_con) + ; traceIf (text "buildDataCon 2" <+> ppr src_name) ; return data_con } @@ -227,7 +234,8 @@ type TcMethInfo = (Name, DefMethSpec, Type) -- A temporary intermediate, to communicate between -- tcClassSigs and buildClass. -buildClass :: Name -> [TyVar] -> [Role] -> ThetaType +buildClass :: Name -- Name of the class/tycon (they have the same Name) + -> [TyVar] -> [Role] -> ThetaType -> [FunDep TyVar] -- Functional dependencies -> [ClassATItem] -- Associated types -> [TcMethInfo] -- Method info @@ -240,10 +248,7 @@ buildClass tycon_name tvs roles sc_theta fds at_items sig_stuff mindef tc_isrec do { traceIf (text "buildClass") ; datacon_name <- newImplicitBinder tycon_name mkClassDataConOcc - -- The class name is the 'parent' for this datacon, not its tycon, - -- because one should import the class to get the binding for - -- the datacon - + ; tc_rep_name <- newTyConRepName tycon_name ; op_items <- mapM (mk_op_item rec_clas) sig_stuff -- Build the selector id and default method id @@ -282,6 +287,7 @@ buildClass tycon_name tvs roles sc_theta fds at_items sig_stuff mindef tc_isrec ; dict_con <- buildDataCon (panic "buildClass: FamInstEnvs") datacon_name False -- Not declared infix + NotPromoted -- Class tycons are not promoted (map (const no_bang) args) (Just (map (const HsLazy) args)) [{- No fields -}] @@ -300,9 +306,8 @@ buildClass tycon_name tvs roles sc_theta fds at_items sig_stuff mindef tc_isrec else return (mkDataTyConRhs [dict_con]) ; let { clas_kind = mkPiKinds tvs constraintKind - - ; tycon = mkClassTyCon tycon_name clas_kind tvs roles - rhs rec_clas tc_isrec + ; tycon = mkClassTyCon tycon_name clas_kind tvs roles + rhs rec_clas tc_isrec tc_rep_name -- 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 } @@ -366,3 +371,12 @@ newImplicitBinder base_name mk_sys_occ where occ = mk_sys_occ (nameOccName base_name) loc = nameSrcSpan base_name + +-- | Make the 'TyConRepName' for this 'TyCon' +newTyConRepName :: Name -> TcRnIf gbl lcl TyConRepName +newTyConRepName tc_name + | Just mod <- nameModule_maybe tc_name + , (mod, occ) <- tyConRepModOcc mod (nameOccName tc_name) + = newGlobalBinder mod occ noSrcSpan + | otherwise + = newImplicitBinder tc_name mkTyConRepUserOcc diff --git a/compiler/iface/IfaceSyn.hs b/compiler/iface/IfaceSyn.hs index 8bf744f0c7..3911786594 100644 --- a/compiler/iface/IfaceSyn.hs +++ b/compiler/iface/IfaceSyn.hs @@ -165,7 +165,8 @@ data IfaceTyConParent IfaceTcArgs data IfaceFamTyConFlav - = IfaceOpenSynFamilyTyCon + = IfaceDataFamilyTyCon -- Data family + | IfaceOpenSynFamilyTyCon | IfaceClosedSynFamilyTyCon (Maybe (IfExtName, [IfaceAxBranch])) -- ^ Name of associated axiom and branches for pretty printing purposes, -- or 'Nothing' for an empty closed family without an axiom @@ -192,7 +193,6 @@ data IfaceAxBranch = IfaceAxBranch { ifaxbTyVars :: [IfaceTvBndr] data IfaceConDecls = IfAbstractTyCon Bool -- c.f TyCon.AbstractTyCon - | IfDataFamTyCon -- Data family | IfDataTyCon [IfaceConDecl] Bool [FieldLabelString] -- Data type decls | IfNewTyCon IfaceConDecl Bool [FieldLabelString] -- Newtype decls @@ -343,14 +343,12 @@ See [http://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/RecompilationAvoid visibleIfConDecls :: IfaceConDecls -> [IfaceConDecl] visibleIfConDecls (IfAbstractTyCon {}) = [] -visibleIfConDecls IfDataFamTyCon = [] visibleIfConDecls (IfDataTyCon cs _ _) = cs visibleIfConDecls (IfNewTyCon c _ _) = [c] ifaceConDeclFields :: IfaceConDecls -> [FieldLbl OccName] ifaceConDeclFields x = case x of IfAbstractTyCon {} -> [] - IfDataFamTyCon {} -> [] IfDataTyCon cons is_over labels -> map (help cons is_over) labels IfNewTyCon con is_over labels -> map (help [con] is_over) labels where @@ -368,35 +366,15 @@ ifaceDeclImplicitBndrs :: IfaceDecl -> [OccName] -- TyThing.getOccName should define a bijection between the two lists. -- This invariant is used in LoadIface.loadDecl (see note [Tricky iface loop]) -- The order of the list does not matter. -ifaceDeclImplicitBndrs IfaceData {ifCons = IfAbstractTyCon {}} = [] - --- Newtype -ifaceDeclImplicitBndrs (IfaceData {ifName = tc_occ, - ifCons = IfNewTyCon (IfCon { ifConOcc = con_occ }) _ _}) - = -- implicit newtype coercion - (mkNewTyCoOcc tc_occ) : -- JPM: newtype coercions shouldn't be implicit - -- data constructor and worker (newtypes don't have a wrapper) - [con_occ, mkDataConWorkerOcc con_occ] - - -ifaceDeclImplicitBndrs (IfaceData {ifName = _tc_occ, - ifCons = IfDataTyCon cons _ _ }) - = -- for each data constructor in order, - -- data constructor, worker, and (possibly) wrapper - concatMap dc_occs cons - where - dc_occs con_decl - | has_wrapper = [con_occ, work_occ, wrap_occ] - | otherwise = [con_occ, work_occ] - where - con_occ = ifConOcc con_decl -- DataCon namespace - wrap_occ = mkDataConWrapperOcc con_occ -- Id namespace - work_occ = mkDataConWorkerOcc con_occ -- Id namespace - has_wrapper = ifConWrapper con_decl -- This is the reason for - -- having the ifConWrapper field! - -ifaceDeclImplicitBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_tc_occ, - ifSigs = sigs, ifATs = ats }) + +ifaceDeclImplicitBndrs (IfaceData {ifName = tc_occ, ifCons = cons }) + = case cons of + IfAbstractTyCon {} -> [] + IfNewTyCon cd _ _ -> mkNewTyCoOcc tc_occ : ifaceConDeclImplicitBndrs cd + IfDataTyCon cds _ _ -> concatMap ifaceConDeclImplicitBndrs cds + +ifaceDeclImplicitBndrs (IfaceClass { ifCtxt = sc_ctxt, ifName = cls_tc_occ + , ifSigs = sigs, ifATs = ats }) = -- (possibly) newtype coercion co_occs ++ -- data constructor (DataCon namespace) @@ -420,6 +398,14 @@ ifaceDeclImplicitBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_tc_occ, ifaceDeclImplicitBndrs _ = [] +ifaceConDeclImplicitBndrs :: IfaceConDecl -> [OccName] +ifaceConDeclImplicitBndrs (IfCon { ifConWrapper = has_wrapper, ifConOcc = con_occ }) + = [con_occ, work_occ] ++ wrap_occs + where + work_occ = mkDataConWorkerOcc con_occ -- Id namespace + wrap_occs | has_wrapper = [mkDataConWrapperOcc con_occ] -- Id namespace + | otherwise = [] + -- ----------------------------------------------------------------------------- -- The fingerprints of an IfaceDecl @@ -685,7 +671,6 @@ pprIfaceDecl ss (IfaceData { ifName = tycon, ifCType = ctype, pp_nd = case condecls of IfAbstractTyCon d -> ptext (sLit "abstract") <> ppShowIface ss (parens (ppr d)) - IfDataFamTyCon -> ptext (sLit "data family") IfDataTyCon{} -> ptext (sLit "data") IfNewTyCon{} -> ptext (sLit "newtype") @@ -694,6 +679,7 @@ pprIfaceDecl ss (IfaceData { ifName = tycon, ifCType = ctype, pp_prom | is_prom = ptext (sLit "Promotable") | otherwise = Outputable.empty + pprIfaceDecl ss (IfaceClass { ifATs = ats, ifSigs = sigs, ifRec = isrec , ifCtxt = context, ifName = clas , ifTyVars = tyvars, ifRoles = roles @@ -738,7 +724,12 @@ pprIfaceDecl ss (IfaceSynonym { ifName = tc pprIfaceDecl ss (IfaceFamily { ifName = tycon, ifTyVars = tyvars , ifFamFlav = rhs, ifFamKind = kind , ifResVar = res_var, ifFamInj = inj }) - = vcat [ hang (text "type family" <+> pprIfaceDeclHead [] ss tycon tyvars) + | IfaceDataFamilyTyCon <- rhs + = ptext (sLit "data family") <+> pprIfaceDeclHead [] ss tycon tyvars + + | otherwise + = vcat [ hang (ptext (sLit "type family") + <+> pprIfaceDeclHead [] ss tycon tyvars) 2 (pp_inj res_var inj <+> ppShowRhs ss (pp_rhs rhs)) , ppShowRhs ss (nest 2 (pp_branches rhs)) ] where @@ -752,11 +743,13 @@ pprIfaceDecl ss (IfaceFamily { ifName = tycon, ifTyVars = tyvars [] -> empty tvs -> hsep [text "|", ppr res, text "->", interppSP (map fst tvs)] + pp_rhs IfaceDataFamilyTyCon + = ppShowIface ss (ptext (sLit "data")) pp_rhs IfaceOpenSynFamilyTyCon = ppShowIface ss (ptext (sLit "open")) pp_rhs IfaceAbstractClosedSynFamilyTyCon = ppShowIface ss (ptext (sLit "closed, abstract")) - pp_rhs (IfaceClosedSynFamilyTyCon _) + pp_rhs (IfaceClosedSynFamilyTyCon {}) = ptext (sLit "where") pp_rhs IfaceBuiltInSynFamTyCon = ppShowIface ss (ptext (sLit "built-in")) @@ -1170,12 +1163,13 @@ freeNamesIfIdDetails _ = emptyNameSet -- All other changes are handled via the version info on the tycon freeNamesIfFamFlav :: IfaceFamTyConFlav -> NameSet -freeNamesIfFamFlav IfaceOpenSynFamilyTyCon = emptyNameSet +freeNamesIfFamFlav IfaceOpenSynFamilyTyCon = emptyNameSet +freeNamesIfFamFlav IfaceDataFamilyTyCon = emptyNameSet freeNamesIfFamFlav (IfaceClosedSynFamilyTyCon (Just (ax, br))) = unitNameSet ax &&& fnList freeNamesIfAxBranch br freeNamesIfFamFlav (IfaceClosedSynFamilyTyCon Nothing) = emptyNameSet -freeNamesIfFamFlav IfaceAbstractClosedSynFamilyTyCon = emptyNameSet -freeNamesIfFamFlav IfaceBuiltInSynFamTyCon = emptyNameSet +freeNamesIfFamFlav IfaceAbstractClosedSynFamilyTyCon = emptyNameSet +freeNamesIfFamFlav IfaceBuiltInSynFamTyCon = emptyNameSet freeNamesIfContext :: IfaceContext -> NameSet freeNamesIfContext = fnList freeNamesIfType @@ -1526,18 +1520,22 @@ instance Binary IfaceDecl where _ -> panic (unwords ["Unknown IfaceDecl tag:", show h]) instance Binary IfaceFamTyConFlav where - put_ bh IfaceOpenSynFamilyTyCon = putByte bh 0 - put_ bh (IfaceClosedSynFamilyTyCon mb) = putByte bh 1 >> put_ bh mb - put_ bh IfaceAbstractClosedSynFamilyTyCon = putByte bh 2 + put_ bh IfaceDataFamilyTyCon = putByte bh 0 + put_ bh IfaceOpenSynFamilyTyCon = putByte bh 1 + put_ bh (IfaceClosedSynFamilyTyCon mb) = putByte bh 2 >> put_ bh mb + put_ bh IfaceAbstractClosedSynFamilyTyCon = putByte bh 3 put_ _ IfaceBuiltInSynFamTyCon = pprPanic "Cannot serialize IfaceBuiltInSynFamTyCon, used for pretty-printing only" Outputable.empty get bh = do { h <- getByte bh ; case h of - 0 -> return IfaceOpenSynFamilyTyCon - 1 -> do { mb <- get bh + 0 -> return IfaceDataFamilyTyCon + 1 -> return IfaceOpenSynFamilyTyCon + 2 -> do { mb <- get bh ; return (IfaceClosedSynFamilyTyCon mb) } - _ -> return IfaceAbstractClosedSynFamilyTyCon } + 3 -> return IfaceAbstractClosedSynFamilyTyCon + _ -> pprPanic "Binary.get(IfaceFamTyConFlav): Invalid tag" + (ppr (fromIntegral h :: Int)) } instance Binary IfaceClassOp where put_ bh (IfaceClassOp n def ty) = do @@ -1576,17 +1574,16 @@ instance Binary IfaceAxBranch where return (IfaceAxBranch a1 a2 a3 a4 a5) instance Binary IfaceConDecls where - put_ bh (IfAbstractTyCon d) = putByte bh 0 >> put_ bh d - put_ bh IfDataFamTyCon = putByte bh 1 - put_ bh (IfDataTyCon cs b fs) = putByte bh 2 >> put_ bh cs >> put_ bh b >> put_ bh fs - put_ bh (IfNewTyCon c b fs) = putByte bh 3 >> put_ bh c >> put_ bh b >> put_ bh fs + put_ bh (IfAbstractTyCon d) = putByte bh 0 >> put_ bh d + put_ bh (IfDataTyCon cs b fs) = putByte bh 1 >> put_ bh cs >> put_ bh b >> put_ bh fs + put_ bh (IfNewTyCon c b fs) = putByte bh 2 >> put_ bh c >> put_ bh b >> put_ bh fs get bh = do h <- getByte bh case h of 0 -> liftM IfAbstractTyCon $ get bh - 1 -> return IfDataFamTyCon - 2 -> liftM3 IfDataTyCon (get bh) (get bh) (get bh) - _ -> liftM3 IfNewTyCon (get bh) (get bh) (get bh) + 1 -> liftM3 IfDataTyCon (get bh) (get bh) (get bh) + 2 -> liftM3 IfNewTyCon (get bh) (get bh) (get bh) + _ -> error "Binary(IfaceConDecls).get: Invalid IfaceConDecls" instance Binary IfaceConDecl where put_ bh (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) = do diff --git a/compiler/iface/MkIface.hs b/compiler/iface/MkIface.hs index df96f6a4af..b7bdc38ae5 100644 --- a/compiler/iface/MkIface.hs +++ b/compiler/iface/MkIface.hs @@ -1611,7 +1611,7 @@ tyConToIfaceDecl env tycon ifCons = ifaceConDecls (algTyConRhs tycon) (algTcFields tycon), ifRec = boolToRecFlag (isRecursiveTyCon tycon), ifGadtSyntax = isGadtSyntaxTyCon tycon, - ifPromotable = isJust (promotableTyCon_maybe tycon), + ifPromotable = isPromotableTyCon tycon, ifParent = parent }) | otherwise -- FunTyCon, PrimTyCon, promoted TyCon/DataCon @@ -1649,16 +1649,14 @@ tyConToIfaceDecl env tycon axn = coAxiomName ax to_if_fam_flav (ClosedSynFamilyTyCon Nothing) = IfaceClosedSynFamilyTyCon Nothing - to_if_fam_flav AbstractClosedSynFamilyTyCon - = IfaceAbstractClosedSynFamilyTyCon + to_if_fam_flav AbstractClosedSynFamilyTyCon = IfaceAbstractClosedSynFamilyTyCon + to_if_fam_flav (DataFamilyTyCon {}) = IfaceDataFamilyTyCon + to_if_fam_flav (BuiltInSynFamTyCon {}) = IfaceBuiltInSynFamTyCon - to_if_fam_flav (BuiltInSynFamTyCon {}) - = IfaceBuiltInSynFamTyCon ifaceConDecls (NewTyCon { data_con = con }) flds = IfNewTyCon (ifaceConDecl con) (ifaceOverloaded flds) (ifaceFields flds) ifaceConDecls (DataTyCon { data_cons = cons }) flds = IfDataTyCon (map ifaceConDecl cons) (ifaceOverloaded flds) (ifaceFields flds) - ifaceConDecls (DataFamilyTyCon {}) _ = IfDataFamTyCon ifaceConDecls (TupleTyCon { data_con = con }) _ = IfDataTyCon [ifaceConDecl con] False [] ifaceConDecls (AbstractTyCon distinct) _ = IfAbstractTyCon distinct -- The AbstractTyCon case happens when a TyCon has been trimmed diff --git a/compiler/iface/TcIface.hs b/compiler/iface/TcIface.hs index 1328b3c002..80de36e82d 100644 --- a/compiler/iface/TcIface.hs +++ b/compiler/iface/TcIface.hs @@ -297,13 +297,13 @@ What this means is that the implicitTyThings MUST NOT DEPEND on any of the forkM stuff. -} -tcIfaceDecl :: Bool -- True <=> discard IdInfo on IfaceId bindings +tcIfaceDecl :: Bool -- ^ True <=> discard IdInfo on IfaceId bindings -> IfaceDecl -> IfL TyThing -tcIfaceDecl = tc_iface_decl NoParentTyCon +tcIfaceDecl = tc_iface_decl Nothing -tc_iface_decl :: TyConParent -- For nested declarations - -> Bool -- True <=> discard IdInfo on IfaceId bindings +tc_iface_decl :: Maybe Class -- ^ For associated type/data family declarations + -> Bool -- ^ True <=> discard IdInfo on IfaceId bindings -> IfaceDecl -> IfL TyThing tc_iface_decl _ ignore_prags (IfaceId {ifName = occ_name, ifType = iface_type, @@ -314,7 +314,7 @@ tc_iface_decl _ ignore_prags (IfaceId {ifName = occ_name, ifType = iface_type, ; info <- tcIdInfo ignore_prags name ty info ; return (AnId (mkGlobalId details name ty info)) } -tc_iface_decl parent _ (IfaceData {ifName = occ_name, +tc_iface_decl _ _ (IfaceData {ifName = occ_name, ifCType = cType, ifTyVars = tv_bndrs, ifRoles = roles, @@ -326,22 +326,23 @@ tc_iface_decl parent _ (IfaceData {ifName = occ_name, { tc_name <- lookupIfaceTop occ_name ; tycon <- fixM $ \ tycon -> do { stupid_theta <- tcIfaceCtxt ctxt - ; parent' <- tc_parent mb_parent - ; cons <- tcIfaceDataCons tc_name tycon tyvars rdr_cons + ; parent' <- tc_parent tc_name mb_parent + ; cons <- tcIfaceDataCons tc_name tycon tyvars rdr_cons is_prom ; return (buildAlgTyCon tc_name tyvars roles cType stupid_theta cons is_rec is_prom gadt_syn parent') } ; traceIf (text "tcIfaceDecl4" <+> ppr tycon) ; return (ATyCon tycon) } where - tc_parent :: IfaceTyConParent -> IfL TyConParent - tc_parent IfNoParent = return parent - tc_parent (IfDataInstance ax_name _ arg_tys) - = ASSERT( isNoParent parent ) - do { ax <- tcIfaceCoAxiom ax_name + tc_parent :: Name -> IfaceTyConParent -> IfL AlgTyConFlav + tc_parent tc_name IfNoParent + = do { tc_rep_name <- newTyConRepName tc_name + ; return (VanillaAlgTyCon tc_rep_name) } + tc_parent _ (IfDataInstance ax_name _ arg_tys) + = do { ax <- tcIfaceCoAxiom ax_name ; let fam_tc = coAxiomTyCon ax ax_unbr = toUnbranchedAxiom ax ; lhs_tys <- tcIfaceTcArgs arg_tys - ; return (FamInstTyCon ax_unbr fam_tc lhs_tys) } + ; return (DataFamInstTyCon ax_unbr fam_tc lhs_tys) } tc_iface_decl _ _ (IfaceSynonym {ifName = occ_name, ifTyVars = tv_bndrs, ifRoles = roles, @@ -365,20 +366,25 @@ tc_iface_decl parent _ (IfaceFamily {ifName = occ_name, ifTyVars = tv_bndrs, { tc_name <- lookupIfaceTop occ_name ; rhs_kind <- tcIfaceKind kind -- Note [Synonym kind loop] ; rhs <- forkM (mk_doc tc_name) $ - tc_fam_flav fam_flav + tc_fam_flav tc_name fam_flav ; res_name <- traverse (newIfaceName . mkTyVarOccFS) res ; let tycon = buildFamilyTyCon tc_name tyvars res_name rhs rhs_kind parent inj ; return (ATyCon tycon) } where mk_doc n = ptext (sLit "Type synonym") <+> ppr n - tc_fam_flav IfaceOpenSynFamilyTyCon = return OpenSynFamilyTyCon - tc_fam_flav (IfaceClosedSynFamilyTyCon mb_ax_name_branches) + + tc_fam_flav :: Name -> IfaceFamTyConFlav -> IfL FamTyConFlav + tc_fam_flav tc_name IfaceDataFamilyTyCon + = do { tc_rep_name <- newTyConRepName tc_name + ; return (DataFamilyTyCon tc_rep_name) } + tc_fam_flav _ IfaceOpenSynFamilyTyCon= return OpenSynFamilyTyCon + tc_fam_flav _ (IfaceClosedSynFamilyTyCon mb_ax_name_branches) = do { ax <- traverse (tcIfaceCoAxiom . fst) mb_ax_name_branches ; return (ClosedSynFamilyTyCon ax) } - tc_fam_flav IfaceAbstractClosedSynFamilyTyCon + tc_fam_flav _ IfaceAbstractClosedSynFamilyTyCon = return AbstractClosedSynFamilyTyCon - tc_fam_flav IfaceBuiltInSynFamTyCon + tc_fam_flav _ IfaceBuiltInSynFamTyCon = pprPanic "tc_iface_decl" (text "IfaceBuiltInSynFamTyCon in interface file") @@ -422,7 +428,7 @@ tc_iface_decl _parent ignore_prags ; return (op_name, dm, op_ty) } tc_at cls (IfaceAT tc_decl if_def) - = do ATyCon tc <- tc_iface_decl (AssocFamilyTyCon cls) ignore_prags tc_decl + = do ATyCon tc <- tc_iface_decl (Just cls) ignore_prags tc_decl mb_def <- case if_def of Nothing -> return Nothing Just def -> forkM (mk_at_doc tc) $ @@ -506,11 +512,10 @@ tc_ax_branch prev_branches , cab_incomps = map (prev_branches !!) incomps } ; return (prev_branches ++ [br]) } -tcIfaceDataCons :: Name -> TyCon -> [TyVar] -> IfaceConDecls -> IfL AlgTyConRhs -tcIfaceDataCons tycon_name tycon tc_tyvars if_cons +tcIfaceDataCons :: Name -> TyCon -> [TyVar] -> IfaceConDecls -> Bool -> IfL AlgTyConRhs +tcIfaceDataCons tycon_name tycon tc_tyvars if_cons is_prom = case if_cons of IfAbstractTyCon dis -> return (AbstractTyCon dis) - IfDataFamTyCon -> return DataFamilyTyCon IfDataTyCon cons _ _ -> do { field_lbls <- mapM (traverse lookupIfaceTop) (ifaceConDeclFields if_cons) ; data_cons <- mapM (tc_con_decl field_lbls) cons ; return (mkDataTyConRhs data_cons) } @@ -528,14 +533,14 @@ tcIfaceDataCons tycon_name tycon tc_tyvars if_cons -- parent TyCon, and are alrady in scope bindIfaceTyVars ex_tvs $ \ ex_tyvars -> do { traceIf (text "Start interface-file tc_con_decl" <+> ppr occ) - ; name <- lookupIfaceTop occ + ; dc_name <- lookupIfaceTop occ -- Read the context and argument types, but lazily for two reasons -- (a) to avoid looking tugging on a recursive use of -- the type itself, which is knot-tied -- (b) to avoid faulting in the component types unless -- they are really needed - ; ~(eq_spec, theta, arg_tys, stricts) <- forkM (mk_doc name) $ + ; ~(eq_spec, theta, arg_tys, stricts) <- forkM (mk_doc dc_name) $ do { eq_spec <- tcIfaceEqSpec spec ; theta <- tcIfaceCtxt ctxt ; arg_tys <- mapM tcIfaceType args @@ -555,20 +560,24 @@ tcIfaceDataCons tycon_name tycon tc_tyvars if_cons ; let orig_res_ty = mkFamilyTyConApp tycon (substTyVars (mkTopTvSubst eq_spec) tc_tyvars) - ; con <- buildDataCon (pprPanic "tcIfaceDataCons: FamInstEnvs" (ppr name)) - name is_infix - (map src_strict if_src_stricts) - (Just stricts) - -- Pass the HsImplBangs (i.e. final - -- decisions) to buildDataCon; it'll use - -- these to guide the construction of a - -- worker. - -- See Note [Bangs on imported data constructors] in MkId - lbl_names - tc_tyvars ex_tyvars - eq_spec theta - arg_tys orig_res_ty tycon - ; traceIf (text "Done interface-file tc_con_decl" <+> ppr name) + ; prom_info <- if is_prom then do { n <- newTyConRepName dc_name + ; return (Promoted n) } + else return NotPromoted + + ; con <- buildDataCon (pprPanic "tcIfaceDataCons: FamInstEnvs" (ppr dc_name)) + dc_name is_infix prom_info + (map src_strict if_src_stricts) + (Just stricts) + -- Pass the HsImplBangs (i.e. final + -- decisions) to buildDataCon; it'll use + -- these to guide the construction of a + -- worker. + -- See Note [Bangs on imported data constructors] in MkId + lbl_names + tc_tyvars ex_tyvars + eq_spec theta + arg_tys orig_res_ty tycon + ; traceIf (text "Done interface-file tc_con_decl" <+> ppr dc_name) ; return con } mk_doc con_name = ptext (sLit "Constructor") <+> ppr con_name @@ -889,7 +898,7 @@ tcIfaceTupleTy sort info args -> return (mkTyConApp base_tc args') IfacePromotedTyCon - | Just tc <- promotableTyCon_maybe base_tc + | Promoted tc <- promotableTyCon_maybe base_tc -> return (mkTyConApp tc args') | otherwise -> panic "tcIfaceTupleTy" (ppr base_tc) @@ -1366,7 +1375,7 @@ tcIfaceTyCon (IfaceTyCon name info) -- Same Name as its underlying TyCon where promote_tc tc - | Just prom_tc <- promotableTyCon_maybe tc = prom_tc + | Promoted prom_tc <- promotableTyCon_maybe tc = prom_tc | isSuperKind (tyConKind tc) = tc | otherwise = pprPanic "tcIfaceTyCon" (ppr name $$ ppr tc) diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index 64143e0c03..95cb5f222f 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -94,9 +94,11 @@ import BasicTypes ( HValue ) import ByteCodeGen ( byteCodeGen, coreExprToBCOs ) import Linker import CoreTidy ( tidyExpr ) -import Type ( Type, Kind ) +import Type ( Type ) +import {- Kind parts of -} Type ( Kind ) import CoreLint ( lintInteractiveExpr ) import VarEnv ( emptyTidyEnv ) +import THNames ( templateHaskellNames ) import ConLike import GHC.Exts @@ -181,7 +183,7 @@ newHscEnv :: DynFlags -> IO HscEnv newHscEnv dflags = do eps_var <- newIORef initExternalPackageState us <- mkSplitUniqSupply 'r' - nc_var <- newIORef (initNameCache us knownKeyNames) + nc_var <- newIORef (initNameCache us allKnownKeyNames) fc_var <- newIORef emptyModuleEnv return HscEnv { hsc_dflags = dflags, hsc_targets = [], @@ -194,6 +196,13 @@ newHscEnv dflags = do hsc_type_env_var = Nothing } +allKnownKeyNames :: [Name] -- Put here to avoid loops involving DsMeta, +allKnownKeyNames = -- where templateHaskellNames are defined + knownKeyNames +#ifdef GHCI + ++ templateHaskellNames +#endif + -- ----------------------------------------------------------------------------- getWarnings :: Hsc WarningMessages diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs index fb65a67e6e..b711ffea51 100644 --- a/compiler/main/HscTypes.hs +++ b/compiler/main/HscTypes.hs @@ -1689,8 +1689,8 @@ implicitTyThings (AConLike cl) = implicitConLikeThings cl implicitConLikeThings :: ConLike -> [TyThing] implicitConLikeThings (RealDataCon dc) - = map AnId (dataConImplicitIds dc) - -- For data cons add the worker and (possibly) wrapper + = dataConImplicitTyThings dc + implicitConLikeThings (PatSynCon {}) = [] -- Pattern synonyms have no implicit Ids; the wrapper and matcher -- are not "implicit"; they are simply new top-level bindings, @@ -1705,7 +1705,7 @@ implicitClassThings cl = -- Does not include default methods, because those Ids may have -- their own pragmas, unfoldings etc, not derived from the Class object -- associated types - -- No extras_plus (recursive call) for the classATs, because they + -- No recursive call for the classATs, because they -- are only the family decls; they have no implicit things map ATyCon (classATs cl) ++ -- superclass and operation selectors @@ -1721,7 +1721,8 @@ implicitTyConThings tc -- for each data constructor in order, -- the contructor, worker, and (possibly) wrapper - concatMap (extras_plus . AConLike . RealDataCon) (tyConDataCons tc) + [ thing | dc <- tyConDataCons tc + , thing <- AConLike (RealDataCon dc) : dataConImplicitTyThings dc ] -- NB. record selectors are *not* implicit, they have fully-fledged -- bindings that pass through the compilation pipeline as normal. where @@ -1729,10 +1730,6 @@ implicitTyConThings tc Nothing -> [] Just cl -> implicitClassThings cl --- add a thing and recursive call -extras_plus :: TyThing -> [TyThing] -extras_plus thing = thing : implicitTyThings thing - -- For newtypes and closed type families (only) add the implicit coercion tycon implicitCoTyCon :: TyCon -> [TyThing] implicitCoTyCon tc diff --git a/compiler/prelude/PrelInfo.hs b/compiler/prelude/PrelInfo.hs index f79b6b1e7f..f76b62ee00 100644 --- a/compiler/prelude/PrelInfo.hs +++ b/compiler/prelude/PrelInfo.hs @@ -10,7 +10,7 @@ module PrelInfo ( primOpRules, builtinRules, ghcPrimExports, - wiredInThings, knownKeyNames, + knownKeyNames, primOpId, -- Random other things @@ -23,56 +23,31 @@ module PrelInfo ( #include "HsVersions.h" +import Constants ( mAX_TUPLE_SIZE ) +import BasicTypes ( Boxity(..) ) +import ConLike ( ConLike(..) ) import PrelNames import PrelRules import Avail import PrimOp import DataCon import Id +import Name import MkId -import Name( Name, getName ) import TysPrim import TysWiredIn import HscTypes import Class import TyCon -import Outputable -import UniqFM import Util import {-# SOURCE #-} TcTypeNats ( typeNatTyCons ) -#ifdef GHCI -import THNames -#endif - import Data.Array - -{- ********************************************************************* -* * - Known key things -* * -********************************************************************* -} - -knownKeyNames :: [Name] -knownKeyNames = - ASSERT2( isNullUFM badNamesUFM, text "badknownKeyNames" <+> ppr badNamesUFM ) - names - where - badNamesUFM = filterUFM (\ns -> length ns > 1) namesUFM - namesUFM = foldl (\m n -> addToUFM_Acc (:) singleton m n n) emptyUFM names - names = concat - [ map getName wiredInThings - , cTupleTyConNames - , basicKnownKeyNames -#ifdef GHCI - , templateHaskellNames -#endif - ] - -{- ********************************************************************* +{- +************************************************************************ * * - Wired in things +\subsection[builtinNameInfo]{Lookup built-in names} * * ************************************************************************ @@ -87,33 +62,61 @@ Notes about wired in things * The name cache is initialised with (the names of) all wired-in things -* The type checker sees if the Name is wired in before looking up - the name in the type environment. So the type envt itself contains - no wired in things. +* The type environment itself contains no wired in things. The type + checker sees if the Name is wired in before looking up the name in + the type environment. * MkIface prunes out wired-in things before putting them in an interface file. So interface files never contain wired-in things. -} -wiredInThings :: [TyThing] --- This list is used only to initialise HscMain.knownKeyNames --- to ensure that when you say "Prelude.map" in your source code, you --- get a Name with the correct known key (See Note [Known-key names]) -wiredInThings - = concat - [ -- Wired in TyCons and their implicit Ids - tycon_things - , concatMap implicitTyThings tycon_things - - -- Wired in Ids - , map AnId wiredInIds - - -- PrimOps - , map (AnId . primOpId) allThePrimOps - ] + +knownKeyNames :: [Name] +-- This list is used to ensure that when you say "Prelude.map" +-- in your source code, or in an interface file, +-- you get a Name with the correct known key +-- (See Note [Known-key names] in PrelNames) +knownKeyNames + = concat [ tycon_kk_names funTyCon + , concatMap tycon_kk_names primTyCons + + , concatMap tycon_kk_names wiredInTyCons + -- Does not include tuples + + , concatMap tycon_kk_names typeNatTyCons + + , concatMap (rep_names . tupleTyCon Boxed) [2..mAX_TUPLE_SIZE] -- Yuk + + , cTupleTyConNames + -- Constraint tuples are known-key but not wired-in + -- They can't show up in source code, but can appear + -- in intreface files + + , map idName wiredInIds + , map (idName . primOpId) allThePrimOps + , basicKnownKeyNames ] where - tycon_things = map ATyCon ([funTyCon] ++ primTyCons ++ wiredInTyCons - ++ typeNatTyCons) + -- "kk" short for "known-key" + tycon_kk_names :: TyCon -> [Name] + tycon_kk_names tc = tyConName tc : (rep_names tc ++ concatMap thing_kk_names (implicitTyConThings tc)) + + datacon_kk_names dc + | Promoted tc <- promoteDataCon_maybe dc = dataConName dc : rep_names tc + | otherwise = [dataConName dc] + + thing_kk_names :: TyThing -> [Name] + thing_kk_names (ATyCon tc) = tycon_kk_names tc + thing_kk_names (AConLike (RealDataCon dc)) = datacon_kk_names dc + thing_kk_names thing = [getName thing] + + -- The TyConRepName for a known-key TyCon has a known key, + -- but isn't itself an implicit thing. Yurgh. + -- NB: if any of the wired-in TyCons had record fields, the record + -- field names would be in a similar situation. Ditto class ops. + -- But it happens that there aren't any + rep_names tc = case tyConRepName_maybe tc of + Just n -> [n] + Nothing -> [] {- We let a lot of "non-standard" values be visible, so that we can make diff --git a/compiler/prelude/PrelNames.hs b/compiler/prelude/PrelNames.hs index 30d11fef59..05a38ffec9 100644 --- a/compiler/prelude/PrelNames.hs +++ b/compiler/prelude/PrelNames.hs @@ -206,11 +206,13 @@ basicKnownKeyNames -- Typeable typeableClassName, typeRepTyConName, - mkTyConName, + trTyConDataConName, + trModuleDataConName, + trNameSDataConName, + typeRepIdName, mkPolyTyConAppName, mkAppTyName, - typeNatTypeRepName, - typeSymbolTypeRepName, + typeSymbolTypeRepName, typeNatTypeRepName, -- Dynamic toDynName, @@ -226,7 +228,6 @@ basicKnownKeyNames fromIntegralName, realToFracName, -- String stuff - stringTyConName, fromStringName, -- Enum stuff @@ -607,7 +608,8 @@ toInteger_RDR = nameRdrName toIntegerName toRational_RDR = nameRdrName toRationalName fromIntegral_RDR = nameRdrName fromIntegralName -fromString_RDR :: RdrName +stringTy_RDR, fromString_RDR :: RdrName +stringTy_RDR = tcQual_RDR gHC_BASE (fsLit "String") fromString_RDR = nameRdrName fromStringName fromList_RDR, fromListN_RDR, toList_RDR :: RdrName @@ -668,11 +670,6 @@ showString_RDR = varQual_RDR gHC_SHOW (fsLit "showString") showSpace_RDR = varQual_RDR gHC_SHOW (fsLit "showSpace") showParen_RDR = varQual_RDR gHC_SHOW (fsLit "showParen") -typeRep_RDR, mkTyCon_RDR, mkTyConApp_RDR :: RdrName -typeRep_RDR = varQual_RDR tYPEABLE_INTERNAL (fsLit "typeRep#") -mkTyCon_RDR = varQual_RDR tYPEABLE_INTERNAL (fsLit "mkTyCon") -mkTyConApp_RDR = varQual_RDR tYPEABLE_INTERNAL (fsLit "mkTyConApp") - undefined_RDR :: RdrName undefined_RDR = varQual_RDR gHC_ERR (fsLit "undefined") @@ -782,6 +779,39 @@ and it's convenient to write them all down in one place. -- guys as well (perhaps) e.g. see trueDataConName below -} +-- | Build a 'Name' for the 'Typeable' representation of the given special 'TyCon'. +-- Special 'TyCon's include @(->)@, @BOX@, @Constraint@, etc. See 'TysPrim'. +mkSpecialTyConRepName :: FastString -> Name -> Name +-- See Note [Grand plan for Typeable] in 'TcTypeable' in TcTypeable. +mkSpecialTyConRepName fs tc_name + = mkExternalName (tyConRepNameUnique (nameUnique tc_name)) + tYPEABLE_INTERNAL + (mkVarOccFS fs) + wiredInSrcSpan + +-- | Make a 'Name' for the 'Typeable' representation of the given wired-in type +mkPrelTyConRepName :: Name -> Name +-- See Note [Grand plan for Typeable] in 'TcTypeable' in TcTypeable. +mkPrelTyConRepName tc_name -- Prelude tc_name is always External, + -- so nameModule will work + = mkExternalName rep_uniq rep_mod rep_occ (nameSrcSpan tc_name) + where + name_occ = nameOccName tc_name + name_mod = nameModule tc_name + name_uniq = nameUnique tc_name + rep_uniq | isTcOcc name_occ = tyConRepNameUnique name_uniq + | otherwise = dataConRepNameUnique name_uniq + (rep_mod, rep_occ) = tyConRepModOcc name_mod name_occ + +-- | TODO +-- See Note [Grand plan for Typeable] in 'TcTypeable' in TcTypeable. +tyConRepModOcc :: Module -> OccName -> (Module, OccName) +tyConRepModOcc tc_module tc_occ + | tc_module == gHC_TYPES + = (tYPEABLE_INTERNAL, mkTyConRepUserOcc tc_occ) + | otherwise + = (tc_module, mkTyConRepSysOcc tc_occ) + wildCardName :: Name wildCardName = mkSystemVarName wildCardKey (fsLit "wild") @@ -849,12 +879,11 @@ uWordTyConName = tcQual gHC_GENERICS (fsLit "UWord") uWordTyConKey -- Base strings Strings unpackCStringName, unpackCStringFoldrName, - unpackCStringUtf8Name, eqStringName, stringTyConName :: Name + unpackCStringUtf8Name, eqStringName :: Name unpackCStringName = varQual gHC_CSTRING (fsLit "unpackCString#") unpackCStringIdKey unpackCStringFoldrName = varQual gHC_CSTRING (fsLit "unpackFoldrCString#") unpackCStringFoldrIdKey unpackCStringUtf8Name = varQual gHC_CSTRING (fsLit "unpackCStringUtf8#") unpackCStringUtf8IdKey eqStringName = varQual gHC_BASE (fsLit "eqString") eqStringIdKey -stringTyConName = tcQual gHC_BASE (fsLit "String") stringTyConKey -- The 'inline' function inlineIdName :: Name @@ -1053,15 +1082,21 @@ ixClassName = clsQual gHC_ARR (fsLit "Ix") ixClassKey -- Class Typeable, and functions for constructing `Typeable` dictionaries typeableClassName , typeRepTyConName - , mkTyConName + , trTyConDataConName + , trModuleDataConName + , trNameSDataConName , mkPolyTyConAppName , mkAppTyName + , typeRepIdName , typeNatTypeRepName , typeSymbolTypeRepName :: Name typeableClassName = clsQual tYPEABLE_INTERNAL (fsLit "Typeable") typeableClassKey typeRepTyConName = tcQual tYPEABLE_INTERNAL (fsLit "TypeRep") typeRepTyConKey -mkTyConName = varQual tYPEABLE_INTERNAL (fsLit "mkTyCon") mkTyConKey +trTyConDataConName = dcQual gHC_TYPES (fsLit "TyCon") trTyConDataConKey +trModuleDataConName = dcQual gHC_TYPES (fsLit "Module") trModuleDataConKey +trNameSDataConName = dcQual gHC_TYPES (fsLit "TrNameS") trNameSDataConKey +typeRepIdName = varQual tYPEABLE_INTERNAL (fsLit "typeRep#") typeRepIdKey mkPolyTyConAppName = varQual tYPEABLE_INTERNAL (fsLit "mkPolyTyConApp") mkPolyTyConAppKey mkAppTyName = varQual tYPEABLE_INTERNAL (fsLit "mkAppTy") mkAppTyKey typeNatTypeRepName = varQual tYPEABLE_INTERNAL (fsLit "typeNatTypeRep") typeNatTypeRepKey @@ -1342,7 +1377,7 @@ ghciIoClassKey :: Unique ghciIoClassKey = mkPreludeClassUnique 44 ---------------- Template Haskell ------------------- --- USES ClassUniques 200-299 +-- THNames.hs: USES ClassUniques 200-299 ----------------------------------------------------- {- @@ -1489,9 +1524,6 @@ unknown2TyConKey = mkPreludeTyConUnique 131 unknown3TyConKey = mkPreludeTyConUnique 132 opaqueTyConKey = mkPreludeTyConUnique 133 -stringTyConKey :: Unique -stringTyConKey = mkPreludeTyConUnique 134 - -- Generics (Unique keys) v1TyConKey, u1TyConKey, par1TyConKey, rec1TyConKey, k1TyConKey, m1TyConKey, sumTyConKey, prodTyConKey, @@ -1589,7 +1621,7 @@ ipCoNameKey = mkPreludeTyConUnique 185 ---------------- Template Haskell ------------------- --- USES TyConUniques 200-299 +-- THNames.hs: USES TyConUniques 200-299 ----------------------------------------------------- ----------------------- SIMD ------------------------ @@ -1668,6 +1700,16 @@ srcLocDataConKey = mkPreludeDataConUnique 37 ipDataConKey :: Unique ipDataConKey = mkPreludeDataConUnique 38 +trTyConDataConKey, trModuleDataConKey, trNameSDataConKey :: Unique +trTyConDataConKey = mkPreludeDataConUnique 40 +trModuleDataConKey = mkPreludeDataConUnique 41 +trNameSDataConKey = mkPreludeDataConUnique 42 + +---------------- Template Haskell ------------------- +-- THNames.hs: USES DataUniques 100-150 +----------------------------------------------------- + + {- ************************************************************************ * * @@ -1922,7 +1964,7 @@ proxyHashKey :: Unique proxyHashKey = mkPreludeMiscIdUnique 502 ---------------- Template Haskell ------------------- --- USES IdUniques 200-499 +-- THNames.hs: USES IdUniques 200-499 ----------------------------------------------------- -- Used to make `Typeable` dictionaries @@ -1931,19 +1973,21 @@ mkTyConKey , mkAppTyKey , typeNatTypeRepKey , typeSymbolTypeRepKey + , typeRepIdKey :: Unique mkTyConKey = mkPreludeMiscIdUnique 503 mkPolyTyConAppKey = mkPreludeMiscIdUnique 504 mkAppTyKey = mkPreludeMiscIdUnique 505 typeNatTypeRepKey = mkPreludeMiscIdUnique 506 typeSymbolTypeRepKey = mkPreludeMiscIdUnique 507 +typeRepIdKey = mkPreludeMiscIdUnique 508 -- Dynamic toDynIdKey :: Unique -toDynIdKey = mkPreludeMiscIdUnique 508 +toDynIdKey = mkPreludeMiscIdUnique 509 bitIntegerIdKey :: Unique -bitIntegerIdKey = mkPreludeMiscIdUnique 509 +bitIntegerIdKey = mkPreludeMiscIdUnique 510 {- ************************************************************************ diff --git a/compiler/prelude/THNames.hs b/compiler/prelude/THNames.hs index 062f9577e7..571487a274 100644 --- a/compiler/prelude/THNames.hs +++ b/compiler/prelude/THNames.hs @@ -448,23 +448,6 @@ unsafeName = libFun (fsLit "unsafe") unsafeIdKey safeName = libFun (fsLit "safe") safeIdKey interruptibleName = libFun (fsLit "interruptible") interruptibleIdKey --- data Inline = ... -noInlineDataConName, inlineDataConName, inlinableDataConName :: Name -noInlineDataConName = thCon (fsLit "NoInline") noInlineDataConKey -inlineDataConName = thCon (fsLit "Inline") inlineDataConKey -inlinableDataConName = thCon (fsLit "Inlinable") inlinableDataConKey - --- data RuleMatch = ... -conLikeDataConName, funLikeDataConName :: Name -conLikeDataConName = thCon (fsLit "ConLike") conLikeDataConKey -funLikeDataConName = thCon (fsLit "FunLike") funLikeDataConKey - --- data Phases = ... -allPhasesDataConName, fromPhaseDataConName, beforePhaseDataConName :: Name -allPhasesDataConName = thCon (fsLit "AllPhases") allPhasesDataConKey -fromPhaseDataConName = thCon (fsLit "FromPhase") fromPhaseDataConKey -beforePhaseDataConName = thCon (fsLit "BeforePhase") beforePhaseDataConKey - -- newtype TExp a = ... tExpDataConName :: Name tExpDataConName = thCon (fsLit "TExp") tExpDataConKey @@ -523,12 +506,42 @@ quotePatName = qqFun (fsLit "quotePat") quotePatKey quoteDecName = qqFun (fsLit "quoteDec") quoteDecKey quoteTypeName = qqFun (fsLit "quoteType") quoteTypeKey +-- data Inline = ... +noInlineDataConName, inlineDataConName, inlinableDataConName :: Name +noInlineDataConName = thCon (fsLit "NoInline") noInlineDataConKey +inlineDataConName = thCon (fsLit "Inline") inlineDataConKey +inlinableDataConName = thCon (fsLit "Inlinable") inlinableDataConKey + +-- data RuleMatch = ... +conLikeDataConName, funLikeDataConName :: Name +conLikeDataConName = thCon (fsLit "ConLike") conLikeDataConKey +funLikeDataConName = thCon (fsLit "FunLike") funLikeDataConKey + +-- data Phases = ... +allPhasesDataConName, fromPhaseDataConName, beforePhaseDataConName :: Name +allPhasesDataConName = thCon (fsLit "AllPhases") allPhasesDataConKey +fromPhaseDataConName = thCon (fsLit "FromPhase") fromPhaseDataConKey +beforePhaseDataConName = thCon (fsLit "BeforePhase") beforePhaseDataConKey + + +{- ********************************************************************* +* * + Class keys +* * +********************************************************************* -} + -- ClassUniques available: 200-299 -- Check in PrelNames if you want to change this liftClassKey :: Unique liftClassKey = mkPreludeClassUnique 200 +{- ********************************************************************* +* * + TyCon keys +* * +********************************************************************* -} + -- TyConUniques available: 200-299 -- Check in PrelNames if you want to change this @@ -574,6 +587,43 @@ tExpTyConKey = mkPreludeTyConUnique 230 injAnnTyConKey = mkPreludeTyConUnique 231 kindTyConKey = mkPreludeTyConUnique 232 +{- ********************************************************************* +* * + DataCon keys +* * +********************************************************************* -} + +-- DataConUniques available: 100-150 +-- If you want to change this, make sure you check in PrelNames + +-- data Inline = ... +noInlineDataConKey, inlineDataConKey, inlinableDataConKey :: Unique +noInlineDataConKey = mkPreludeDataConUnique 100 +inlineDataConKey = mkPreludeDataConUnique 101 +inlinableDataConKey = mkPreludeDataConUnique 102 + +-- data RuleMatch = ... +conLikeDataConKey, funLikeDataConKey :: Unique +conLikeDataConKey = mkPreludeDataConUnique 103 +funLikeDataConKey = mkPreludeDataConUnique 104 + +-- data Phases = ... +allPhasesDataConKey, fromPhaseDataConKey, beforePhaseDataConKey :: Unique +allPhasesDataConKey = mkPreludeDataConUnique 105 +fromPhaseDataConKey = mkPreludeDataConUnique 106 +beforePhaseDataConKey = mkPreludeDataConUnique 107 + +-- newtype TExp a = ... +tExpDataConKey :: Unique +tExpDataConKey = mkPreludeDataConUnique 108 + + +{- ********************************************************************* +* * + Id keys +* * +********************************************************************* -} + -- IdUniques available: 200-499 -- If you want to change this, make sure you check in PrelNames @@ -843,27 +893,6 @@ unsafeIdKey = mkPreludeMiscIdUnique 430 safeIdKey = mkPreludeMiscIdUnique 431 interruptibleIdKey = mkPreludeMiscIdUnique 432 --- data Inline = ... -noInlineDataConKey, inlineDataConKey, inlinableDataConKey :: Unique -noInlineDataConKey = mkPreludeDataConUnique 40 -inlineDataConKey = mkPreludeDataConUnique 41 -inlinableDataConKey = mkPreludeDataConUnique 42 - --- data RuleMatch = ... -conLikeDataConKey, funLikeDataConKey :: Unique -conLikeDataConKey = mkPreludeDataConUnique 43 -funLikeDataConKey = mkPreludeDataConUnique 44 - --- data Phases = ... -allPhasesDataConKey, fromPhaseDataConKey, beforePhaseDataConKey :: Unique -allPhasesDataConKey = mkPreludeDataConUnique 45 -fromPhaseDataConKey = mkPreludeDataConUnique 46 -beforePhaseDataConKey = mkPreludeDataConUnique 47 - --- newtype TExp a = ... -tExpDataConKey :: Unique -tExpDataConKey = mkPreludeDataConUnique 48 - -- data FunDep = ... funDepIdKey :: Unique funDepIdKey = mkPreludeMiscIdUnique 440 diff --git a/compiler/prelude/TysPrim.hs b/compiler/prelude/TysPrim.hs index d66b48e3b7..3a6dd0341e 100644 --- a/compiler/prelude/TysPrim.hs +++ b/compiler/prelude/TysPrim.hs @@ -10,6 +10,8 @@ -- | This module defines TyCons that can't be expressed in Haskell. -- They are all, therefore, wired-in TyCons. C.f module TysWiredIn module TysPrim( + mkPrimTyConName, -- For implicit parameters in TysWiredIn only + mkTemplateTyVars, alphaTyVars, betaTyVars, alphaTyVar, betaTyVar, gammaTyVar, deltaTyVar, alphaTy, betaTy, gammaTy, deltaTy, @@ -81,12 +83,11 @@ module TysPrim( #include "HsVersions.h" import Var ( TyVar, KindVar, mkTyVar ) -import Name ( Name, BuiltInSyntax(..), mkInternalName, mkWiredInName ) -import OccName ( mkTyVarOccFS, mkTcOccFS ) +import Name import TyCon import TypeRep import SrcLoc -import Unique ( mkAlphaTyVarUnique ) +import Unique import PrelNames import FastString @@ -258,8 +259,9 @@ funTyConName :: Name funTyConName = mkPrimTyConName (fsLit "(->)") funTyConKey funTyCon funTyCon :: TyCon -funTyCon = mkFunTyCon funTyConName $ - mkArrowKinds [liftedTypeKind, liftedTypeKind] liftedTypeKind +funTyCon = mkFunTyCon funTyConName kind tc_rep_nm + where + kind = mkArrowKinds [liftedTypeKind, liftedTypeKind] liftedTypeKind -- You might think that (->) should have type (?? -> ? -> *), and you'd be right -- But if we do that we get kind errors when saying -- instance Control.Arrow (->) @@ -269,6 +271,8 @@ funTyCon = mkFunTyCon funTyConName $ -- a prefix way, thus: (->) Int# Int#. And this is unusual. -- because they are never in scope in the source + tc_rep_nm = mkSpecialTyConRepName (fsLit "tcFun") funTyConName + -- One step to remove subkinding. -- (->) :: * -> * -> * -- but we should have (and want) the following typing rule for fully applied arrows @@ -318,14 +322,21 @@ superKindTyConName, anyKindTyConName, liftedTypeKindTyConName, constraintKindTyConName :: Name -superKindTyCon = mkKindTyCon superKindTyConName superKind - -- See Note [SuperKind (BOX)] +mk_kind_tycon :: Name -- ^ Name of the kind constructor, e.g. @*@ + -> FastString -- ^ Name of the 'TyConRepName' function, + -- e.g. @tcLiftedKind :: TyCon@ + -> TyCon -- ^ The kind constructor +mk_kind_tycon tc_name rep_fs + = mkKindTyCon tc_name superKind (mkSpecialTyConRepName rep_fs tc_name) + +superKindTyCon = mk_kind_tycon superKindTyConName (fsLit "tcBOX") + -- See Note [SuperKind (BOX)] -anyKindTyCon = mkKindTyCon anyKindTyConName superKind -liftedTypeKindTyCon = mkKindTyCon liftedTypeKindTyConName superKind -openTypeKindTyCon = mkKindTyCon openTypeKindTyConName superKind -unliftedTypeKindTyCon = mkKindTyCon unliftedTypeKindTyConName superKind -constraintKindTyCon = mkKindTyCon constraintKindTyConName superKind +anyKindTyCon = mk_kind_tycon anyKindTyConName (fsLit "tcAnyK") +constraintKindTyCon = mk_kind_tycon constraintKindTyConName (fsLit "tcConstraint") +liftedTypeKindTyCon = mk_kind_tycon liftedTypeKindTyConName (fsLit "tcLiftedKind") +openTypeKindTyCon = mk_kind_tycon openTypeKindTyConName (fsLit "tcOpenKind") +unliftedTypeKindTyCon = mk_kind_tycon unliftedTypeKindTyConName (fsLit "tcUnliftedKind") -------------------------- -- ... and now their names @@ -736,6 +747,7 @@ variables with no constraints on them. It appears in similar circumstances to Any, but at the kind level. For example: type family Length (l :: [k]) :: Nat + type instance Length [] = Zero f :: Proxy (Length []) -> Int f = .... @@ -776,7 +788,7 @@ anyTy = mkTyConTy anyTyCon anyTyCon :: TyCon anyTyCon = mkFamilyTyCon anyTyConName kind [kKiVar] Nothing (ClosedSynFamilyTyCon Nothing) - NoParentTyCon + Nothing NotInjective where kind = ForAllTy kKiVar (mkTyVarTy kKiVar) diff --git a/compiler/prelude/TysWiredIn.hs b/compiler/prelude/TysWiredIn.hs index e8a06e7ad4..067700f120 100644 --- a/compiler/prelude/TysWiredIn.hs +++ b/compiler/prelude/TysWiredIn.hs @@ -99,6 +99,7 @@ import TysPrim -- others: import CoAxiom import Coercion +import Id import Constants ( mAX_TUPLE_SIZE, mAX_CTUPLE_SIZE ) import Module ( Module ) import Type ( mkTyConApp ) @@ -289,7 +290,7 @@ pcTyCon is_enum is_rec is_prom name cType tyvars cons is_rec is_prom False -- Not in GADT syntax - NoParentTyCon + (VanillaAlgTyCon (mkPrelTyConRepName name)) pcDataCon :: Name -> [TyVar] -> [Type] -> TyCon -> DataCon pcDataCon = pcDataConWithFixity False @@ -310,7 +311,7 @@ pcDataConWithFixity' :: Bool -> Name -> Unique -> [TyVar] -> [Type] -> TyCon -> pcDataConWithFixity' declared_infix dc_name wrk_key tyvars arg_tys tycon = data_con where - data_con = mkDataCon dc_name declared_infix + data_con = mkDataCon dc_name declared_infix prom_info (map (const no_bang) arg_tys) [] -- No labelled fields tyvars @@ -327,10 +328,16 @@ pcDataConWithFixity' declared_infix dc_name wrk_key tyvars arg_tys tycon modu = ASSERT( isExternalName dc_name ) nameModule dc_name - wrk_occ = mkDataConWorkerOcc (nameOccName dc_name) + dc_occ = nameOccName dc_name + wrk_occ = mkDataConWorkerOcc dc_occ wrk_name = mkWiredInName modu wrk_occ wrk_key (AnId (dataConWorkId data_con)) UserSyntax + prom_info | Promoted {} <- promotableTyCon_maybe tycon -- Knot-tied + = Promoted (mkPrelTyConRepName dc_name) + | otherwise + = NotPromoted + {- ************************************************************************ * * @@ -498,15 +505,19 @@ mk_tuple boxity arity = (tycon, tuple_con) where tycon = mkTupleTyCon tc_name tc_kind arity tyvars tuple_con tup_sort - prom_tc NoParentTyCon + prom_tc flavour + + flavour = case boxity of + Boxed -> VanillaAlgTyCon (mkPrelTyConRepName tc_name) + Unboxed -> UnboxedAlgTyCon tup_sort = case boxity of Boxed -> BoxedTuple Unboxed -> UnboxedTuple prom_tc = case boxity of - Boxed -> Just (mkPromotedTyCon tycon (promoteKind tc_kind)) - Unboxed -> Nothing + Boxed -> Promoted (mkPromotedTyCon tycon (promoteKind tc_kind)) + Unboxed -> NotPromoted modu = case boxity of Boxed -> gHC_TUPLE @@ -732,8 +743,11 @@ mkListTy :: Type -> Type mkListTy ty = mkTyConApp listTyCon [ty] listTyCon :: TyCon -listTyCon = pcTyCon False Recursive True - listTyConName Nothing alpha_tyvar [nilDataCon, consDataCon] +listTyCon = buildAlgTyCon listTyConName alpha_tyvar [Representational] + Nothing [] + (DataTyCon [nilDataCon, consDataCon] False ) + Recursive True False + (VanillaAlgTyCon (mkSpecialTyConRepName (fsLit "tcList") listTyConName)) mkPromotedListTy :: Type -> Type mkPromotedListTy ty = mkTyConApp promotedListTyCon [ty] @@ -930,10 +944,10 @@ eqTyCon = mkAlgTyCon eqTyConName Nothing [] -- No stupid theta (DataTyCon [eqBoxDataCon] False) - NoParentTyCon + (VanillaAlgTyCon (mkSpecialTyConRepName (fsLit "tcEq") eqTyConName)) NonRecursive False - Nothing -- No parent for constraint-kinded types + NotPromoted where kv = kKiVar k = mkTyVarTy kv @@ -949,15 +963,17 @@ eqBoxDataCon = pcDataCon eqBoxDataConName args [TyConApp eqPrimTyCon (map mkTyVa coercibleTyCon :: TyCon -coercibleTyCon = mkClassTyCon - coercibleTyConName kind tvs [Nominal, Representational, Representational] - rhs coercibleClass NonRecursive - where kind = (ForAllTy kv $ mkArrowKinds [k, k] constraintKind) - kv = kKiVar - k = mkTyVarTy kv - [a,b] = mkTemplateTyVars [k,k] - tvs = [kv, a, b] - rhs = DataTyCon [coercibleDataCon] False +coercibleTyCon = mkClassTyCon coercibleTyConName kind tvs + [Nominal, Representational, Representational] + rhs coercibleClass NonRecursive + (mkPrelTyConRepName coercibleTyConName) + where + kind = (ForAllTy kv $ mkArrowKinds [k, k] constraintKind) + kv = kKiVar + k = mkTyVarTy kv + [a,b] = mkTemplateTyVars [k,k] + tvs = [kv, a, b] + rhs = DataTyCon [coercibleDataCon] False coercibleDataCon :: DataCon coercibleDataCon = pcDataCon coercibleDataConName args [TyConApp eqReprPrimTyCon (map mkTyVarTy args)] coercibleTyCon @@ -994,6 +1010,7 @@ ipCoName = mkWiredInCoAxiomName BuiltInSyntax gHC_CLASSES (fsLit "NTCo:IP") -- See Note [The Implicit Parameter class] ipTyCon :: TyCon ipTyCon = mkClassTyCon ipTyConName kind [ip,a] [] rhs ipClass NonRecursive + (mkPrelTyConRepName ipTyConName) where kind = mkArrowKinds [typeSymbolKind, liftedTypeKind] constraintKind [ip,a] = mkTemplateTyVars [typeSymbolKind, liftedTypeKind] diff --git a/compiler/simplCore/FloatIn.hs b/compiler/simplCore/FloatIn.hs index 5390c48dd3..412125ae3e 100644 --- a/compiler/simplCore/FloatIn.hs +++ b/compiler/simplCore/FloatIn.hs @@ -25,7 +25,7 @@ import CoreUtils ( exprIsDupable, exprIsExpandable, exprType, import CoreFVs ( CoreExprWithFVs, freeVars, freeVarsOf, idRuleAndUnfoldingVars ) import Id ( isOneShotBndr, idType ) import Var -import Type ( Type, isUnLiftedType, splitFunTy, applyTy ) +import Type ( Type, isUnLiftedType, isFunTy, splitFunTy, applyTy ) import VarSet import Util import UniqFM @@ -168,7 +168,7 @@ fiExpr dflags to_drop ann_expr@(_,AnnApp {}) = ((applyTy fun_ty ty, extra_fvs), emptyVarSet) mk_arg_fvs (fun_ty, extra_fvs) (arg_fvs, ann_arg) - | noFloatIntoRhs ann_arg arg_ty + | ASSERT( isFunTy fun_ty ) noFloatIntoRhs ann_arg arg_ty = ((res_ty, extra_fvs `unionVarSet` arg_fvs), emptyVarSet) | otherwise = ((res_ty, extra_fvs), arg_fvs) diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs index 217739201b..d8c0350096 100644 --- a/compiler/typecheck/TcBinds.hs +++ b/compiler/typecheck/TcBinds.hs @@ -8,9 +8,9 @@ {-# LANGUAGE CPP, RankNTypes, ScopedTypeVariables #-} module TcBinds ( tcLocalBinds, tcTopBinds, tcRecSelBinds, - tcHsBootSigs, tcPolyCheck, + tcValBinds, tcHsBootSigs, tcPolyCheck, tcSpecPrags, tcSpecWrapper, - tcVectDecls, + tcVectDecls, addTypecheckedBinds, TcSigInfo(..), TcSigFun, TcPragEnv, mkPragEnv, instTcTySig, instTcTySigFromId, findScopedTyVars, @@ -66,6 +66,21 @@ import Data.List (partition) #include "HsVersions.h" +{- ********************************************************************* +* * + A useful helper function +* * +********************************************************************* -} + +addTypecheckedBinds :: TcGblEnv -> [LHsBinds Id] -> TcGblEnv +addTypecheckedBinds tcg_env binds + | isHsBoot (tcg_src tcg_env) = tcg_env + -- Do not add the code for record-selector bindings + -- when compiling hs-boot files + | otherwise = tcg_env { tcg_binds = foldr unionBags + (tcg_binds tcg_env) + binds } + {- ************************************************************************ * * @@ -169,10 +184,8 @@ tcTopBinds (ValBindsOut binds sigs) ; return (gbl, lcl) } ; specs <- tcImpPrags sigs -- SPECIALISE prags for imported Ids - ; let { tcg_env' = tcg_env { tcg_binds = foldr (unionBags . snd) - (tcg_binds tcg_env) - binds' - , tcg_imp_specs = specs ++ tcg_imp_specs tcg_env } } + ; let { tcg_env' = tcg_env { tcg_imp_specs = specs ++ tcg_imp_specs tcg_env } + `addTypecheckedBinds` map snd binds' } ; return (tcg_env', tcl_env) } -- The top level bindings are flattened into a giant @@ -182,15 +195,17 @@ tcTopBinds (ValBindsIn {}) = panic "tcTopBinds" tcRecSelBinds :: HsValBinds Name -> TcM TcGblEnv tcRecSelBinds (ValBindsOut binds sigs) - = tcExtendGlobalValEnv [sel_id | L _ (IdSig sel_id) <- sigs] $ - do { (rec_sel_binds, tcg_env) <- discardWarnings (tcValBinds TopLevel binds sigs getGblEnv) + = -- tcExtendGlobalValEnv [sel_id | L _ (IdSig sel_id) <- sigs] $ + -- this envt extension happens in tcValBinds + do { (rec_sel_binds, tcg_env) <- discardWarnings $ + tcValBinds TopLevel binds sigs getGblEnv ; let tcg_env' | isHsBoot (tcg_src tcg_env) = tcg_env | otherwise = tcg_env { tcg_binds = foldr (unionBags . snd) (tcg_binds tcg_env) rec_sel_binds } - -- Do not add the code for record-selector bindings when - -- compiling hs-boot files + -- Do not add the code for record-selector bindings + -- when compiling hs-boot files ; return tcg_env' } tcRecSelBinds (ValBindsIn {}) = panic "tcRecSelBinds" diff --git a/compiler/typecheck/TcEnv.hs b/compiler/typecheck/TcEnv.hs index 5d1c1be3ad..3bb2703104 100644 --- a/compiler/typecheck/TcEnv.hs +++ b/compiler/typecheck/TcEnv.hs @@ -631,13 +631,12 @@ tcGetDefaultTys -- No use-supplied default -- Use [Integer, Double], plus modifications { integer_ty <- tcMetaTy integerTyConName - ; checkWiredInTyCon doubleTyCon - ; string_ty <- tcMetaTy stringTyConName ; list_ty <- tcMetaTy listTyConName + ; checkWiredInTyCon doubleTyCon ; let deflt_tys = opt_deflt extended_defaults [unitTy, list_ty] -- Note [Extended defaults] ++ [integer_ty, doubleTy] - ++ opt_deflt ovl_strings [string_ty] + ++ opt_deflt ovl_strings [stringTy] ; return (deflt_tys, flags) } } } where opt_deflt True xs = xs diff --git a/compiler/typecheck/TcEvidence.hs b/compiler/typecheck/TcEvidence.hs index 83bbcca1b7..1cfa351125 100644 --- a/compiler/typecheck/TcEvidence.hs +++ b/compiler/typecheck/TcEvidence.hs @@ -730,24 +730,27 @@ data EvTerm | EvLit EvLit -- Dictionary for KnownNat and KnownSymbol classes. -- Note [KnownNat & KnownSymbol and EvLit] - | EvCallStack EvCallStack -- Dictionary for CallStack implicit parameters + | EvCallStack EvCallStack -- Dictionary for CallStack implicit parameters - | EvTypeable EvTypeable -- Dictionary for `Typeable` + | EvTypeable Type EvTypeable -- Dictionary for (Typeable ty) deriving( Data.Data, Data.Typeable ) -- | Instructions on how to make a 'Typeable' dictionary. +-- See Note [Typeable evidence terms] data EvTypeable - = EvTypeableTyCon TyCon [Kind] - -- ^ Dictionary for concrete type constructors. + = EvTypeableTyCon -- ^ Dictionary for @Typeable (T k1..kn)@ - | EvTypeableTyApp (EvTerm,Type) (EvTerm,Type) - -- ^ Dictionary for type applications; this is used when we have - -- a type expression starting with a type variable (e.g., @Typeable (f a)@) + | EvTypeableTyApp EvTerm EvTerm + -- ^ Dictionary for @Typeable (s t)@, + -- given a dictionaries for @s@ and @t@ - | EvTypeableTyLit (EvTerm,Type) - -- ^ Dictionary for a type literal. + | EvTypeableTyLit EvTerm + -- ^ Dictionary for a type literal, + -- e.g. @Typeable "foo"@ or @Typeable 3@ + -- The 'EvTerm' is evidence of, e.g., @KnownNat 3@ + -- (see Trac #10348) deriving ( Data.Data, Data.Typeable ) @@ -769,6 +772,20 @@ data EvCallStack deriving( Data.Data, Data.Typeable ) {- +Note [Typeable evidence terms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The EvTypeable data type looks isomorphic to Type, but the EvTerms +inside can be EvIds. Eg + f :: forall a. Typeable a => a -> TypeRep + f x = typeRep (undefined :: Proxy [a]) +Here for the (Typeable [a]) dictionary passed to typeRep we make +evidence + dl :: Typeable [a] = EvTypeable [a] + (EvTypeableTyApp EvTypeableTyCon (EvId d)) +where + d :: Typable a +is the lambda-bound dictionary passed into f. + Note [Coercion evidence terms] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ A "coercion evidence term" takes one of these forms @@ -1009,7 +1026,7 @@ evVarsOfTerm (EvCast tm co) = evVarsOfTerm tm `unionVarSet` coVarsOfTcCo c evVarsOfTerm (EvDelayedError _ _) = emptyVarSet evVarsOfTerm (EvLit _) = emptyVarSet evVarsOfTerm (EvCallStack cs) = evVarsOfCallStack cs -evVarsOfTerm (EvTypeable ev) = evVarsOfTypeable ev +evVarsOfTerm (EvTypeable _ ev) = evVarsOfTypeable ev evVarsOfTerms :: [EvTerm] -> VarSet evVarsOfTerms = mapUnionVarSet evVarsOfTerm @@ -1023,9 +1040,9 @@ evVarsOfCallStack cs = case cs of evVarsOfTypeable :: EvTypeable -> VarSet evVarsOfTypeable ev = case ev of - EvTypeableTyCon _ _ -> emptyVarSet - EvTypeableTyApp e1 e2 -> evVarsOfTerms (map fst [e1,e2]) - EvTypeableTyLit e -> evVarsOfTerm (fst e) + EvTypeableTyCon -> emptyVarSet + EvTypeableTyApp e1 e2 -> evVarsOfTerms [e1,e2] + EvTypeableTyLit e -> evVarsOfTerm e {- ************************************************************************ @@ -1082,16 +1099,16 @@ instance Outputable EvBind where -- We cheat a bit and pretend EqVars are CoVars for the purposes of pretty printing instance Outputable EvTerm where - ppr (EvId v) = ppr v - ppr (EvCast v co) = ppr v <+> (ptext (sLit "`cast`")) <+> pprParendTcCo co - ppr (EvCoercion co) = ptext (sLit "CO") <+> ppr co - ppr (EvSuperClass d n) = ptext (sLit "sc") <> parens (ppr (d,n)) - ppr (EvDFunApp df tys ts) = ppr df <+> sep [ char '@' <> ppr tys, ppr ts ] - ppr (EvLit l) = ppr l - ppr (EvCallStack cs) = ppr cs - ppr (EvDelayedError ty msg) = ptext (sLit "error") + ppr (EvId v) = ppr v + ppr (EvCast v co) = ppr v <+> (ptext (sLit "`cast`")) <+> pprParendTcCo co + ppr (EvCoercion co) = ptext (sLit "CO") <+> ppr co + ppr (EvSuperClass d n) = ptext (sLit "sc") <> parens (ppr (d,n)) + ppr (EvDFunApp df tys ts) = ppr df <+> sep [ char '@' <> ppr tys, ppr ts ] + ppr (EvLit l) = ppr l + ppr (EvCallStack cs) = ppr cs + ppr (EvDelayedError ty msg) = ptext (sLit "error") <+> sep [ char '@' <> ppr ty, ppr msg ] - ppr (EvTypeable ev) = ppr ev + ppr (EvTypeable ty ev) = ppr ev <+> dcolon <+> ptext (sLit "Typeable") <+> ppr ty instance Outputable EvLit where ppr (EvNum n) = integer n @@ -1106,11 +1123,9 @@ instance Outputable EvCallStack where = angleBrackets (ppr (name,loc)) <+> ptext (sLit ":") <+> ppr tm instance Outputable EvTypeable where - ppr ev = - case ev of - EvTypeableTyCon tc ks -> parens (ppr tc <+> sep (map ppr ks)) - EvTypeableTyApp t1 t2 -> parens (ppr (fst t1) <+> ppr (fst t2)) - EvTypeableTyLit x -> ppr (fst x) + ppr EvTypeableTyCon = ptext (sLit "TC") + ppr (EvTypeableTyApp t1 t2) = parens (ppr t1 <+> ppr t2) + ppr (EvTypeableTyLit t1) = ptext (sLit "TyLit") <> ppr t1 ---------------------------------------------------------------------- diff --git a/compiler/typecheck/TcGenGenerics.hs b/compiler/typecheck/TcGenGenerics.hs index f69c137762..9a1c506b33 100644 --- a/compiler/typecheck/TcGenGenerics.hs +++ b/compiler/typecheck/TcGenGenerics.hs @@ -73,23 +73,23 @@ gen_Generic_binds gk tc metaTyCons mod = do genGenericMetaTyCons :: TyCon -> TcM (MetaTyCons, BagDerivStuff) genGenericMetaTyCons tc = - do let - tc_name = tyConName tc - mod = nameModule tc_name - tc_cons = tyConDataCons tc - tc_arits = map dataConSourceArity tc_cons - - tc_occ = nameOccName tc_name - d_occ = mkGenD mod tc_occ - c_occ m = mkGenC mod tc_occ m - s_occ m n = mkGenS mod tc_occ m n - - mkTyCon name = ASSERT( isExternalName name ) - buildAlgTyCon name [] [] Nothing [] distinctAbstractTyConRhs - NonRecursive - False -- Not promotable - False -- Not GADT syntax - NoParentTyCon + do let tc_name = tyConName tc + ty_rep_name <- newTyConRepName tc_name + let mod = nameModule tc_name + tc_cons = tyConDataCons tc + tc_arits = map dataConSourceArity tc_cons + + tc_occ = nameOccName tc_name + d_occ = mkGenD mod tc_occ + c_occ m = mkGenC mod tc_occ m + s_occ m n = mkGenS mod tc_occ m n + + mkTyCon name = ASSERT( isExternalName name ) + buildAlgTyCon name [] [] Nothing [] distinctAbstractTyConRhs + NonRecursive + False -- Not promotable + False -- Not GADT syntax + (VanillaAlgTyCon ty_rep_name) loc <- getSrcSpanM -- we generate new names in current module @@ -265,10 +265,9 @@ canDoGenerics tc tc_args where -- The tc can be a representation tycon. When we want to display it to the -- user (in an error message) we should print its parent - (tc_name, tc_tys) = case tyConParent tc of - FamInstTyCon _ ptc tys -> (ppr ptc, hsep (map ppr - (tys ++ drop (length tys) tc_args))) - _ -> (ppr tc, hsep (map ppr (tyConTyVars tc))) + (tc_name, tc_tys) = case tyConFamInst_maybe tc of + Just (ptc, tys) -> (ppr ptc, hsep (map ppr (tys ++ drop (length tys) tc_args))) + _ -> (ppr tc, hsep (map ppr (tyConTyVars tc))) -- Check (d) from Note [Requirements for deriving Generic and Rep]. -- diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs index 5aa797c4c2..ddf9c4ff36 100644 --- a/compiler/typecheck/TcHsSyn.hs +++ b/compiler/typecheck/TcHsSyn.hs @@ -1282,19 +1282,10 @@ zonkEvTerm env (EvCast tm co) = do { tm' <- zonkEvTerm env tm ; return (mkEvCast tm' co') } zonkEvTerm _ (EvLit l) = return (EvLit l) -zonkEvTerm env (EvTypeable ev) = - fmap EvTypeable $ - case ev of - EvTypeableTyCon tc ks -> return (EvTypeableTyCon tc ks) - EvTypeableTyApp t1 t2 -> do e1 <- zonk t1 - e2 <- zonk t2 - return (EvTypeableTyApp e1 e2) - EvTypeableTyLit t -> EvTypeableTyLit `fmap` zonk t - where - zonk (ev,t) = do ev' <- zonkEvTerm env ev - t' <- zonkTcTypeToType env t - return (ev',t') - +zonkEvTerm env (EvTypeable ty ev) = + do { ev' <- zonkEvTypeable env ev + ; ty' <- zonkTcTypeToType env ty + ; return (EvTypeable ty' ev') } zonkEvTerm env (EvCallStack cs) = case cs of EvCsEmpty -> return (EvCallStack cs) @@ -1312,6 +1303,16 @@ zonkEvTerm env (EvDelayedError ty msg) = do { ty' <- zonkTcTypeToType env ty ; return (EvDelayedError ty' msg) } +zonkEvTypeable :: ZonkEnv -> EvTypeable -> TcM EvTypeable +zonkEvTypeable _ EvTypeableTyCon + = return EvTypeableTyCon +zonkEvTypeable env (EvTypeableTyApp t1 t2) + = do { t1' <- zonkEvTerm env t1 + ; t2' <- zonkEvTerm env t2 + ; return (EvTypeableTyApp t1' t2') } +zonkEvTypeable _ (EvTypeableTyLit t1) + = return (EvTypeableTyLit t1) + zonkTcEvBinds_s :: ZonkEnv -> [TcEvBinds] -> TcM (ZonkEnv, [TcEvBinds]) zonkTcEvBinds_s env bs = do { (env, bs') <- mapAccumLM zonk_tc_ev_binds env bs ; return (env, [EvBinds (unionManyBags bs')]) } diff --git a/compiler/typecheck/TcHsType.hs b/compiler/typecheck/TcHsType.hs index 2f427916b4..191756ac7a 100644 --- a/compiler/typecheck/TcHsType.hs +++ b/compiler/typecheck/TcHsType.hs @@ -659,7 +659,7 @@ tcTyVar name -- Could be a tyvar, a tycon, or a datacon AGlobal (ATyCon tc) -> inst_tycon (mkTyConApp tc) (tyConKind tc) AGlobal (AConLike (RealDataCon dc)) - | Just tc <- promoteDataCon_maybe dc + | Promoted tc <- promoteDataCon_maybe dc -> do { data_kinds <- xoptM Opt_DataKinds ; unless data_kinds $ promotionErr name NoDataKinds ; inst_tycon (mkTyConApp tc) (tyConKind tc) } @@ -1619,10 +1619,10 @@ tc_kind_var_app name arg_kis -> do { data_kinds <- xoptM Opt_DataKinds ; unless data_kinds $ addErr (dataKindsErr name) ; case promotableTyCon_maybe tc of - Just prom_tc | arg_kis `lengthIs` tyConArity prom_tc + Promoted prom_tc | arg_kis `lengthIs` tyConArity prom_tc -> return (mkTyConApp prom_tc arg_kis) - Just _ -> tycon_err tc "is not fully applied" - Nothing -> tycon_err tc "is not promotable" } + Promoted _ -> tycon_err tc "is not fully applied" + NotPromoted -> tycon_err tc "is not promotable" } -- A lexically scoped kind variable ATyVar _ kind_var diff --git a/compiler/typecheck/TcInstDcls.hs b/compiler/typecheck/TcInstDcls.hs index c97e4e128c..ef0c4b6c8f 100644 --- a/compiler/typecheck/TcInstDcls.hs +++ b/compiler/typecheck/TcInstDcls.hs @@ -434,7 +434,7 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls ptext (sLit "Replace the following instance:")) 2 (pprInstanceHdr (iSpec i)) - -- Report an error or a warning for a `Typeable` instances. + -- Report an error or a warning for a Typeable instances. -- If we are working on an .hs-boot file, we just report a warning, -- and ignore the instance. We do this, to give users a chance to fix -- their code. @@ -445,10 +445,13 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls then do warn <- woptM Opt_WarnDerivingTypeable when warn $ addWarnTc $ vcat - [ ptext (sLit "`Typeable` instances in .hs-boot files are ignored.") - , ptext (sLit "This warning will become an error in future versions of the compiler.") + [ ppTypeable <+> ptext (sLit "instances in .hs-boot files are ignored") + , ptext (sLit "This warning will become an error in future versions of the compiler") ] - else addErrTc $ ptext (sLit "Class `Typeable` does not support user-specified instances.") + else addErrTc $ ptext (sLit "Class") <+> ppTypeable + <+> ptext (sLit "does not support user-specified instances") + ppTypeable :: SDoc + ppTypeable = quotes (ppr typeableClassName) addClsInsts :: [InstInfo Name] -> TcM a -> TcM a addClsInsts infos thing_inside @@ -633,7 +636,7 @@ tcDataFamInstDecl mb_clsinfo -- Check that the family declaration is for the right kind ; checkTc (isFamilyTyCon fam_tc) (notFamily fam_tc) - ; checkTc (isAlgTyCon fam_tc) (wrongKindOfFamily fam_tc) + ; checkTc (isDataFamilyTyCon fam_tc) (wrongKindOfFamily fam_tc) -- Kind check type patterns ; tcFamTyPats (famTyConShape fam_tc) mb_clsinfo pats @@ -659,7 +662,9 @@ tcDataFamInstDecl mb_clsinfo ; let orig_res_ty = mkTyConApp fam_tc pats' ; (rep_tc, fam_inst) <- fixM $ \ ~(rec_rep_tc, _) -> - do { data_cons <- tcConDecls new_or_data rec_rep_tc + do { data_cons <- tcConDecls new_or_data + False -- Not promotable + rec_rep_tc (tvs', orig_res_ty) cons ; tc_rhs <- case new_or_data of DataType -> return (mkDataTyConRhs data_cons) @@ -670,7 +675,7 @@ tcDataFamInstDecl mb_clsinfo axiom = mkSingleCoAxiom Representational axiom_name eta_tvs fam_tc eta_pats (mkTyConApp rep_tc (mkTyVarTys eta_tvs)) - parent = FamInstTyCon axiom fam_tc pats' + parent = DataFamInstTyCon axiom fam_tc pats' roles = map (const Nominal) tvs' -- NB: Use the tvs' from the pats. See bullet toward diff --git a/compiler/typecheck/TcInteract.hs b/compiler/typecheck/TcInteract.hs index 49a5d4cc09..47147d7a4d 100644 --- a/compiler/typecheck/TcInteract.hs +++ b/compiler/typecheck/TcInteract.hs @@ -16,10 +16,11 @@ import VarSet import Type import Kind ( isKind ) import InstEnv( DFunInstType, lookupInstEnv, instanceDFunId ) -import CoAxiom(sfInteractTop, sfInteractInert) +import CoAxiom( sfInteractTop, sfInteractInert ) import Var import TcType +import Name import PrelNames ( knownNatClassName, knownSymbolClassName, callStackTyConKey, typeableClassName ) import TysWiredIn ( ipClass, typeNatKind, typeSymbolKind ) @@ -743,11 +744,11 @@ addFunDepWork inerts work_ev cls inert_pred inert_loc } {- -********************************************************************************* -* * +********************************************************************** +* * Implicit parameters -* * -********************************************************************************* +* * +********************************************************************** -} interactGivenIP :: InertCans -> Ct -> TcS (StopOrContinue Ct) @@ -770,6 +771,26 @@ interactGivenIP inerts workItem@(CDictCan { cc_ev = ev, cc_class = cls interactGivenIP _ wi = pprPanic "interactGivenIP" (ppr wi) +-- | Is the constraint for an implicit CallStack parameter? +-- i.e. (IP "name" CallStack) +isCallStackIP :: CtLoc -> Class -> [Type] -> Maybe (EvTerm -> EvCallStack) +isCallStackIP loc cls tys + | cls == ipClass + , [_ip_name, ty] <- tys + , Just (tc, _) <- splitTyConApp_maybe ty + , tc `hasKey` callStackTyConKey + = occOrigin (ctLocOrigin loc) + | otherwise + = Nothing + where + locSpan = ctLocSpan loc + + -- We only want to grab constraints that arose due to the use of an IP or a + -- function call. See Note [Overview of implicit CallStacks] + occOrigin (OccurrenceOf n) = Just (EvCsPushCall n locSpan) + occOrigin (IPOccOrigin n) = Just (EvCsTop ('?' `consFS` hsIPNameFS n) locSpan) + occOrigin _ = Nothing + {- Note [Shadowing of Implicit Parameters] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -821,11 +842,11 @@ I can think of two ways to fix this: error if we get multiple givens for the same implicit parameter. -********************************************************************************* -* * +********************************************************************** +* * interactFunEq -* * -********************************************************************************* +* * +********************************************************************** -} interactFunEq :: InertCans -> Ct -> TcS (StopOrContinue Ct) @@ -1056,11 +1077,11 @@ The second is the right thing to do. Hence the isMetaTyVarTy test when solving pairwise CFunEqCan. -********************************************************************************* -* * +********************************************************************** +* * interactTyVarEq -* * -********************************************************************************* +* * +********************************************************************** -} interactTyVarEq :: InertCans -> Ct -> TcS (StopOrContinue Ct) @@ -1233,11 +1254,11 @@ emitFunDepDeriveds fd_eqns Pair (Type.substTy subst ty1) (Type.substTy subst ty2) {- -********************************************************************************* -* * +********************************************************************** +* * The top-reaction Stage -* * -********************************************************************************* +* * +********************************************************************** -} topReactionsStage :: WorkItem -> TcS (StopOrContinue Ct) @@ -1716,6 +1737,12 @@ So the inner binding for ?x::Bool *overrides* the outer one. Hence a work-item Given overrides an inert-item Given. -} +{- ******************************************************************* +* * + Class lookup +* * +**********************************************************************-} + -- | Indicates if Instance met the Safe Haskell overlapping instances safety -- check. -- @@ -1733,116 +1760,36 @@ instance Outputable LookupInstResult where where ss = text $ if s then "[safe]" else "[unsafe]" -matchClassInst, match_class_inst - :: DynFlags -> InertSet -> Class -> [Type] -> CtLoc -> TcS LookupInstResult - +matchClassInst :: DynFlags -> InertSet -> Class -> [Type] -> CtLoc -> TcS LookupInstResult matchClassInst dflags inerts clas tys loc - = do { traceTcS "matchClassInst" $ vcat [ text "pred =" <+> ppr (mkClassPred clas tys) ] - ; res <- match_class_inst dflags inerts clas tys loc - ; traceTcS "matchClassInst result" $ ppr res - ; return res } - -- First check whether there is an in-scope Given that could -- match this constraint. In that case, do not use top-level -- instances. See Note [Instance and Given overlap] -match_class_inst dflags inerts clas tys loc | not (xopt Opt_IncoherentInstances dflags) , let matchable_givens = matchableGivens loc pred inerts , not (isEmptyBag matchable_givens) = do { traceTcS "Delaying instance application" $ - vcat [ text "Work item=" <+> pprType pred + vcat [ text "Work item=" <+> pprClassPred clas tys , text "Potential matching givens:" <+> ppr matchable_givens ] ; return NoInstance } where pred = mkClassPred clas tys -match_class_inst _ _ clas [ ty ] _ - | className clas == knownNatClassName - , Just n <- isNumLitTy ty = makeDict (EvNum n) - - | className clas == knownSymbolClassName - , Just s <- isStrLitTy ty = makeDict (EvStr s) +matchClassInst dflags _ clas tys loc + = do { traceTcS "matchClassInst" $ vcat [ text "pred =" <+> ppr (mkClassPred clas tys) ] + ; res <- match_class_inst dflags clas tys loc + ; traceTcS "matchClassInst result" $ ppr res + ; return res } +match_class_inst :: DynFlags -> Class -> [Type] -> CtLoc -> TcS LookupInstResult +match_class_inst dflags clas tys loc + | cls_name == knownNatClassName = matchKnownNat clas tys + | cls_name == knownSymbolClassName = matchKnownSymbol clas tys + | isCTupleClass clas = matchCTuple clas tys + | cls_name == typeableClassName = matchTypeable clas tys + | otherwise = matchInstEnv dflags clas tys loc where - {- This adds a coercion that will convert the literal into a dictionary - of the appropriate type. See Note [KnownNat & KnownSymbol and EvLit] - in TcEvidence. The coercion happens in 2 steps: - - Integer -> SNat n -- representation of literal to singleton - SNat n -> KnownNat n -- singleton to dictionary - - The process is mirrored for Symbols: - String -> SSymbol n - SSymbol n -> KnownSymbol n - -} - makeDict evLit - | Just (_, co_dict) <- tcInstNewTyCon_maybe (classTyCon clas) [ty] - -- co_dict :: KnownNat n ~ SNat n - , [ meth ] <- classMethods clas - , Just tcRep <- tyConAppTyCon_maybe -- SNat - $ funResultTy -- SNat n - $ dropForAlls -- KnownNat n => SNat n - $ idType meth -- forall n. KnownNat n => SNat n - , Just (_, co_rep) <- tcInstNewTyCon_maybe tcRep [ty] - -- SNat n ~ Integer - , let ev_tm = mkEvCast (EvLit evLit) (mkTcSymCo (mkTcTransCo co_dict co_rep)) - = return $ GenInst [] (\_ -> ev_tm) True - - | otherwise - = panicTcS (text "Unexpected evidence for" <+> ppr (className clas) - $$ vcat (map (ppr . idType) (classMethods clas))) - -match_class_inst _ _ clas ts _ - | isCTupleClass clas - , let data_con = tyConSingleDataCon (classTyCon clas) - tuple_ev = EvDFunApp (dataConWrapId data_con) ts - = return (GenInst ts tuple_ev True) - -- The dfun is the data constructor! - -match_class_inst _ _ clas [k,t] _ - | className clas == typeableClassName - = matchTypeableClass clas k t - -match_class_inst dflags _ clas tys loc - = do { instEnvs <- getInstEnvs - ; let safeOverlapCheck = safeHaskell dflags `elem` [Sf_Safe, Sf_Trustworthy] - (matches, unify, unsafeOverlaps) = lookupInstEnv True instEnvs clas tys - safeHaskFail = safeOverlapCheck && not (null unsafeOverlaps) - ; case (matches, unify, safeHaskFail) of - - -- Nothing matches - ([], _, _) - -> do { traceTcS "matchClass not matching" $ - vcat [ text "dict" <+> ppr pred ] - ; return NoInstance } - - -- A single match (& no safe haskell failure) - ([(ispec, inst_tys)], [], False) - -> do { let dfun_id = instanceDFunId ispec - ; traceTcS "matchClass success" $ - vcat [text "dict" <+> ppr pred, - text "witness" <+> ppr dfun_id - <+> ppr (idType dfun_id) ] - -- Record that this dfun is needed - ; match_one (null unsafeOverlaps) dfun_id inst_tys } - - -- More than one matches (or Safe Haskell fail!). Defer any - -- reactions of a multitude until we learn more about the reagent - (matches, _, _) - -> do { traceTcS "matchClass multiple matches, deferring choice" $ - vcat [text "dict" <+> ppr pred, - text "matches" <+> ppr matches] - ; return NoInstance } } - where - pred = mkClassPred clas tys - - match_one :: SafeOverlapping -> DFunId -> [DFunInstType] -> TcS LookupInstResult - -- See Note [DFunInstType: instantiating types] in InstEnv - match_one so dfun_id mb_inst_tys - = do { checkWellStagedDFun pred dfun_id loc - ; (tys, theta) <- instDFunType dfun_id mb_inst_tys - ; return $ GenInst theta (EvDFunApp dfun_id tys) so } - + cls_name = className clas {- Note [Instance and Given overlap] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1907,89 +1854,202 @@ Other notes: constraint solving. -} --- | Is the constraint for an implicit CallStack parameter? --- i.e. (IP "name" CallStack) -isCallStackIP :: CtLoc -> Class -> [Type] -> Maybe (EvTerm -> EvCallStack) -isCallStackIP loc cls tys - | cls == ipClass - , [_ip_name, ty] <- tys - , Just (tc, _) <- splitTyConApp_maybe ty - , tc `hasKey` callStackTyConKey - = occOrigin (ctLocOrigin loc) - | otherwise - = Nothing - where - locSpan = ctLocSpan loc - -- We only want to grab constraints that arose due to the use of an IP or a - -- function call. See Note [Overview of implicit CallStacks] - occOrigin (OccurrenceOf n) = Just (EvCsPushCall n locSpan) - occOrigin (IPOccOrigin n) = Just (EvCsTop ('?' `consFS` hsIPNameFS n) locSpan) - occOrigin _ = Nothing +{- ******************************************************************* +* * + Class lookup in the instance environment +* * +**********************************************************************-} --- | Assumes that we've checked that this is the 'Typeable' class, --- and it was applied to the correct argument. -matchTypeableClass :: Class -> Kind -> Type -> TcS LookupInstResult -matchTypeableClass clas k t +matchInstEnv :: DynFlags -> Class -> [Type] -> CtLoc -> TcS LookupInstResult +matchInstEnv dflags clas tys loc + = do { instEnvs <- getInstEnvs + ; let safeOverlapCheck = safeHaskell dflags `elem` [Sf_Safe, Sf_Trustworthy] + (matches, unify, unsafeOverlaps) = lookupInstEnv True instEnvs clas tys + safeHaskFail = safeOverlapCheck && not (null unsafeOverlaps) + ; case (matches, unify, safeHaskFail) of + + -- Nothing matches + ([], _, _) + -> do { traceTcS "matchClass not matching" $ + vcat [ text "dict" <+> ppr pred ] + ; return NoInstance } - -- See Note [No Typeable for qualified types] - | isForAllTy t = return NoInstance + -- A single match (& no safe haskell failure) + ([(ispec, inst_tys)], [], False) + -> do { let dfun_id = instanceDFunId ispec + ; traceTcS "matchClass success" $ + vcat [text "dict" <+> ppr pred, + text "witness" <+> ppr dfun_id + <+> ppr (idType dfun_id) ] + -- Record that this dfun is needed + ; match_one (null unsafeOverlaps) dfun_id inst_tys } - -- Is the type of the form `C => t`? - | isJust (tcSplitPredFunTy_maybe t) = return NoInstance + -- More than one matches (or Safe Haskell fail!). Defer any + -- reactions of a multitude until we learn more about the reagent + (matches, _, _) + -> do { traceTcS "matchClass multiple matches, deferring choice" $ + vcat [text "dict" <+> ppr pred, + text "matches" <+> ppr matches] + ; return NoInstance } } + where + pred = mkClassPred clas tys - | eqType k typeNatKind = doTyLit knownNatClassName - | eqType k typeSymbolKind = doTyLit knownSymbolClassName + match_one :: SafeOverlapping -> DFunId -> [DFunInstType] -> TcS LookupInstResult + -- See Note [DFunInstType: instantiating types] in InstEnv + match_one so dfun_id mb_inst_tys + = do { checkWellStagedDFun pred dfun_id loc + ; (tys, theta) <- instDFunType dfun_id mb_inst_tys + ; return $ GenInst theta (EvDFunApp dfun_id tys) so } - | Just (tc, ks) <- splitTyConApp_maybe t - , all isKind ks = doTyCon tc ks - | Just (f,kt) <- splitAppTy_maybe t = doTyApp f kt - | otherwise = return NoInstance +{- ******************************************************************** +* * + Class lookup for CTuples +* * +***********************************************************************-} +matchCTuple :: Class -> [Type] -> TcS LookupInstResult +matchCTuple clas tys -- (isCTupleClass clas) holds + = return (GenInst tys tuple_ev True) + -- The dfun *is* the data constructor! where - -- Representation for type constructor applied to some kinds - doTyCon tc ks = - case mapM kindRep ks of - Nothing -> return NoInstance - Just kReps -> - return $ GenInst [] (\_ -> EvTypeable (EvTypeableTyCon tc kReps) ) True - - {- Representation for an application of a type to a type-or-kind. - This may happen when the type expression starts with a type variable. - Example (ignoring kind parameter): - Typeable (f Int Char) --> - (Typeable (f Int), Typeable Char) --> - (Typeable f, Typeable Int, Typeable Char) --> (after some simp. steps) - Typeable f - -} - doTyApp f tk - | isKind tk - = return NoInstance -- We can't solve until we know the ctr. + data_con = tyConSingleDataCon (classTyCon clas) + tuple_ev = EvDFunApp (dataConWrapId data_con) tys + +{- ******************************************************************** +* * + Class lookup for Literals +* * +***********************************************************************-} + +matchKnownNat :: Class -> [Type] -> TcS LookupInstResult +matchKnownNat clas [ty] -- clas = KnownNat + | Just n <- isNumLitTy ty = makeLitDict clas ty (EvNum n) +matchKnownNat _ _ = return NoInstance + +matchKnownSymbol :: Class -> [Type] -> TcS LookupInstResult +matchKnownSymbol clas [ty] -- clas = KnownSymbol + | Just n <- isStrLitTy ty = makeLitDict clas ty (EvStr n) +matchKnownSymbol _ _ = return NoInstance + + +makeLitDict :: Class -> Type -> EvLit -> TcS LookupInstResult +-- makeLitDict adds a coercion that will convert the literal into a dictionary +-- of the appropriate type. See Note [KnownNat & KnownSymbol and EvLit] +-- in TcEvidence. The coercion happens in 2 steps: +-- +-- Integer -> SNat n -- representation of literal to singleton +-- SNat n -> KnownNat n -- singleton to dictionary +-- +-- The process is mirrored for Symbols: +-- String -> SSymbol n +-- SSymbol n -> KnownSymbol n -} +makeLitDict clas ty evLit + | Just (_, co_dict) <- tcInstNewTyCon_maybe (classTyCon clas) [ty] + -- co_dict :: KnownNat n ~ SNat n + , [ meth ] <- classMethods clas + , Just tcRep <- tyConAppTyCon_maybe -- SNat + $ funResultTy -- SNat n + $ dropForAlls -- KnownNat n => SNat n + $ idType meth -- forall n. KnownNat n => SNat n + , Just (_, co_rep) <- tcInstNewTyCon_maybe tcRep [ty] + -- SNat n ~ Integer + , let ev_tm = mkEvCast (EvLit evLit) (mkTcSymCo (mkTcTransCo co_dict co_rep)) + = return $ GenInst [] (\_ -> ev_tm) True + | otherwise - = return $ GenInst [mk_typeable_pred f, mk_typeable_pred tk] - (\[t1,t2] -> EvTypeable $ EvTypeableTyApp (EvId t1,f) (EvId t2,tk)) - True - - -- Representation for concrete kinds. We just use the kind itself, - -- but first check to make sure that it is "simple" (i.e., made entirely - -- out of kind constructors). - kindRep ki = do (_,ks) <- splitTyConApp_maybe ki - mapM_ kindRep ks - return ki - - -- Emit a `Typeable` constraint for the given type. - mk_typeable_pred ty = mkClassPred clas [ typeKind ty, ty ] - - -- Given KnownNat / KnownSymbol, generate appropriate sub-goal - -- and make evidence for a type-level literal. - doTyLit c = do clas <- tcLookupClass c - let p = mkClassPred clas [ t ] - return $ GenInst [p] (\[i] -> EvTypeable - $ EvTypeableTyLit (EvId i,t)) True - -{- Note [No Typeable for polytype or for constraints] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + = panicTcS (text "Unexpected evidence for" <+> ppr (className clas) + $$ vcat (map (ppr . idType) (classMethods clas))) + + +{- ******************************************************************** +* * + Class lookup for Typeable +* * +***********************************************************************-} + +-- | Assumes that we've checked that this is the 'Typeable' class, +-- and it was applied to the correct argument. +matchTypeable :: Class -> [Type] -> TcS LookupInstResult +matchTypeable clas [k,t] -- clas = Typeable + -- For the first two cases, See Note [No Typeable for polytypes or qualified types] + | isForAllTy k = return NoInstance -- Polytype + | isJust (tcSplitPredFunTy_maybe t) = return NoInstance -- Qualified type + + -- Now cases that do work + | k `eqType` typeNatKind = doTyLit knownNatClassName t + | k `eqType` typeSymbolKind = doTyLit knownSymbolClassName t + | Just (_, ks) <- splitTyConApp_maybe t -- See Note [Typeable (T a b c)] + , all isGroundKind ks = doTyConApp t + | Just (f,kt) <- splitAppTy_maybe t = doTyApp clas t f kt + +matchTypeable _ _ = return NoInstance + +doTyConApp :: Type -> TcS LookupInstResult +-- Representation for type constructor applied to some (ground) kinds +doTyConApp ty = return $ GenInst [] (\_ -> EvTypeable ty EvTypeableTyCon) True + +-- Representation for concrete kinds. We just use the kind itself, +-- but first check to make sure that it is "simple" (i.e., made entirely +-- out of kind constructors). +isGroundKind :: KindOrType -> Bool +-- Return True if (a) k is a kind and (b) it is a ground kind +isGroundKind k + = isKind k && is_ground k + where + is_ground k | Just (_, ks) <- splitTyConApp_maybe k + = all is_ground ks + | otherwise + = False + +doTyApp :: Class -> Type -> Type -> KindOrType -> TcS LookupInstResult +-- Representation for an application of a type to a type-or-kind. +-- This may happen when the type expression starts with a type variable. +-- Example (ignoring kind parameter): +-- Typeable (f Int Char) --> +-- (Typeable (f Int), Typeable Char) --> +-- (Typeable f, Typeable Int, Typeable Char) --> (after some simp. steps) +-- Typeable f +doTyApp clas ty f tk + | isKind tk + = return NoInstance -- We can't solve until we know the ctr. + | otherwise + = return $ GenInst [mk_typeable_pred clas f, mk_typeable_pred clas tk] + (\[t1,t2] -> EvTypeable ty $ EvTypeableTyApp (EvId t1) (EvId t2)) + True + +-- Emit a `Typeable` constraint for the given type. +mk_typeable_pred :: Class -> Type -> PredType +mk_typeable_pred clas ty = mkClassPred clas [ typeKind ty, ty ] + + -- Typeable is implied by KnownNat/KnownSymbol. In the case of a type literal + -- we generate a sub-goal for the appropriate class. See #10348 for what + -- happens when we fail to do this. +doTyLit :: Name -> Type -> TcS LookupInstResult +doTyLit kc t = do { kc_clas <- tcLookupClass kc + ; let kc_pred = mkClassPred kc_clas [ t ] + mk_ev [ev] = EvTypeable t $ EvTypeableTyLit $ EvId ev + mk_ev _ = panic "doTyLit" + ; return (GenInst [kc_pred] mk_ev True) } + +{- Note [Typeable (T a b c)] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For type applications we always decompose using binary application, +vai doTyApp, until we get to a *kind* instantiation. Exmaple + Proxy :: forall k. k -> * + +To solve Typeable (Proxy (* -> *) Maybe) we + - First decompose with doTyApp, + to get (Typeable (Proxy (* -> *))) and Typeable Maybe + - Then sovle (Typeable (Proxy (* -> *))) with doTyConApp + +If we attempt to short-cut by solving it all at once, via +doTyCOnAPp + + +Note [No Typeable for polytypes or qualified types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We do not support impredicative typeable, such as Typeable (forall a. a->a) Typeable (Eq a => a -> a) @@ -2003,9 +2063,9 @@ a TypeRep for them. For qualified but not polymorphic types, like * We don't need a TypeRep for these things. TypeReps are for monotypes only. - * Perhaps we could treat `=>` as another type constructor for `Typeable` - purposes, and thus support things like `Eq Int => Int`, however, - at the current state of affairs this would be an odd exception as - no other class works with impredicative types. - For now we leave it off, until we have a better story for impredicativity. + * Perhaps we could treat `=>` as another type constructor for `Typeable` + purposes, and thus support things like `Eq Int => Int`, however, + at the current state of affairs this would be an odd exception as + no other class works with impredicative types. + For now we leave it off, until we have a better story for impredicativity. -} diff --git a/compiler/typecheck/TcPatSyn.hs b/compiler/typecheck/TcPatSyn.hs index f1db883509..5c55fcef2f 100644 --- a/compiler/typecheck/TcPatSyn.hs +++ b/compiler/typecheck/TcPatSyn.hs @@ -314,7 +314,7 @@ tcPatSynMatcher (L loc name) lpat ; let matcher_tau = mkFunTys [pat_ty, cont_ty, fail_ty] res_ty matcher_sigma = mkSigmaTy (res_tv:univ_tvs) req_theta matcher_tau - matcher_id = mkExportedLocalId VanillaId matcher_name matcher_sigma + matcher_id = mkExportedLocalId PatSynId matcher_name matcher_sigma -- See Note [Exported LocalIds] in Id cont_dicts = map nlHsVar prov_dicts diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs index 45c25e4942..4e6b1d3db7 100644 --- a/compiler/typecheck/TcRnDriver.hs +++ b/compiler/typecheck/TcRnDriver.hs @@ -68,6 +68,7 @@ import TcMType import MkIface import TcSimplify import TcTyClsDecls +import TcTypeable( mkModIdBindings ) import LoadIface import TidyPgm ( mkBootModDetailsTc ) import RnNames @@ -460,8 +461,14 @@ tcRnSrcDecls :: Bool -- False => no 'module M(..) where' header at all -- Returns the variables free in the decls -- Reason: solely to report unused imports and bindings tcRnSrcDecls explicit_mod_hdr exports decls - = do { -- Do all the declarations - ((tcg_env, tcl_env), lie) <- captureConstraints $ + = do { -- Create a binding for $trModule + -- Do this before processing any data type declarations, + -- which need tcg_tr_module to be initialised + ; tcg_env <- mkModIdBindings + + -- Do all the declarations + ; ((tcg_env, tcl_env), lie) <- setGblEnv tcg_env $ + captureConstraints $ do { (tcg_env, tcl_env) <- tc_rn_src_decls decls ; ; tcg_env <- setEnvs (tcg_env, tcl_env) $ checkMain explicit_mod_hdr @@ -961,12 +968,13 @@ checkBootTyCon tc1 tc2 | Just fam_flav1 <- famTyConFlav_maybe tc1 , Just fam_flav2 <- famTyConFlav_maybe tc2 = ASSERT(tc1 == tc2) - let eqFamFlav OpenSynFamilyTyCon OpenSynFamilyTyCon = True + let eqFamFlav OpenSynFamilyTyCon OpenSynFamilyTyCon = True + eqFamFlav (DataFamilyTyCon {}) (DataFamilyTyCon {}) = True eqFamFlav AbstractClosedSynFamilyTyCon (ClosedSynFamilyTyCon {}) = True eqFamFlav (ClosedSynFamilyTyCon {}) AbstractClosedSynFamilyTyCon = True eqFamFlav (ClosedSynFamilyTyCon ax1) (ClosedSynFamilyTyCon ax2) = eqClosedFamilyAx ax1 ax2 - eqFamFlav (BuiltInSynFamTyCon _) (BuiltInSynFamTyCon _) = tc1 == tc2 + eqFamFlav (BuiltInSynFamTyCon {}) (BuiltInSynFamTyCon {}) = tc1 == tc2 eqFamFlav _ _ = False injInfo1 = familyTyConInjectivityInfo tc1 injInfo2 = familyTyConInjectivityInfo tc2 @@ -998,7 +1006,6 @@ checkBootTyCon tc1 tc2 (text "The natures of the declarations for" <+> quotes (ppr tc) <+> text "are different") | otherwise = checkSuccess - eqAlgRhs _ DataFamilyTyCon{} DataFamilyTyCon{} = checkSuccess eqAlgRhs _ tc1@DataTyCon{} tc2@DataTyCon{} = checkListBy eqCon (data_cons tc1) (data_cons tc2) (text "constructors") eqAlgRhs _ tc1@NewTyCon{} tc2@NewTyCon{} = @@ -2063,7 +2070,7 @@ pprTcGblEnv (TcGblEnv { tcg_type_env = type_env, tcg_rules = rules, tcg_vects = vects, tcg_imports = imports }) - = vcat [ ppr_types insts type_env + = vcat [ ppr_types type_env , ppr_tycons fam_insts type_env , ppr_insts insts , ppr_fam_insts fam_insts @@ -2080,20 +2087,19 @@ pprTcGblEnv (TcGblEnv { tcg_type_env = type_env, `thenCmp` (is_boot1 `compare` is_boot2) -ppr_types :: [ClsInst] -> TypeEnv -> SDoc -ppr_types insts type_env +ppr_types :: TypeEnv -> SDoc +ppr_types type_env = text "TYPE SIGNATURES" $$ nest 2 (ppr_sigs ids) where - dfun_ids = map instanceDFunId insts ids = [id | id <- typeEnvIds type_env, want_sig id] - want_sig id | opt_PprStyle_Debug = True - | otherwise = isLocalId id && - isExternalName (idName id) && - not (id `elem` dfun_ids) - -- isLocalId ignores data constructors, records selectors etc. - -- The isExternalName ignores local dictionary and method bindings - -- that the type checker has invented. Top-level user-defined things - -- have External names. + want_sig id | opt_PprStyle_Debug + = True + | otherwise + = isExternalName (idName id) && + (case idDetails id of { VanillaId -> True; _ -> False }) + -- Looking for VanillaId ignores data constructors, records selectors etc. + -- The isExternalName ignores local evidence bindings that the type checker + -- has invented. Top-level user-defined things have External names. ppr_tycons :: [FamInst] -> TypeEnv -> SDoc ppr_tycons fam_insts type_env diff --git a/compiler/typecheck/TcRnMonad.hs b/compiler/typecheck/TcRnMonad.hs index 601b030f74..19055647bd 100644 --- a/compiler/typecheck/TcRnMonad.hs +++ b/compiler/typecheck/TcRnMonad.hs @@ -144,7 +144,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this tcg_rn_imports = [], tcg_rn_exports = maybe_rn_syntax [], tcg_rn_decls = maybe_rn_syntax emptyRnGroup, - + tcg_tr_module = Nothing, tcg_binds = emptyLHsBinds, tcg_imp_specs = [], tcg_sigs = emptyNameSet, diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs index c046704643..7375a8c66e 100644 --- a/compiler/typecheck/TcRnTypes.hs +++ b/compiler/typecheck/TcRnTypes.hs @@ -477,6 +477,9 @@ data TcGblEnv -- Things defined in this module, or (in GHCi) -- in the declarations for a single GHCi command. -- For the latter, see Note [The interactive package] in HscTypes + tcg_tr_module :: Maybe Id, -- Id for $trModule :: GHC.Types.Module + -- for which every module has a top-level defn + -- except in GHCi in which case we have Nothing tcg_binds :: LHsBinds Id, -- Value bindings in this module tcg_sigs :: NameSet, -- ...Top-level names that *lack* a signature tcg_imp_specs :: [LTcSpecPrag], -- ...SPECIALISE prags for imported Ids @@ -898,7 +901,7 @@ pprPECategory RecDataConPE = ptext (sLit "Data constructor") pprPECategory NoDataKinds = ptext (sLit "Data constructor") {- Note [Bindings with closed types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider f x = let g ys = map not ys @@ -915,6 +918,8 @@ iff a) all its free variables are imported, or are let-bound with closed types b) generalisation is not restricted by the monomorphism restriction +Invariant: a closed variable has no free type variables in its type. + Under OutsideIn we are free to generalise a closed let-binding. This is an extension compared to the JFP paper on OutsideIn, which used "top-level" as a proxy for "closed". (It's not a good proxy diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs index 34b2585b4d..78f1d35e5c 100644 --- a/compiler/typecheck/TcTyClsDecls.hs +++ b/compiler/typecheck/TcTyClsDecls.hs @@ -16,7 +16,7 @@ module TcTyClsDecls ( kcDataDefn, tcConDecls, dataDeclChecks, checkValidTyCon, tcFamTyPats, tcTyFamInstEqn, famTyConShape, tcAddTyFamInstCtxt, tcMkDataFamInstCtxt, tcAddDataFamInstCtxt, - wrongKindOfFamily, dataConCtxt, badDataConTyCon + wrongKindOfFamily, dataConCtxt, badDataConTyCon, mkOneRecordSelector ) where #include "HsVersions.h" @@ -28,7 +28,6 @@ import TcRnMonad import TcEnv import TcValidity import TcHsSyn -import TcBinds( tcRecSelBinds ) import TcTyDecls import TcClassDcl import TcHsType @@ -44,6 +43,7 @@ import Class import CoAxiom import TyCon import DataCon +import ConLike import Id import IdInfo import Var @@ -53,6 +53,7 @@ import Module import Name import NameSet import NameEnv +import RdrName import RnEnv import Outputable import Maybes @@ -63,8 +64,10 @@ import ListSetOps import Digraph import DynFlags import FastString +import Unique ( mkBuiltinUnique ) import BasicTypes +import Bag import Control.Monad import Data.List @@ -167,16 +170,7 @@ tcTyClGroup tyclds -- Step 4: Add the implicit things; -- we want them in the environment because -- they may be mentioned in interface files - ; tcExtendGlobalValEnv (mkDefaultMethodIds tyclss) $ - tcAddImplicits tyclss } } - -tcAddImplicits :: [TyThing] -> TcM TcGblEnv -tcAddImplicits tyclss - = tcExtendGlobalEnvImplicit implicit_things $ - tcRecSelBinds rec_sel_binds - where - implicit_things = concatMap implicitTyThings tyclss - rec_sel_binds = mkRecSelBinds tyclss + ; tcAddImplicits tyclss } } zipRecTyClss :: [(Name, Kind)] -> [TyThing] -- Knot-tied diff --git a/compiler/typecheck/TcTyDecls.hs b/compiler/typecheck/TcTyDecls.hs index 0da0cb1382..bba808063c 100644 --- a/compiler/typecheck/TcTyDecls.hs +++ b/compiler/typecheck/TcTyDecls.hs @@ -14,28 +14,33 @@ files for imported data types. module TcTyDecls( calcRecFlags, RecTyInfo(..), calcSynCycles, calcClassCycles, + + -- * Roles RoleAnnots, extractRoleAnnots, emptyRoleAnnots, lookupRoleAnnots, - mkDefaultMethodIds, mkRecSelBinds, mkOneRecordSelector + + -- * Implicits + tcAddImplicits ) where #include "HsVersions.h" import TcRnMonad import TcEnv +import TcTypeable( mkTypeableBinds ) +import TcBinds( tcValBinds, addTypecheckedBinds ) +import TypeRep( Type(..) ) import TcType import TysWiredIn( unitTy ) import MkCore( rEC_SEL_ERROR_ID ) -import TypeRep import HsSyn import Class import Type +import HscTypes import TyCon -import ConLike import DataCon import Name import NameEnv import RdrName ( mkVarUnqual ) -import Var ( tyVarKind ) import Id import IdInfo import VarEnv @@ -379,7 +384,7 @@ calcRecFlags boot_details is_boot mrole_env tyclss -- Recursion of newtypes/data types can happen via -- the class TyCon, so tyclss includes the class tycons - is_promotable = all (isPromotableTyCon rec_tycon_names) all_tycons + is_promotable = all (computeTyConPromotability rec_tycon_names) all_tycons roles = inferRoles is_boot mrole_env all_tycons @@ -473,70 +478,6 @@ findLoopBreakers deps {- ************************************************************************ * * - Promotion calculation -* * -************************************************************************ - -See Note [Checking whether a group is promotable] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We only want to promote a TyCon if all its data constructors -are promotable; it'd be very odd to promote some but not others. - -But the data constructors may mention this or other TyCons. - -So we treat the recursive uses as all OK (ie promotable) and -do one pass to check that each TyCon is promotable. - -Currently type synonyms are not promotable, though that -could change. --} - -isPromotableTyCon :: NameSet -> TyCon -> Bool -isPromotableTyCon rec_tycons tc - = isAlgTyCon tc -- Only algebraic; not even synonyms - -- (we could reconsider the latter) - && ok_kind (tyConKind tc) - && case algTyConRhs tc of - DataTyCon { data_cons = cs } -> all ok_con cs - NewTyCon { data_con = c } -> ok_con c - AbstractTyCon {} -> False - DataFamilyTyCon {} -> False - TupleTyCon { tup_sort = sort } -> case sort of - BoxedTuple -> True - UnboxedTuple -> False - ConstraintTuple -> False - where - ok_kind kind = all isLiftedTypeKind args && isLiftedTypeKind res - where -- Checks for * -> ... -> * -> * - (args, res) = splitKindFunTys kind - - -- See Note [Promoted data constructors] in TyCon - ok_con con = all (isLiftedTypeKind . tyVarKind) ex_tvs - && null eq_spec -- No constraints - && null theta - && all (isPromotableType rec_tycons) orig_arg_tys - where - (_, ex_tvs, eq_spec, theta, orig_arg_tys, _) = dataConFullSig con - - -isPromotableType :: NameSet -> Type -> Bool --- Must line up with DataCon.promoteType --- But the function lives here because we must treat the --- *recursive* tycons as promotable -isPromotableType rec_tcs con_arg_ty - = go con_arg_ty - where - go (TyConApp tc tys) = tys `lengthIs` tyConArity tc - && (tyConName tc `elemNameSet` rec_tcs - || isJust (promotableTyCon_maybe tc)) - && all go tys - go (FunTy arg res) = go arg && go res - go (TyVarTy {}) = True - go _ = False - -{- -************************************************************************ -* * Role annotations * * ************************************************************************ @@ -859,6 +800,27 @@ updateRoleEnv name n role RIS { role_env = role_env', update = True } else state ) + +{- ********************************************************************* +* * + Building implicits +* * +********************************************************************* -} + +tcAddImplicits :: [TyThing] -> TcM TcGblEnv +tcAddImplicits tyclss + = discardWarnings $ + tcExtendGlobalEnvImplicit implicit_things $ + tcExtendGlobalValEnv def_meth_ids $ + do { (rec_sel_ids, rec_sel_binds) <- mkRecSelBinds tycons + ; (typeable_ids, typeable_binds) <- mkTypeableBinds tycons + ; gbl_env <- tcExtendGlobalValEnv (rec_sel_ids ++ typeable_ids) getGblEnv + ; return (gbl_env `addTypecheckedBinds` (rec_sel_binds ++ typeable_binds)) } + where + implicit_things = concatMap implicitTyThings tyclss + tycons = [tc | ATyCon tc <- tyclss] + def_meth_ids = mkDefaultMethodIds tyclss + {- ************************************************************************ * * @@ -893,53 +855,49 @@ must bring the default method Ids into scope first (so they can be seen when typechecking the [d| .. |] quote, and typecheck them later. -} -mkRecSelBinds :: [TyThing] -> HsValBinds Name --- NB We produce *un-typechecked* bindings, rather like 'deriving' --- This makes life easier, because the later type checking will add --- all necessary type abstractions and applications +mkRecSelBinds :: [TyCon] -> TcM ([Id], [LHsBinds Id]) mkRecSelBinds tycons - = ValBindsOut [(NonRecursive, b) | b <- binds] sigs - where - (sigs, binds) = unzip rec_sels - rec_sels = map mkRecSelBind [ (tc,fld) - | ATyCon tc <- tycons - , fld <- tyConFieldLabels tc ] - - -mkRecSelBind :: (TyCon, FieldLabel) -> (LSig Name, LHsBinds Name) + = do { -- We generate *un-typechecked* bindings in mkRecSelBind, and + -- then typecheck them, rather like 'deriving'. This makes life + -- easier, because the later type checking will add all necessary + -- type abstractions and applications + + let sel_binds :: [(RecFlag, LHsBinds Name)] + sel_sigs :: [LSig Name] + (sel_sigs, sel_binds) + = mapAndUnzip mkRecSelBind [ (tc,fld) + | tc <- tycons + , fld <- tyConFieldLabels tc ] + sel_ids = [sel_id | L _ (IdSig sel_id) <- sel_sigs] + ; (sel_binds, _) <- tcValBinds TopLevel sel_binds sel_sigs (return ()) + ; return (sel_ids, map snd sel_binds) } + +mkRecSelBind :: (TyCon, FieldLabel) -> (LSig Name, (RecFlag, LHsBinds Name)) mkRecSelBind (tycon, fl) - = mkOneRecordSelector all_cons (RecSelData tycon) fl - where - all_cons = map RealDataCon (tyConDataCons tycon) - -mkOneRecordSelector :: [ConLike] -> RecSelParent -> FieldLabel - -> (LSig Name, LHsBinds Name) -mkOneRecordSelector all_cons idDetails fl = - (L loc (IdSig sel_id), unitBag (L loc sel_bind)) + = (L loc (IdSig sel_id), (NonRecursive, unitBag (L loc sel_bind))) where loc = getSrcSpan sel_name + sel_id = mkExportedLocalId rec_details sel_name sel_ty lbl = flLabel fl sel_name = flSelector fl - - sel_id = mkExportedLocalId rec_details sel_name sel_ty - rec_details = RecSelId { sel_tycon = idDetails, sel_naughty = is_naughty } + rec_details = RecSelId { sel_tycon = tycon, sel_naughty = is_naughty } -- Find a representative constructor, con1 - - cons_w_field = conLikesWithFields all_cons [lbl] + all_cons = tyConDataCons tycon + cons_w_field = tyConDataConsWithFields tycon [lbl] con1 = ASSERT( not (null cons_w_field) ) head cons_w_field + -- Selector type; Note [Polymorphic selectors] - field_ty = conLikeFieldType con1 lbl + field_ty = dataConFieldType con1 lbl + data_ty = dataConOrigResTy con1 data_tvs = tyVarsOfType data_ty is_naughty = not (tyVarsOfType field_ty `subVarSet` data_tvs) (field_tvs, field_theta, field_tau) = tcSplitSigmaTy field_ty sel_ty | is_naughty = unitTy -- See Note [Naughty record selectors] | otherwise = mkForAllTys (varSetElemsKvsFirst $ data_tvs `extendVarSetList` field_tvs) $ - mkPhiTy (conLikeStupidTheta con1) $ -- Urgh! + mkPhiTy (dataConStupidTheta con1) $ -- Urgh! mkPhiTy field_theta $ -- Urgh! - -- req_theta is empty for normal DataCon - mkPhiTy req_theta $ mkFunTy data_ty field_tau -- Make the binding: sel (C2 { fld = x }) = x @@ -976,14 +934,8 @@ mkOneRecordSelector all_cons idDetails fl = -- data instance T Int a where -- A :: { fld :: Int } -> T Int Bool -- B :: { fld :: Int } -> T Int Char - dealt_with :: ConLike -> Bool - dealt_with (PatSynCon _) = False -- We can't predict overlap - dealt_with con@(RealDataCon dc) = - con `elem` cons_w_field || dataConCannotMatch inst_tys dc - - (univ_tvs, _, eq_spec, _, req_theta, _, data_ty) = conLikeFullSig con1 - - inst_tys = substTyVars (mkTopTvSubst eq_spec) univ_tvs + dealt_with con = con `elem` cons_w_field || dataConCannotMatch inst_tys con + inst_tys = substTyVars (mkTopTvSubst (dataConEqSpec con1)) (dataConUnivTyVars con1) unit_rhs = mkLHsTupleExpr [] msg_lit = HsStringPrim "" (fastStringToByteString lbl) diff --git a/compiler/typecheck/TcTypeNats.hs b/compiler/typecheck/TcTypeNats.hs index 1f31d5666a..e64f43a9ba 100644 --- a/compiler/typecheck/TcTypeNats.hs +++ b/compiler/typecheck/TcTypeNats.hs @@ -16,7 +16,7 @@ import Type import Pair import TcType ( TcType, tcEqType ) import TyCon ( TyCon, FamTyConFlav(..), mkFamilyTyCon - , Injectivity(..), TyConParent(..) ) + , Injectivity(..) ) import Coercion ( Role(..) ) import TcRnTypes ( Xi ) import CoAxiom ( CoAxiomRule(..), BuiltInSynFamily(..) ) @@ -45,7 +45,7 @@ import qualified Data.Map as Map import Data.Maybe ( isJust ) {------------------------------------------------------------------------------- -Built-in type constructors for functions on type-lelve nats +Built-in type constructors for functions on type-level nats -} typeNatTyCons :: [TyCon] @@ -110,7 +110,7 @@ typeNatLeqTyCon = (mkTemplateTyVars [ typeNatKind, typeNatKind ]) Nothing (BuiltInSynFamTyCon ops) - NoParentTyCon + Nothing NotInjective where @@ -129,7 +129,7 @@ typeNatCmpTyCon = (mkTemplateTyVars [ typeNatKind, typeNatKind ]) Nothing (BuiltInSynFamTyCon ops) - NoParentTyCon + Nothing NotInjective where @@ -148,7 +148,7 @@ typeSymbolCmpTyCon = (mkTemplateTyVars [ typeSymbolKind, typeSymbolKind ]) Nothing (BuiltInSynFamTyCon ops) - NoParentTyCon + Nothing NotInjective where @@ -172,7 +172,7 @@ mkTypeNatFunTyCon2 op tcb = (mkTemplateTyVars [ typeNatKind, typeNatKind ]) Nothing (BuiltInSynFamTyCon tcb) - NoParentTyCon + Nothing NotInjective diff --git a/compiler/typecheck/TcTypeable.hs b/compiler/typecheck/TcTypeable.hs new file mode 100644 index 0000000000..f015eec79f --- /dev/null +++ b/compiler/typecheck/TcTypeable.hs @@ -0,0 +1,206 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1999 +-} + +module TcTypeable( + mkTypeableBinds, mkModIdBindings + ) where + + +import TcBinds( addTypecheckedBinds ) +import IfaceEnv( newGlobalBinder ) +import TcEnv +import TcRnMonad +import PrelNames( gHC_TYPES, trModuleDataConName, trTyConDataConName, trNameSDataConName ) +import Id +import IdInfo( IdDetails(..) ) +import Type +import TyCon +import DataCon +import Name( getOccName ) +import OccName +import Module +import HsSyn +import DynFlags +import Bag +import Fingerprint(Fingerprint(..), fingerprintString) +import Outputable +import Data.Word( Word64 ) +import FastString ( FastString, mkFastString ) + +{- Note [Grand plan for Typeable] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The overall plan is this: + +1. Generate a binding for each module p:M + (done in TcTypeable by mkModIdBindings) + M.$trModule :: GHC.Types.Module + M.$trModule = Module "p" "M" + ("tr" is short for "type representation"; see GHC.Types) + + We might want to add the filename too. + This can be used for the lightweight stack-tracing stuff too + + Record the Name M.$trModule in the tcg_tr_module field of TcGblEnv + +2. Generate a binding for every data type declaration T in module M, + M.$tcT :: GHC.Types.TyCon + M.$tcT = TyCon ...fingerprint info... + $trModule + "T" + We define (in TyCon) + type TyConRepName = Name + to use for these M.$tcT "tycon rep names". + +3. Record the TyConRepName in T's TyCon, including for promoted + data and type constructors, and kinds like * and #. + + The TyConRepNaem is not an "implicit Id". It's more like a record + selector: the TyCon knows its name but you have to go to the + interface file to find its type, value, etc + +4. Solve Typeable costraints. This is done by a custom Typeable solver, + currently in TcInteract, that use M.$tcT so solve (Typeable T). + +There are many wrinkles: + +* Since we generate $tcT for every data type T, the types TyCon and + Module must be available right from the start; so they are defined + in ghc-prim:GHC.Types + +* To save space and reduce dependencies, we need use quite low-level + representations for TyCon and Module. See GHC.Types + Note [Runtime representation of modules and tycons] + +* It's hard to generate the TyCon/Module bindings when the types TyCon + and Module aren't yet available; i.e. when compiling GHC.Types + itself. So we *don't* generate them for types in GHC.Types. Instead + we write them by hand in base:GHC.Typeable.Internal. + +* To be able to define them by hand, they need to have user-writable + names, thus + tcBool not $tcBool for the type-rep TyCon for Bool + Hence PrelNames.tyConRepModOcc + +* Moreover for type constructors with special syntax, they need to have + completely hand-crafted names + lists tcList not $tc[] for the type-rep TyCon for [] + kinds tcLiftedKind not $tc* for the type-rep TyCon for * + Hence PrelNames.mkSpecialTyConRepName, which takes an extra FastString + to use for the TyConRepName + +* Since listTyCon, boolTyCon etd are wired in, their TyConRepNames must + be wired in as well. For these wired-in TyCons we generate the + TyConRepName's unique from that of the TyCon; see + Unique.tyConRepNameUnique, dataConRepNameUnique. + +-} + +{- ********************************************************************* +* * + Building top-level binding for $trModule +* * +********************************************************************* -} + +mkModIdBindings :: TcM TcGblEnv +mkModIdBindings + = do { mod <- getModule + ; if mod == gHC_TYPES + then getGblEnv -- Do not generate bindings for modules in GHC.Types + else + do { loc <- getSrcSpanM + ; tr_mod_dc <- tcLookupDataCon trModuleDataConName + ; tr_name_dc <- tcLookupDataCon trNameSDataConName + ; mod_nm <- newGlobalBinder mod (mkVarOcc "$trModule") loc + ; let mod_id = mkExportedLocalId ReflectionId mod_nm + (mkTyConApp (dataConTyCon tr_mod_dc) []) + mod_bind = mkVarBind mod_id mod_rhs + mod_rhs = nlHsApps (dataConWrapId tr_mod_dc) + [ trNameLit tr_name_dc (unitIdFS (moduleUnitId mod)) + , trNameLit tr_name_dc (moduleNameFS (moduleName mod)) ] + + ; tcg_env <- tcExtendGlobalValEnv [mod_id] getGblEnv + ; return (tcg_env { tcg_tr_module = Just mod_id } + `addTypecheckedBinds` [unitBag mod_bind]) } } + + +{- ********************************************************************* +* * + Building type-representation bindings +* * +********************************************************************* -} + +mkTypeableBinds :: [TyCon] -> TcM ([Id], [LHsBinds Id]) +mkTypeableBinds tycons + = do { dflags <- getDynFlags + ; gbl_env <- getGblEnv + ; mod <- getModule + ; if mod == gHC_TYPES + then return ([], []) -- Do not generate bindings for modules in GHC.Types + else + do { tr_datacon <- tcLookupDataCon trTyConDataConName + ; trn_datacon <- tcLookupDataCon trNameSDataConName + ; let pkg_str = unitIdString (moduleUnitId mod) + mod_str = moduleNameString (moduleName mod) + mod_expr = case tcg_tr_module gbl_env of -- Should be set by now + Just mod_id -> nlHsVar mod_id + Nothing -> pprPanic "tcMkTypeableBinds" (ppr tycons) + stuff = (dflags, mod_expr, pkg_str, mod_str, tr_datacon, trn_datacon) + tc_binds = map (mk_typeable_binds stuff) tycons + tycon_rep_ids = foldr ((++) . collectHsBindsBinders) [] tc_binds + ; return (tycon_rep_ids, tc_binds) } } + +trNameLit :: DataCon -> FastString -> LHsExpr Id +trNameLit tr_name_dc fs + = nlHsApps (dataConWrapId tr_name_dc) [nlHsLit (mkHsStringPrimLit fs)] + +type TypeableStuff + = ( DynFlags + , LHsExpr Id -- Of type GHC.Types.Module + , String -- Package name + , String -- Module name + , DataCon -- Data constructor GHC.Types.TyCon + , DataCon ) -- Data constructor GHC.Types.TrNameS + +mk_typeable_binds :: TypeableStuff -> TyCon -> LHsBinds Id +mk_typeable_binds stuff tycon + = mkTyConRepBinds stuff tycon + `unionBags` + unionManyBags (map (mkTypeableDataConBinds stuff) (tyConDataCons tycon)) + +mkTyConRepBinds :: TypeableStuff -> TyCon -> LHsBinds Id +mkTyConRepBinds (dflags, mod_expr, pkg_str, mod_str, tr_datacon, trn_datacon) tycon + = case tyConRepName_maybe tycon of + Just rep_name -> unitBag (mkVarBind rep_id rep_rhs) + where + rep_id = mkExportedLocalId ReflectionId rep_name (mkTyConApp tr_tycon []) + _ -> emptyBag + where + tr_tycon = dataConTyCon tr_datacon + rep_rhs = nlHsApps (dataConWrapId tr_datacon) + [ nlHsLit (word64 high), nlHsLit (word64 low) + , mod_expr + , trNameLit trn_datacon (mkFastString tycon_str) ] + + tycon_str = add_tick (occNameString (getOccName tycon)) + add_tick s | isPromotedDataCon tycon = '\'' : s + | isPromotedTyCon tycon = '\'' : s + | otherwise = s + + hashThis :: String + hashThis = unwords [pkg_str, mod_str, tycon_str] + + Fingerprint high low + | gopt Opt_SuppressUniques dflags = Fingerprint 0 0 + | otherwise = fingerprintString hashThis + + word64 :: Word64 -> HsLit + word64 | wORD_SIZE dflags == 4 = \n -> HsWord64Prim (show n) (toInteger n) + | otherwise = \n -> HsWordPrim (show n) (toInteger n) + +mkTypeableDataConBinds :: TypeableStuff -> DataCon -> LHsBinds Id +mkTypeableDataConBinds stuff dc + = case promoteDataCon_maybe dc of + Promoted tc -> mkTyConRepBinds stuff tc + NotPromoted -> emptyBag diff --git a/compiler/types/TyCon.hs b/compiler/types/TyCon.hs index 465ccb14b6..21598450c2 100644 --- a/compiler/types/TyCon.hs +++ b/compiler/types/TyCon.hs @@ -13,8 +13,8 @@ module TyCon( TyCon, AlgTyConRhs(..), visibleDataCons, - TyConParent(..), isNoParent, - FamTyConFlav(..), Role(..), Injectivity(..), + AlgTyConFlav(..), isNoParent, + FamTyConFlav(..), Role(..), Promoted(..), Injectivity(..), -- ** Field labels tyConFieldLabels, tyConFieldLabelEnv, @@ -42,7 +42,7 @@ module TyCon( mightBeUnsaturatedTyCon, isPromotedDataCon, isPromotedTyCon, isPromotedDataCon_maybe, isPromotedTyCon_maybe, - promotableTyCon_maybe, promoteTyCon, + promotableTyCon_maybe, isPromotableTyCon, promoteTyCon, isDataTyCon, isProductTyCon, isDataProductTyCon_maybe, isEnumerationTyCon, @@ -71,7 +71,6 @@ module TyCon( tyConStupidTheta, tyConArity, tyConRoles, - tyConParent, tyConFlavour, tyConTuple_maybe, tyConClass_maybe, tyConFamInst_maybe, tyConFamInstSig_maybe, tyConFamilyCoercion_maybe, @@ -89,6 +88,9 @@ module TyCon( newTyConCo, newTyConCo_maybe, pprPromotionQuote, + -- * Runtime type representation + TyConRepName, tyConRepName_maybe, + -- * Primitive representations of Types PrimRep(..), PrimElemRep(..), tyConPrimRep, isVoidRep, isGcPtrRep, @@ -190,8 +192,8 @@ See also Note [Wrappers for data instance tycons] in MkId.hs Note that this is a *representational* coercion The R:TInt is the "representation TyCons". - It has an AlgTyConParent of - FamInstTyCon T [Int] ax_ti + It has an AlgTyConFlav of + DataFamInstTyCon T [Int] ax_ti * The axiom ax_ti may be eta-reduced; see Note [Eta reduction for data family axioms] in TcInstDcls @@ -223,9 +225,9 @@ See also Note [Wrappers for data instance tycons] in MkId.hs data instance declaration for T (a,b), to get the result type in the representation; e.g. T (a,b) --> R:TPair a b - The representation TyCon R:TList, has an AlgTyConParent of + The representation TyCon R:TList, has an AlgTyConFlav of - FamInstTyCon T [(a,b)] ax_pr + DataFamInstTyCon T [(a,b)] ax_pr * Notice that T is NOT translated to a FC type function; it just becomes a "data type" with no constructors, which can be coerced inot @@ -269,7 +271,7 @@ See also Note [Wrappers for data instance tycons] in MkId.hs Note [Associated families and their parent class] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ *Associated* families are just like *non-associated* families, except -that they have a TyConParent of AssocFamilyTyCon, which identifies the +that they have a famTcParent field of (Just cls), which identifies the parent class. However there is an important sharing relationship between @@ -375,15 +377,26 @@ data TyCon tyConKind :: Kind, -- ^ Kind of this TyCon (full kind, not just -- the return kind) - tyConArity :: Arity -- ^ Number of arguments this TyCon must + tyConArity :: Arity, -- ^ Number of arguments this TyCon must -- receive to be considered saturated -- (including implicit kind variables) + + tcRepName :: TyConRepName } - -- | Algebraic type constructors, which are defined to be those - -- arising @data@ type and @newtype@ declarations. All these - -- constructors are lifted and boxed. See 'AlgTyConRhs' for more - -- information. + -- | Algebraic data types, from + -- - @data@ declararations + -- - @newtype@ declarations + -- - data instance declarations + -- - type instance declarations + -- - the TyCon generated by a class declaration + -- - boxed tuples + -- - unboxed tuples + -- - constraint tuples + -- All these constructors are lifted and boxed except unboxed tuples + -- which should have an 'UnboxedAlgTyCon' parent. + -- Data/newtype/type /families/ are handled by 'FamilyTyCon'. + -- See 'AlgTyConRhs' for more information. | AlgTyCon { tyConUnique :: Unique, -- ^ A Unique of this TyCon. Invariant: -- identical to Unique of Name stored in @@ -440,12 +453,11 @@ data TyCon algTcRec :: RecFlag, -- ^ Tells us whether the data type is part -- of a mutually-recursive group or not - algTcParent :: TyConParent, -- ^ Gives the class or family declaration - -- 'TyCon' for derived 'TyCon's representing - -- class or family instances, respectively. - -- See also 'synTcParent' + algTcParent :: AlgTyConFlav, -- ^ Gives the class or family declaration + -- 'TyCon' for derived 'TyCon's representing + -- class or family instances, respectively. - tcPromoted :: Maybe TyCon -- ^ Promoted TyCon, if any + tcPromoted :: Promoted TyCon -- ^ Promoted TyCon, if any } -- | Represents type synonyms @@ -475,7 +487,8 @@ data TyCon -- of the synonym } - -- | Represents type families + -- | Represents families (both type and data) + -- Argument roles are all Nominal | FamilyTyCon { tyConUnique :: Unique, -- ^ A Unique of this TyCon. Invariant: -- identical to Unique of Name stored in @@ -496,7 +509,7 @@ data TyCon -- Precisely, this list scopes over: -- -- 1. The 'algTcStupidTheta' - -- 2. The cached types in algTyConRhs.NewTyCon + -- 2. The cached types in 'algTyConRhs.NewTyCon' -- 3. The family instance types if present -- -- Note that it does /not/ scope over the data @@ -511,8 +524,9 @@ data TyCon -- abstract, built-in. See comments for -- FamTyConFlav - famTcParent :: TyConParent, -- ^ TyCon of enclosing class for - -- associated type families + famTcParent :: Maybe Class, -- ^ For *associated* type/data families + -- The class in whose declaration the family is declared + -- See Note [Associated families and their parent class] famTcInj :: Injectivity -- ^ is this a type family injective in -- its type variables? Nothing if no @@ -521,7 +535,7 @@ data TyCon -- | Primitive types; cannot be defined in Haskell. This includes -- the usual suspects (such as @Int#@) as well as foreign-imported - -- types and kinds + -- types and kinds (@*@, @#@, and @?@) | PrimTyCon { tyConUnique :: Unique, -- ^ A Unique of this TyCon. Invariant: -- identical to Unique of Name stored in @@ -545,9 +559,13 @@ data TyCon -- pointers). This 'PrimRep' holds that -- information. Only relevant if tyConKind = * - isUnLifted :: Bool -- ^ Most primitive tycons are unlifted (may + isUnLifted :: Bool, -- ^ Most primitive tycons are unlifted (may -- not contain bottom) but other are lifted, -- e.g. @RealWorld@ + -- Only relevant if tyConKind = * + + primRepName :: Maybe TyConRepName -- Only relevant for kind TyCons + -- i.e, *, #, ? } -- | Represents promoted data constructor. @@ -557,7 +575,8 @@ data TyCon tyConArity :: Arity, tyConKind :: Kind, -- ^ Translated type of the data constructor tcRoles :: [Role], -- ^ Roles: N for kind vars, R for type vars - dataCon :: DataCon -- ^ Corresponding data constructor + dataCon :: DataCon,-- ^ Corresponding data constructor + tcRepName :: TyConRepName } -- | Represents promoted type constructor. @@ -566,7 +585,8 @@ data TyCon tyConName :: Name, -- ^ Same Name as the type constructor tyConArity :: Arity, -- ^ n if ty_con :: * -> ... -> * n times tyConKind :: Kind, -- ^ Always TysPrim.superKind - ty_con :: TyCon -- ^ Corresponding type constructor + ty_con :: TyCon, -- ^ Corresponding type constructor + tcRepName :: TyConRepName } deriving Typeable @@ -582,20 +602,6 @@ data AlgTyConRhs Bool -- True <=> It's definitely a distinct data type, -- equal only to itself; ie not a newtype -- False <=> Not sure - -- See Note [AbstractTyCon and type equality] - - -- | Represents an open type family without a fixed right hand - -- side. Additional instances can appear at any time. - -- - -- These are introduced by either a top level declaration: - -- - -- > data T a :: * - -- - -- Or an associated data type declaration, within a class declaration: - -- - -- > class C a b where - -- > data T b :: * - | DataFamilyTyCon -- | Information about those 'TyCon's derived from a @data@ -- declaration. This includes data types with no constructors at @@ -649,18 +655,15 @@ data AlgTyConRhs -- again check Trac #1072. } -{- -Note [AbstractTyCon and type equality] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -TODO --} +-- | Isomorphic to Maybe, but used when the question is +-- whether or not something is promoted +data Promoted a = NotPromoted | Promoted a -- | Extract those 'DataCon's that we are able to learn about. Note -- that visibility in this sense does not correspond to visibility in -- the context of any particular user program! visibleDataCons :: AlgTyConRhs -> [DataCon] visibleDataCons (AbstractTyCon {}) = [] -visibleDataCons DataFamilyTyCon {} = [] visibleDataCons (DataTyCon{ data_cons = cs }) = cs visibleDataCons (NewTyCon{ data_con = c }) = [c] visibleDataCons (TupleTyCon{ data_con = c }) = [c] @@ -668,26 +671,35 @@ visibleDataCons (TupleTyCon{ data_con = c }) = [c] -- ^ Both type classes as well as family instances imply implicit -- type constructors. These implicit type constructors refer to their parent -- structure (ie, the class or family from which they derive) using a type of --- the following form. We use 'TyConParent' for both algebraic and synonym --- types, but the variant 'ClassTyCon' will only be used by algebraic 'TyCon's. -data TyConParent +-- the following form. +data AlgTyConFlav = -- | An ordinary type constructor has no parent. - NoParentTyCon + VanillaAlgTyCon + TyConRepName + + -- | An unboxed type constructor. Note that this carries no TyConRepName + -- as it is not representable. + | UnboxedAlgTyCon -- | Type constructors representing a class dictionary. -- See Note [ATyCon for classes] in TypeRep | ClassTyCon Class -- INVARIANT: the classTyCon of this Class is the -- current tycon - - -- | An *associated* type of a class. - | AssocFamilyTyCon - Class -- The class in whose declaration the family is declared - -- See Note [Associated families and their parent class] - - -- | Type constructors representing an instance of a *data* family. - -- See Note [Data type families] and source comments for more info. - | FamInstTyCon -- See Note [Data type families] + TyConRepName + + -- | Type constructors representing an *instance* of a *data* family. + -- Parameters: + -- + -- 1) The type family in question + -- + -- 2) Instance types; free variables are the 'tyConTyVars' + -- of the current 'TyCon' (not the family one). INVARIANT: + -- the number of types matches the arity of the family 'TyCon' + -- + -- 3) A 'CoTyCon' identifying the representation + -- type with the type instance family + | DataFamInstTyCon -- See Note [Data type families] (CoAxiom Unbranched) -- The coercion axiom. -- A *Representational* coercion, -- of kind T ty1 ty2 ~R R:T a b c @@ -708,27 +720,26 @@ data TyConParent -- gives a representation tycon: -- data R:TList a = ... -- axiom co a :: T [a] ~ R:TList a - -- with R:TList's algTcParent = FamInstTyCon T [a] co - -instance Outputable TyConParent where - ppr NoParentTyCon = text "No parent" - ppr (ClassTyCon cls) = text "Class parent" <+> ppr cls - ppr (AssocFamilyTyCon cls) = - text "Class parent (assoc. family)" <+> ppr cls - ppr (FamInstTyCon _ tc tys) = + -- with R:TList's algTcParent = DataFamInstTyCon T [a] co + +instance Outputable AlgTyConFlav where + ppr (VanillaAlgTyCon {}) = text "Vanilla ADT" + ppr (UnboxedAlgTyCon {}) = text "Unboxed ADT" + ppr (ClassTyCon cls _) = text "Class parent" <+> ppr cls + ppr (DataFamInstTyCon _ tc tys) = text "Family parent (family instance)" <+> ppr tc <+> sep (map ppr tys) --- | Checks the invariants of a 'TyConParent' given the appropriate type class +-- | Checks the invariants of a 'AlgTyConFlav' given the appropriate type class -- name, if any -okParent :: Name -> TyConParent -> Bool -okParent _ NoParentTyCon = True -okParent tc_name (AssocFamilyTyCon cls) = tc_name `elem` map tyConName (classATs cls) -okParent tc_name (ClassTyCon cls) = tc_name == tyConName (classTyCon cls) -okParent _ (FamInstTyCon _ fam_tc tys) = tyConArity fam_tc == length tys +okParent :: Name -> AlgTyConFlav -> Bool +okParent _ (VanillaAlgTyCon {}) = True +okParent _ (UnboxedAlgTyCon) = True +okParent tc_name (ClassTyCon cls _) = tc_name == tyConName (classTyCon cls) +okParent _ (DataFamInstTyCon _ fam_tc tys) = tyConArity fam_tc == length tys -isNoParent :: TyConParent -> Bool -isNoParent NoParentTyCon = True -isNoParent _ = False +isNoParent :: AlgTyConFlav -> Bool +isNoParent (VanillaAlgTyCon {}) = True +isNoParent _ = False -------------------- @@ -739,8 +750,22 @@ data Injectivity -- | Information pertaining to the expansion of a type synonym (@type@) data FamTyConFlav - = -- | An open type synonym family e.g. @type family F x y :: * -> *@ - OpenSynFamilyTyCon + = -- | Represents an open type family without a fixed right hand + -- side. Additional instances can appear at any time. + -- + -- These are introduced by either a top level declaration: + -- + -- > data T a :: * + -- + -- Or an associated data type declaration, within a class declaration: + -- + -- > class C a b where + -- > data T b :: * + DataFamilyTyCon + TyConRepName + + -- | An open type synonym family e.g. @type family F x y :: * -> *@ + | OpenSynFamilyTyCon -- | A closed type synonym family e.g. -- @type family F x where { F Int = Bool }@ @@ -878,7 +903,34 @@ so the coercion tycon CoT must have ************************************************************************ * * -\subsection{PrimRep} + TyConRepName +* * +********************************************************************* -} + +type TyConRepName = Name -- The Name of the top-level declaration + -- $tcMaybe :: Data.Typeable.Internal.TyCon + -- $tcMaybe = TyCon { tyConName = "Maybe", ... } + +tyConRepName_maybe :: TyCon -> Maybe TyConRepName +tyConRepName_maybe (FunTyCon { tcRepName = rep_nm }) + = Just rep_nm +tyConRepName_maybe (PrimTyCon { primRepName = mb_rep_nm }) + = mb_rep_nm +tyConRepName_maybe (AlgTyCon { algTcParent = parent }) + | VanillaAlgTyCon rep_nm <- parent = Just rep_nm + | ClassTyCon _ rep_nm <- parent = Just rep_nm +tyConRepName_maybe (FamilyTyCon { famTcFlav = DataFamilyTyCon rep_nm }) + = Just rep_nm +tyConRepName_maybe (PromotedDataCon { tcRepName = rep_nm }) + = Just rep_nm +tyConRepName_maybe (PromotedTyCon { tcRepName = rep_nm }) + = Just rep_nm +tyConRepName_maybe _ = Nothing + + +{- ********************************************************************* +* * + PrimRep * * ************************************************************************ @@ -1062,13 +1114,14 @@ So we compromise, and move their Kind calculation to the call site. -- | Given the name of the function type constructor and it's kind, create the -- corresponding 'TyCon'. It is reccomended to use 'TypeRep.funTyCon' if you want -- this functionality -mkFunTyCon :: Name -> Kind -> TyCon -mkFunTyCon name kind +mkFunTyCon :: Name -> Kind -> Name -> TyCon +mkFunTyCon name kind rep_nm = FunTyCon { tyConUnique = nameUnique name, tyConName = name, tyConKind = kind, - tyConArity = 2 + tyConArity = 2, + tcRepName = rep_nm } -- | This is the making of an algebraic 'TyCon'. Notably, you have to @@ -1084,11 +1137,12 @@ mkAlgTyCon :: Name -> Maybe CType -- ^ The C type this type corresponds to -- when using the CAPI FFI -> [PredType] -- ^ Stupid theta: see 'algTcStupidTheta' - -> AlgTyConRhs -- ^ Information about dat aconstructors - -> TyConParent + -> AlgTyConRhs -- ^ Information about data constructors + -> AlgTyConFlav -- ^ What flavour is it? + -- (e.g. vanilla, type family) -> RecFlag -- ^ Is the 'TyCon' recursive? -> Bool -- ^ Was the 'TyCon' declared with GADT syntax? - -> Maybe TyCon -- ^ Promoted version + -> Promoted TyCon -- ^ Promoted version -> TyCon mkAlgTyCon name kind tyvars roles cType stupid rhs parent is_rec gadt_syn prom_tc = AlgTyCon { @@ -1110,11 +1164,12 @@ mkAlgTyCon name kind tyvars roles cType stupid rhs parent is_rec gadt_syn prom_t -- | Simpler specialization of 'mkAlgTyCon' for classes mkClassTyCon :: Name -> Kind -> [TyVar] -> [Role] -> AlgTyConRhs -> Class - -> RecFlag -> TyCon -mkClassTyCon name kind tyvars roles rhs clas is_rec - = mkAlgTyCon name kind tyvars roles Nothing [] rhs (ClassTyCon clas) + -> RecFlag -> Name -> TyCon +mkClassTyCon name kind tyvars roles rhs clas is_rec tc_rep_name + = mkAlgTyCon name kind tyvars roles Nothing [] rhs + (ClassTyCon clas tc_rep_name) is_rec False - Nothing -- Class TyCons are not promoted + NotPromoted -- Class TyCons are not promoted mkTupleTyCon :: Name -> Kind -- ^ Kind of the resulting 'TyCon' @@ -1122,8 +1177,8 @@ mkTupleTyCon :: Name -> [TyVar] -- ^ 'TyVar's scoped over: see 'tyConTyVars' -> DataCon -> TupleSort -- ^ Whether the tuple is boxed or unboxed - -> Maybe TyCon -- ^ Promoted version - -> TyConParent + -> Promoted TyCon -- ^ Promoted version + -> AlgTyConFlav -> TyCon mkTupleTyCon name kind arity tyvars con sort prom_tc parent = AlgTyCon { @@ -1135,7 +1190,8 @@ mkTupleTyCon name kind arity tyvars con sort prom_tc parent tcRoles = replicate arity Representational, tyConCType = Nothing, algTcStupidTheta = [], - algTcRhs = TupleTyCon { data_con = con, tup_sort = sort }, + algTcRhs = TupleTyCon { data_con = con, + tup_sort = sort }, algTcFields = emptyFsEnv, algTcParent = parent, algTcRec = NonRecursive, @@ -1146,20 +1202,21 @@ mkTupleTyCon name kind arity tyvars con sort prom_tc parent -- | Create an unlifted primitive 'TyCon', such as @Int#@ mkPrimTyCon :: Name -> Kind -> [Role] -> PrimRep -> TyCon mkPrimTyCon name kind roles rep - = mkPrimTyCon' name kind roles rep True + = mkPrimTyCon' name kind roles rep True Nothing -- | Kind constructors -mkKindTyCon :: Name -> Kind -> TyCon -mkKindTyCon name kind - = mkPrimTyCon' name kind [] VoidRep True +mkKindTyCon :: Name -> Kind -> Name -> TyCon +mkKindTyCon name kind rep_nm + = mkPrimTyCon' name kind [] VoidRep True (Just rep_nm) -- | Create a lifted primitive 'TyCon' such as @RealWorld@ mkLiftedPrimTyCon :: Name -> Kind -> [Role] -> PrimRep -> TyCon mkLiftedPrimTyCon name kind roles rep - = mkPrimTyCon' name kind roles rep False + = mkPrimTyCon' name kind roles rep False Nothing -mkPrimTyCon' :: Name -> Kind -> [Role] -> PrimRep -> Bool -> TyCon -mkPrimTyCon' name kind roles rep is_unlifted +mkPrimTyCon' :: Name -> Kind -> [Role] -> PrimRep + -> Bool -> Maybe TyConRepName -> TyCon +mkPrimTyCon' name kind roles rep is_unlifted rep_nm = PrimTyCon { tyConName = name, tyConUnique = nameUnique name, @@ -1167,7 +1224,8 @@ mkPrimTyCon' name kind roles rep is_unlifted tyConArity = length roles, tcRoles = roles, primTyConRep = rep, - isUnLifted = is_unlifted + isUnLifted = is_unlifted, + primRepName = rep_nm } -- | Create a type synonym 'TyCon' @@ -1185,7 +1243,7 @@ mkSynonymTyCon name kind tyvars roles rhs -- | Create a type family 'TyCon' mkFamilyTyCon:: Name -> Kind -> [TyVar] -> Maybe Name -> FamTyConFlav - -> TyConParent -> Injectivity -> TyCon + -> Maybe Class -> Injectivity -> TyCon mkFamilyTyCon name kind tyvars resVar flav parent inj = FamilyTyCon { tyConUnique = nameUnique name @@ -1204,15 +1262,16 @@ mkFamilyTyCon name kind tyvars resVar flav parent inj -- Somewhat dodgily, we give it the same Name -- as the data constructor itself; when we pretty-print -- the TyCon we add a quote; see the Outputable TyCon instance -mkPromotedDataCon :: DataCon -> Name -> Unique -> Kind -> [Role] -> TyCon -mkPromotedDataCon con name unique kind roles +mkPromotedDataCon :: DataCon -> Name -> TyConRepName -> Kind -> [Role] -> TyCon +mkPromotedDataCon con name rep_name kind roles = PromotedDataCon { + tyConUnique = nameUnique name, tyConName = name, - tyConUnique = unique, tyConArity = arity, tcRoles = roles, tyConKind = kind, - dataCon = con + dataCon = con, + tcRepName = rep_name } where arity = length roles @@ -1227,7 +1286,11 @@ mkPromotedTyCon tc kind tyConUnique = getUnique tc, tyConArity = tyConArity tc, tyConKind = kind, - ty_con = tc + ty_con = tc, + tcRepName = case tyConRepName_maybe tc of + Just rep_nm -> rep_nm + Nothing -> pprPanic "mkPromotedTyCon" (ppr tc) + -- Promoted TyCons always have a TyConRepName } isFunTyCon :: TyCon -> Bool @@ -1284,7 +1347,6 @@ isDataTyCon (AlgTyCon {algTcRhs = rhs}) -> isBoxed (tupleSortBoxity sort) DataTyCon {} -> True NewTyCon {} -> False - DataFamilyTyCon {} -> False AbstractTyCon {} -> False -- We don't know, so return False isDataTyCon _ = False @@ -1300,7 +1362,8 @@ isInjectiveTyCon (AlgTyCon {}) Nominal = True isInjectiveTyCon (AlgTyCon {algTcRhs = rhs}) Representational = isGenInjAlgRhs rhs isInjectiveTyCon (SynonymTyCon {}) _ = False -isInjectiveTyCon (FamilyTyCon {}) _ = False +isInjectiveTyCon (FamilyTyCon {famTcFlav = flav}) Nominal = isDataFamFlav flav +isInjectiveTyCon (FamilyTyCon {}) Representational = False isInjectiveTyCon (PrimTyCon {}) _ = True isInjectiveTyCon (PromotedDataCon {}) _ = True isInjectiveTyCon (PromotedTyCon {ty_con = tc}) r @@ -1320,7 +1383,6 @@ isGenerativeTyCon = isInjectiveTyCon isGenInjAlgRhs :: AlgTyConRhs -> Bool isGenInjAlgRhs (TupleTyCon {}) = True isGenInjAlgRhs (DataTyCon {}) = True -isGenInjAlgRhs (DataFamilyTyCon {}) = False isGenInjAlgRhs (AbstractTyCon distinct) = distinct isGenInjAlgRhs (NewTyCon {}) = False @@ -1409,8 +1471,7 @@ isTypeSynonymTyCon _ = False -- right hand side to which a synonym family application can expand. -- -mightBeUnsaturatedTyCon :: TyCon -> Bool --- True iff we can decompose (T a b c) into ((T a b) c) +-- | True iff we can decompose (T a b c) into ((T a b) c) -- I.e. is it injective and generative w.r.t nominal equality? -- That is, if (T a b) ~N d e f, is it always the case that -- (T ~N d), (a ~N e) and (b ~N f)? @@ -1419,8 +1480,9 @@ mightBeUnsaturatedTyCon :: TyCon -> Bool -- It'd be unusual to call mightBeUnsaturatedTyCon on a regular H98 -- type synonym, because you should probably have expanded it first -- But regardless, it's not decomposable +mightBeUnsaturatedTyCon :: TyCon -> Bool mightBeUnsaturatedTyCon (SynonymTyCon {}) = False -mightBeUnsaturatedTyCon (FamilyTyCon {}) = False +mightBeUnsaturatedTyCon (FamilyTyCon { famTcFlav = flav}) = isDataFamFlav flav mightBeUnsaturatedTyCon _other = True -- | Is this an algebraic 'TyCon' declared with the GADT syntax? @@ -1440,21 +1502,26 @@ isEnumerationTyCon _ = False -- | Is this a 'TyCon', synonym or otherwise, that defines a family? isFamilyTyCon :: TyCon -> Bool -isFamilyTyCon (FamilyTyCon {}) = True -isFamilyTyCon (AlgTyCon {algTcRhs = DataFamilyTyCon {}}) = True -isFamilyTyCon _ = False +isFamilyTyCon (FamilyTyCon {}) = True +isFamilyTyCon _ = False -- | Is this a 'TyCon', synonym or otherwise, that defines a family with -- instances? isOpenFamilyTyCon :: TyCon -> Bool -isOpenFamilyTyCon (FamilyTyCon {famTcFlav = OpenSynFamilyTyCon }) = True -isOpenFamilyTyCon (AlgTyCon {algTcRhs = DataFamilyTyCon }) = True -isOpenFamilyTyCon _ = False +isOpenFamilyTyCon (FamilyTyCon {famTcFlav = flav }) + | OpenSynFamilyTyCon <- flav = True + | DataFamilyTyCon {} <- flav = True +isOpenFamilyTyCon _ = False -- | Is this a synonym 'TyCon' that can have may have further instances appear? isTypeFamilyTyCon :: TyCon -> Bool -isTypeFamilyTyCon (FamilyTyCon {}) = True -isTypeFamilyTyCon _ = False +isTypeFamilyTyCon (FamilyTyCon { famTcFlav = flav }) = not (isDataFamFlav flav) +isTypeFamilyTyCon _ = False + +-- | Is this a synonym 'TyCon' that can have may have further instances appear? +isDataFamilyTyCon :: TyCon -> Bool +isDataFamilyTyCon (FamilyTyCon { famTcFlav = flav }) = isDataFamFlav flav +isDataFamilyTyCon _ = False -- | Is this an open type family TyCon? isOpenTypeFamilyTyCon :: TyCon -> Bool @@ -1479,10 +1546,9 @@ isBuiltInSynFamTyCon_maybe (FamilyTyCon {famTcFlav = BuiltInSynFamTyCon ops }) = Just ops isBuiltInSynFamTyCon_maybe _ = Nothing --- | Is this a synonym 'TyCon' that can have may have further instances appear? -isDataFamilyTyCon :: TyCon -> Bool -isDataFamilyTyCon (AlgTyCon {algTcRhs = DataFamilyTyCon {}}) = True -isDataFamilyTyCon _ = False +isDataFamFlav :: FamTyConFlav -> Bool +isDataFamFlav (DataFamilyTyCon {}) = True -- Data family +isDataFamFlav _ = False -- Type synonym family -- | Are we able to extract information 'TyVar' to class argument list -- mapping from a given 'TyCon'? @@ -1490,9 +1556,8 @@ isTyConAssoc :: TyCon -> Bool isTyConAssoc tc = isJust (tyConAssoc_maybe tc) tyConAssoc_maybe :: TyCon -> Maybe Class -tyConAssoc_maybe tc = case tyConParent tc of - AssocFamilyTyCon cls -> Just cls - _ -> Nothing +tyConAssoc_maybe (FamilyTyCon { famTcParent = mb_cls }) = mb_cls +tyConAssoc_maybe _ = Nothing -- The unit tycon didn't used to be classed as a tuple tycon -- but I thought that was silly so I've undone it @@ -1531,14 +1596,19 @@ isRecursiveTyCon :: TyCon -> Bool isRecursiveTyCon (AlgTyCon {algTcRec = Recursive}) = True isRecursiveTyCon _ = False -promotableTyCon_maybe :: TyCon -> Maybe TyCon +promotableTyCon_maybe :: TyCon -> Promoted TyCon promotableTyCon_maybe (AlgTyCon { tcPromoted = prom }) = prom -promotableTyCon_maybe _ = Nothing +promotableTyCon_maybe _ = NotPromoted + +isPromotableTyCon :: TyCon -> Bool +isPromotableTyCon tc = case promotableTyCon_maybe tc of + Promoted {} -> True + NotPromoted -> False promoteTyCon :: TyCon -> TyCon promoteTyCon tc = case promotableTyCon_maybe tc of - Just prom_tc -> prom_tc - Nothing -> pprPanic "promoteTyCon" (ppr tc) + Promoted prom_tc -> prom_tc + NotPromoted -> pprPanic "promoteTyCon" (ppr tc) -- | Is this a PromotedTyCon? isPromotedTyCon :: TyCon -> Bool @@ -1580,13 +1650,10 @@ isImplicitTyCon (FunTyCon {}) = True isImplicitTyCon (PrimTyCon {}) = True isImplicitTyCon (PromotedDataCon {}) = True isImplicitTyCon (PromotedTyCon {}) = True -isImplicitTyCon (AlgTyCon { algTcRhs = rhs, algTcParent = parent, tyConName = name }) +isImplicitTyCon (AlgTyCon { algTcRhs = rhs, tyConName = name }) | TupleTyCon {} <- rhs = isWiredInName name - | AssocFamilyTyCon {} <- parent = True - | otherwise = False -isImplicitTyCon (FamilyTyCon { famTcParent = parent }) - | AssocFamilyTyCon {} <- parent = True | otherwise = False +isImplicitTyCon (FamilyTyCon { famTcParent = parent }) = isJust parent isImplicitTyCon (SynonymTyCon {}) = False tyConCType_maybe :: TyCon -> Maybe CType @@ -1679,7 +1746,6 @@ tyConFamilySize tc@(AlgTyCon { algTcRhs = rhs }) DataTyCon { data_cons = cons } -> length cons NewTyCon {} -> 1 TupleTyCon {} -> 1 - DataFamilyTyCon {} -> 0 _ -> pprPanic "tyConFamilySize 1" (ppr tc) tyConFamilySize tc = pprPanic "tyConFamilySize 2" (ppr tc) @@ -1776,50 +1842,41 @@ famTyConFlav_maybe _ = Nothing -- | Is this 'TyCon' that for a class instance? isClassTyCon :: TyCon -> Bool -isClassTyCon (AlgTyCon {algTcParent = ClassTyCon _}) = True -isClassTyCon _ = False +isClassTyCon (AlgTyCon {algTcParent = ClassTyCon {}}) = True +isClassTyCon _ = False -- | If this 'TyCon' is that for a class instance, return the class it is for. -- Otherwise returns @Nothing@ tyConClass_maybe :: TyCon -> Maybe Class -tyConClass_maybe (AlgTyCon {algTcParent = ClassTyCon clas}) = Just clas -tyConClass_maybe _ = Nothing - ----------------------------------------------------------------------------- -tyConParent :: TyCon -> TyConParent -tyConParent (AlgTyCon {algTcParent = parent}) = parent -tyConParent (FamilyTyCon {famTcParent = parent}) = parent -tyConParent _ = NoParentTyCon +tyConClass_maybe (AlgTyCon {algTcParent = ClassTyCon clas _}) = Just clas +tyConClass_maybe _ = Nothing ---------------------------------------------------------------------------- -- | Is this 'TyCon' that for a data family instance? isFamInstTyCon :: TyCon -> Bool -isFamInstTyCon tc = case tyConParent tc of - FamInstTyCon {} -> True - _ -> False +isFamInstTyCon (AlgTyCon {algTcParent = DataFamInstTyCon {} }) + = True +isFamInstTyCon _ = False tyConFamInstSig_maybe :: TyCon -> Maybe (TyCon, [Type], CoAxiom Unbranched) -tyConFamInstSig_maybe tc - = case tyConParent tc of - FamInstTyCon ax f ts -> Just (f, ts, ax) - _ -> Nothing +tyConFamInstSig_maybe (AlgTyCon {algTcParent = DataFamInstTyCon ax f ts }) + = Just (f, ts, ax) +tyConFamInstSig_maybe _ = Nothing --- | If this 'TyCon' is that of a family instance, return the family in question +-- | If this 'TyCon' is that of a data family instance, return the family in question -- and the instance types. Otherwise, return @Nothing@ tyConFamInst_maybe :: TyCon -> Maybe (TyCon, [Type]) -tyConFamInst_maybe tc - = case tyConParent tc of - FamInstTyCon _ f ts -> Just (f, ts) - _ -> Nothing +tyConFamInst_maybe (AlgTyCon {algTcParent = DataFamInstTyCon _ f ts }) + = Just (f, ts) +tyConFamInst_maybe _ = Nothing --- | If this 'TyCon' is that of a family instance, return a 'TyCon' which +-- | If this 'TyCon' is that of a data family instance, return a 'TyCon' which -- represents a coercion identifying the representation type with the type -- instance family. Otherwise, return @Nothing@ tyConFamilyCoercion_maybe :: TyCon -> Maybe (CoAxiom Unbranched) -tyConFamilyCoercion_maybe tc - = case tyConParent tc of - FamInstTyCon co _ _ -> Just co - _ -> Nothing +tyConFamilyCoercion_maybe (AlgTyCon {algTcParent = DataFamInstTyCon ax _ _ }) + = Just ax +tyConFamilyCoercion_maybe _ = Nothing {- ************************************************************************ @@ -1855,16 +1912,17 @@ instance Outputable TyCon where tyConFlavour :: TyCon -> String tyConFlavour (AlgTyCon { algTcParent = parent, algTcRhs = rhs }) - | ClassTyCon _ <- parent = "class" + | ClassTyCon _ _ <- parent = "class" | otherwise = case rhs of TupleTyCon { tup_sort = sort } | isBoxed (tupleSortBoxity sort) -> "tuple" | otherwise -> "unboxed tuple" DataTyCon {} -> "data type" NewTyCon {} -> "newtype" - DataFamilyTyCon {} -> "data family" AbstractTyCon {} -> "abstract type" -tyConFlavour (FamilyTyCon {}) = "type family" +tyConFlavour (FamilyTyCon { famTcFlav = flav }) + | isDataFamFlav flav = "data family" + | otherwise = "type family" tyConFlavour (SynonymTyCon {}) = "type synonym" tyConFlavour (FunTyCon {}) = "built-in type" tyConFlavour (PrimTyCon {}) = "built-in type" @@ -1872,14 +1930,16 @@ tyConFlavour (PromotedDataCon {}) = "promoted data constructor" tyConFlavour (PromotedTyCon {}) = "promoted type constructor" pprPromotionQuote :: TyCon -> SDoc -pprPromotionQuote (PromotedDataCon {}) = char '\'' -- Quote promoted DataCons - -- in types -pprPromotionQuote (PromotedTyCon {}) = ifPprDebug (char '\'') -pprPromotionQuote _ = empty -- However, we don't quote TyCons - -- in kinds e.g. - -- type family T a :: Bool -> * - -- cf Trac #5952. - -- Except with -dppr-debug +-- Promoted data constructors already have a tick in their OccName +pprPromotionQuote tc + = case tc of + PromotedDataCon {} -> char '\'' -- Always quote promoted DataCons in types + + PromotedTyCon {} -> ifPprDebug (char '\'') + -- However, we don't quote TyCons in kinds, except with -dppr-debug + -- e.g. type family T a :: Bool -> * + -- cf Trac #5952. + _ -> empty instance NamedThing TyCon where getName = tyConName diff --git a/compiler/types/Type.hs b/compiler/types/Type.hs index a2feeef723..0c8ed35776 100644 --- a/compiler/types/Type.hs +++ b/compiler/types/Type.hs @@ -30,6 +30,7 @@ module Type ( mkTyConApp, mkTyConTy, tyConAppTyCon_maybe, tyConAppArgs_maybe, tyConAppTyCon, tyConAppArgs, splitTyConApp_maybe, splitTyConApp, tyConAppArgN, nextRole, + splitTyConArgs, mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys, mkPiKinds, mkPiType, mkPiTypes, @@ -595,6 +596,14 @@ nextRole ty | otherwise = Nominal +splitTyConArgs :: TyCon -> [KindOrType] -> ([Kind], [Type]) +-- Given a tycon app (T k1 .. kn t1 .. tm), split the kind and type args +-- TyCons always have prenex kinds +splitTyConArgs tc kts + = splitAtList kind_vars kts + where + (kind_vars, _) = splitForAllTys (tyConKind tc) + newTyConInstRhs :: TyCon -> [Type] -> Type -- ^ Unwrap one 'layer' of newtype on a type constructor and its -- arguments, using an eta-reduced version of the @newtype@ if possible. diff --git a/compiler/utils/Binary.hs b/compiler/utils/Binary.hs index 8946b6cf62..5083804d6f 100644 --- a/compiler/utils/Binary.hs +++ b/compiler/utils/Binary.hs @@ -76,7 +76,6 @@ import Data.IORef import Data.Char ( ord, chr ) import Data.Time import Data.Typeable -import Data.Typeable.Internal import Control.Monad ( when ) import System.IO as IO import System.IO.Unsafe ( unsafeInterleaveIO ) @@ -554,10 +553,14 @@ instance Binary (Bin a) where -- Instances for Data.Typeable stuff instance Binary TyCon where - put_ bh (TyCon _ p m n) = do - put_ bh (p,m,n) + put_ bh tc = do + put_ bh (tyConPackage tc) + put_ bh (tyConModule tc) + put_ bh (tyConName tc) get bh = do - (p,m,n) <- get bh + p <- get bh + m <- get bh + n <- get bh return (mkTyCon3 p m n) instance Binary TypeRep where diff --git a/compiler/vectorise/Vectorise/Generic/PData.hs b/compiler/vectorise/Vectorise/Generic/PData.hs index fc0192c744..b69a773626 100644 --- a/compiler/vectorise/Vectorise/Generic/PData.hs +++ b/compiler/vectorise/Vectorise/Generic/PData.hs @@ -59,7 +59,7 @@ buildDataFamInst name' fam_tc vect_tc rhs rec_flag -- FIXME: is this ok? False -- Not promotable False -- not GADT syntax - (FamInstTyCon ax fam_tc pat_tys) + (DataFamInstTyCon ax fam_tc pat_tys) ; liftDs $ newFamInst (DataFamilyInst rep_tc) ax } where tyvars = tyConTyVars vect_tc @@ -79,6 +79,7 @@ buildPDataDataCon orig_name vect_tc repr_tc repr fam_envs <- readGEnv global_fam_inst_env liftDs $ buildDataCon fam_envs dc_name False -- not infix + NotPromoted -- not promotable (map (const no_bang) comp_tys) (Just $ map (const HsLazy) comp_tys) [] -- no field labels @@ -121,6 +122,7 @@ buildPDatasDataCon orig_name vect_tc repr_tc repr fam_envs <- readGEnv global_fam_inst_env liftDs $ buildDataCon fam_envs dc_name False -- not infix + NotPromoted -- not promotable (map (const no_bang) comp_tys) (Just $ map (const HsLazy) comp_tys) [] -- no field labels diff --git a/compiler/vectorise/Vectorise/Type/Env.hs b/compiler/vectorise/Vectorise/Type/Env.hs index 47b1caa516..8396e2cafa 100644 --- a/compiler/vectorise/Vectorise/Type/Env.hs +++ b/compiler/vectorise/Vectorise/Type/Env.hs @@ -323,7 +323,9 @@ vectTypeEnv tycons vectTypeDecls vectClassDecls addParallelTyConAndCons tycon = do { addGlobalParallelTyCon tycon - ; mapM_ addGlobalParallelVar . concatMap dataConImplicitIds . tyConDataCons $ tycon + ; mapM_ addGlobalParallelVar [ id | dc <- tyConDataCons tycon + , AnId id <- dataConImplicitTyThings dc ] + -- Ignoring the promoted tycon; hope that's ok } -- Add a mapping from the original to vectorised type constructor to the vectorisation map. diff --git a/compiler/vectorise/Vectorise/Type/TyConDecl.hs b/compiler/vectorise/Vectorise/Type/TyConDecl.hs index 910aba473a..40f28d18d8 100644 --- a/compiler/vectorise/Vectorise/Type/TyConDecl.hs +++ b/compiler/vectorise/Vectorise/Type/TyConDecl.hs @@ -7,6 +7,7 @@ import Vectorise.Type.Type import Vectorise.Monad import Vectorise.Env( GlobalEnv( global_fam_inst_env ) ) import BuildTyCl( buildClass, buildDataCon ) +import OccName import Class import Type import TyCon @@ -98,6 +99,7 @@ vectTyConDecl tycon name' gadt_flag = isGadtSyntaxTyCon tycon -- build the vectorised type constructor + ; tc_rep_name <- mkDerivedName mkTyConRepUserOcc name' ; return $ buildAlgTyCon name' -- new name (tyConTyVars tycon) -- keep original type vars @@ -108,7 +110,7 @@ vectTyConDecl tycon name' rec_flag -- whether recursive False -- Not promotable gadt_flag -- whether in GADT syntax - NoParentTyCon + (VanillaAlgTyCon tc_rep_name) } -- some other crazy thing that we don't handle @@ -135,8 +137,6 @@ vectAlgTyConRhs :: TyCon -> AlgTyConRhs -> VM AlgTyConRhs vectAlgTyConRhs tc (AbstractTyCon {}) = do dflags <- getDynFlags cantVectorise dflags "Can't vectorise imported abstract type" (ppr tc) -vectAlgTyConRhs _tc DataFamilyTyCon - = return DataFamilyTyCon vectAlgTyConRhs _tc (DataTyCon { data_cons = data_cons , is_enum = is_enum }) @@ -184,6 +184,7 @@ vectDataCon dc ; liftDs $ buildDataCon fam_envs name' (dataConIsInfix dc) -- infix if the original is + NotPromoted -- Vectorised type is not promotable (dataConSrcBangs dc) -- strictness as original constructor (Just $ dataConImplBangs dc) [] -- no labelled fields for now diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs index 736b8a957e..1153afa414 100644 --- a/ghc/InteractiveUI.hs +++ b/ghc/InteractiveUI.hs @@ -1342,7 +1342,7 @@ defineMacro overwrite s = do step <- getGhciStepIO expr <- GHC.parseExpr definition -- > ghciStepIO . definition :: String -> IO String - let stringTy = nlHsTyVar $ getRdrName stringTyConName + let stringTy = nlHsTyVar stringTy_RDR ioM = nlHsTyVar (getRdrName ioTyConName) `nlHsAppTy` stringTy body = nlHsVar compose_RDR `mkHsApp` step `mkHsApp` expr tySig = stringTy `nlHsFunTy` ioM @@ -1392,7 +1392,7 @@ cmdCmd str = handleSourceError GHC.printException $ do getGhciStepIO :: GHCi (LHsExpr RdrName) getGhciStepIO = do ghciTyConName <- GHC.getGHCiMonad - let stringTy = nlHsTyVar $ getRdrName stringTyConName + let stringTy = nlHsTyVar stringTy_RDR ghciM = nlHsTyVar (getRdrName ghciTyConName) `nlHsAppTy` stringTy ioM = nlHsTyVar (getRdrName ioTyConName) `nlHsAppTy` stringTy body = nlHsVar (getRdrName ghciStepIoMName) diff --git a/libraries/base/Data/Typeable.hs b/libraries/base/Data/Typeable.hs index c30a43dd65..1afc6a9563 100644 --- a/libraries/base/Data/Typeable.hs +++ b/libraries/base/Data/Typeable.hs @@ -58,7 +58,7 @@ module Data.Typeable -- * A canonical proxy type Proxy (..), - + -- * Type representations TypeRep, -- abstract, instance of: Eq, Show, Typeable typeRepFingerprint, @@ -66,6 +66,7 @@ module Data.Typeable showsTypeRep, TyCon, -- abstract, instance of: Eq, Show, Typeable + -- For now don't export Module, to avoid name clashes tyConFingerprint, tyConString, tyConPackage, @@ -87,7 +88,7 @@ module Data.Typeable typeRepArgs, -- :: TypeRep -> [TypeRep] ) where -import Data.Typeable.Internal hiding (mkTyCon) +import Data.Typeable.Internal import Data.Type.Equality import Unsafe.Coerce diff --git a/libraries/base/Data/Typeable/Internal.hs b/libraries/base/Data/Typeable/Internal.hs index e35d794a62..4379155c57 100644 --- a/libraries/base/Data/Typeable/Internal.hs +++ b/libraries/base/Data/Typeable/Internal.hs @@ -25,15 +25,34 @@ module Data.Typeable.Internal ( Proxy (..), - TypeRep(..), - KindRep, Fingerprint(..), + + -- * Typeable class typeOf, typeOf1, typeOf2, typeOf3, typeOf4, typeOf5, typeOf6, typeOf7, Typeable1, Typeable2, Typeable3, Typeable4, Typeable5, Typeable6, Typeable7, - TyCon(..), + + -- * Module + Module, -- Abstract + moduleName, modulePackage, + + -- * TyCon + TyCon, -- Abstract + tyConPackage, tyConModule, tyConName, tyConString, tyConFingerprint, + mkTyCon3, mkTyCon3#, + rnfTyCon, + + tcBool, tc'True, tc'False, + tcOrdering, tc'LT, tc'EQ, tc'GT, + tcChar, tcInt, tcWord, tcFloat, tcDouble, tcFun, + tcIO, tcSPEC, tcTyCon, tcModule, + tcCoercible, tcList, tcEq, + tcLiftedKind, tcUnliftedKind, tcOpenKind, tcBOX, tcConstraint, tcAnyK, + + funTc, -- ToDo + + -- * TypeRep + TypeRep(..), KindRep, typeRep, - mkTyCon, - mkTyCon3, mkTyConApp, mkPolyTyConApp, mkAppTy, @@ -47,19 +66,15 @@ module Data.Typeable.Internal ( typeRepFingerprint, rnfTypeRep, showsTypeRep, - tyConString, - rnfTyCon, - listTc, funTc, typeRepKinds, - typeNatTypeRep, - typeSymbolTypeRep + typeSymbolTypeRep, typeNatTypeRep ) where import GHC.Base import GHC.Word import GHC.Show -import GHC.TypeLits import Data.Proxy +import GHC.TypeLits( KnownNat, KnownSymbol, natVal', symbolVal' ) import GHC.Fingerprint.Type import {-# SOURCE #-} GHC.Fingerprint @@ -68,9 +83,106 @@ import {-# SOURCE #-} GHC.Fingerprint -- of Data.Typeable as much as possible so we can optimise the derived -- instances. --- | A concrete representation of a (monomorphic) type. 'TypeRep' --- supports reasonably efficient equality. +#include "MachDeps.h" + +{- ********************************************************************* +* * + The TyCon type +* * +********************************************************************* -} + +modulePackage :: Module -> String +modulePackage (Module p _) = trNameString p + +moduleName :: Module -> String +moduleName (Module _ m) = trNameString m + +tyConPackage :: TyCon -> String +tyConPackage (TyCon _ _ m _) = modulePackage m + +tyConModule :: TyCon -> String +tyConModule (TyCon _ _ m _) = moduleName m + +tyConName :: TyCon -> String +tyConName (TyCon _ _ _ n) = trNameString n + +trNameString :: TrName -> String +trNameString (TrNameS s) = unpackCString# s +trNameString (TrNameD s) = s + +-- | Observe string encoding of a type representation +{-# DEPRECATED tyConString "renamed to 'tyConName'; 'tyConModule' and 'tyConPackage' are also available." #-} +-- deprecated in 7.4 +tyConString :: TyCon -> String +tyConString = tyConName + +tyConFingerprint :: TyCon -> Fingerprint +tyConFingerprint (TyCon hi lo _ _) + = Fingerprint (W64# hi) (W64# lo) + +mkTyCon3# :: Addr# -- ^ package name + -> Addr# -- ^ module name + -> Addr# -- ^ the name of the type constructor + -> TyCon -- ^ A unique 'TyCon' object +mkTyCon3# pkg modl name + | Fingerprint (W64# hi) (W64# lo) <- fingerprint + = TyCon hi lo (Module (TrNameS pkg) (TrNameS modl)) (TrNameS name) + where + fingerprint :: Fingerprint + fingerprint = fingerprintString (unpackCString# pkg + ++ (' ': unpackCString# modl) + ++ (' ' : unpackCString# name)) + +mkTyCon3 :: String -- ^ package name + -> String -- ^ module name + -> String -- ^ the name of the type constructor + -> TyCon -- ^ A unique 'TyCon' object +-- Used when the strings are dynamically allocated, +-- eg from binary deserialisation +mkTyCon3 pkg modl name + | Fingerprint (W64# hi) (W64# lo) <- fingerprint + = TyCon hi lo (Module (TrNameD pkg) (TrNameD modl)) (TrNameD name) + where + fingerprint :: Fingerprint + fingerprint = fingerprintString (pkg ++ (' ':modl) ++ (' ':name)) + +isTupleTyCon :: TyCon -> Bool +isTupleTyCon tc + | ('(':',':_) <- tyConName tc = True + | otherwise = False + +-- | Helper to fully evaluate 'TyCon' for use as @NFData(rnf)@ implementation +-- +-- @since 4.8.0.0 +rnfModule :: Module -> () +rnfModule (Module p m) = rnfTrName p `seq` rnfTrName m + +rnfTrName :: TrName -> () +rnfTrName (TrNameS _) = () +rnfTrName (TrNameD n) = rnfString n + +rnfTyCon :: TyCon -> () +rnfTyCon (TyCon _ _ m n) = rnfModule m `seq` rnfTrName n + +rnfString :: [Char] -> () +rnfString [] = () +rnfString (c:cs) = c `seq` rnfString cs + + +{- ********************************************************************* +* * + The TypeRep type +* * +********************************************************************* -} + +-- | A concrete representation of a (monomorphic) type. +-- 'TypeRep' supports reasonably efficient equality. data TypeRep = TypeRep {-# UNPACK #-} !Fingerprint TyCon [KindRep] [TypeRep] + -- NB: For now I've made this lazy so that it's easy to + -- optimise code that constructs and deconstructs TypeReps + -- perf/should_run/T9203 is a good example + -- Also note that mkAppTy does discards the fingerprint, + -- so it's a waste to compute it type KindRep = TypeRep @@ -81,56 +193,42 @@ instance Eq TypeRep where instance Ord TypeRep where TypeRep x _ _ _ <= TypeRep y _ _ _ = x <= y +-- | Observe the 'Fingerprint' of a type representation +-- +-- @since 4.8.0.0 +typeRepFingerprint :: TypeRep -> Fingerprint +typeRepFingerprint (TypeRep fpr _ _ _) = fpr --- | An abstract representation of a type constructor. 'TyCon' objects can --- be built using 'mkTyCon'. -data TyCon = TyCon { - tyConFingerprint :: {-# UNPACK #-} !Fingerprint, -- ^ @since 4.8.0.0 - tyConPackage :: String, -- ^ @since 4.5.0.0 - tyConModule :: String, -- ^ @since 4.5.0.0 - tyConName :: String -- ^ @since 4.5.0.0 - } - -instance Eq TyCon where - (TyCon t1 _ _ _) == (TyCon t2 _ _ _) = t1 == t2 - -instance Ord TyCon where - (TyCon k1 _ _ _) <= (TyCon k2 _ _ _) = k1 <= k2 - ------------------ Construction -------------------- - -#include "MachDeps.h" - --- mkTyCon is an internal function to make it easier for GHC to --- generate derived instances. GHC precomputes the MD5 hash for the --- TyCon and passes it as two separate 64-bit values to mkTyCon. The --- TyCon for a derived Typeable instance will end up being statically --- allocated. - -#if WORD_SIZE_IN_BITS < 64 -mkTyCon :: Word64# -> Word64# -> String -> String -> String -> TyCon -#else -mkTyCon :: Word# -> Word# -> String -> String -> String -> TyCon -#endif -mkTyCon high# low# pkg modl name - = TyCon (Fingerprint (W64# high#) (W64# low#)) pkg modl name - --- | Applies a polymorhic type constructor to a sequence of kinds and types +-- | Applies a kind-polymorphic type constructor to a sequence of kinds and +-- types mkPolyTyConApp :: TyCon -> [KindRep] -> [TypeRep] -> TypeRep -mkPolyTyConApp tc@(TyCon tc_k _ _ _) [] [] = TypeRep tc_k tc [] [] -mkPolyTyConApp tc@(TyCon tc_k _ _ _) kinds types = - TypeRep (fingerprintFingerprints (tc_k : arg_ks)) tc kinds types +{-# INLINE mkPolyTyConApp #-} +mkPolyTyConApp tc kinds types + = TypeRep (fingerprintFingerprints sub_fps) tc kinds types where - arg_ks = [ k | TypeRep k _ _ _ <- kinds ++ types ] + !kt_fps = typeRepFingerprints kinds types + sub_fps = tyConFingerprint tc : kt_fps --- | Applies a monomorphic type constructor to a sequence of types +typeRepFingerprints :: [KindRep] -> [TypeRep] -> [Fingerprint] +-- Builds no thunks +typeRepFingerprints kinds types + = go1 [] kinds + where + go1 acc [] = go2 acc types + go1 acc (k:ks) = let !fp = typeRepFingerprint k + in go1 (fp:acc) ks + go2 acc [] = acc + go2 acc (t:ts) = let !fp = typeRepFingerprint t + in go2 (fp:acc) ts + +-- | Applies a kind-monomorphic type constructor to a sequence of types mkTyConApp :: TyCon -> [TypeRep] -> TypeRep mkTyConApp tc = mkPolyTyConApp tc [] -- | A special case of 'mkTyConApp', which applies the function -- type constructor to a pair of types. mkFunTy :: TypeRep -> TypeRep -> TypeRep -mkFunTy f a = mkTyConApp funTc [f,a] +mkFunTy f a = mkTyConApp tcFun [f,a] -- | Splits a type constructor application. -- Note that if the type construcotr is polymorphic, this will @@ -150,11 +248,12 @@ splitPolyTyConApp (TypeRep _ tc ks trs) = (tc,ks,trs) funResultTy :: TypeRep -> TypeRep -> Maybe TypeRep funResultTy trFun trArg = case splitTyConApp trFun of - (tc, [t1,t2]) | tc == funTc && t1 == trArg -> Just t2 + (tc, [t1,t2]) | tc == tcFun && t1 == trArg -> Just t2 _ -> Nothing -- | Adds a TypeRep argument to a TypeRep. mkAppTy :: TypeRep -> TypeRep -> TypeRep +{-# INLINE mkAppTy #-} mkAppTy (TypeRep _ tc ks trs) arg_tr = mkPolyTyConApp tc ks (trs ++ [arg_tr]) -- Notice that we call mkTyConApp to construct the fingerprint from tc and -- the arg fingerprints. Simply combining the current fingerprint with @@ -162,20 +261,6 @@ mkAppTy (TypeRep _ tc ks trs) arg_tr = mkPolyTyConApp tc ks (trs ++ [arg_tr]) -- ensure that a TypeRep of the same shape has the same fingerprint! -- See Trac #5962 --- | Builds a 'TyCon' object representing a type constructor. An --- implementation of "Data.Typeable" should ensure that the following holds: --- --- > A==A' ^ B==B' ^ C==C' ==> mkTyCon A B C == mkTyCon A' B' C' --- - --- -mkTyCon3 :: String -- ^ package name - -> String -- ^ module name - -> String -- ^ the name of the type constructor - -> TyCon -- ^ A unique 'TyCon' object -mkTyCon3 pkg modl name = - TyCon (fingerprintString (pkg ++ (' ':modl) ++ (' ':name))) pkg modl name - ----------------- Observation --------------------- -- | Observe the type constructor of a type representation @@ -190,16 +275,12 @@ typeRepArgs (TypeRep _ _ _ tys) = tys typeRepKinds :: TypeRep -> [KindRep] typeRepKinds (TypeRep _ _ ks _) = ks --- | Observe string encoding of a type representation -{-# DEPRECATED tyConString "renamed to 'tyConName'; 'tyConModule' and 'tyConPackage' are also available." #-} -- deprecated in 7.4 -tyConString :: TyCon -> String -tyConString = tyConName --- | Observe the 'Fingerprint' of a type representation --- --- @since 4.8.0.0 -typeRepFingerprint :: TypeRep -> Fingerprint -typeRepFingerprint (TypeRep fpr _ _ _) = fpr +{- ********************************************************************* +* * + The Typeable class +* * +********************************************************************* -} ------------------------------------------------------------- -- @@ -273,8 +354,8 @@ instance Show TypeRep where showsPrec p (TypeRep _ tycon kinds tys) = case tys of [] -> showsPrec p tycon - [x] | tycon == listTc -> showChar '[' . shows x . showChar ']' - [a,r] | tycon == funTc -> showParen (p > 8) $ + [x] | tycon == tcList -> showChar '[' . shows x . showChar ']' + [a,r] | tycon == tcFun -> showParen (p > 8) $ showsPrec 9 a . showString " -> " . showsPrec 8 r @@ -288,13 +369,6 @@ instance Show TypeRep where showsTypeRep :: TypeRep -> ShowS showsTypeRep = shows -instance Show TyCon where - showsPrec _ t = showString (tyConName t) - -isTupleTyCon :: TyCon -> Bool -isTupleTyCon (TyCon _ _ _ ('(':',':_)) = True -isTupleTyCon _ = False - -- | Helper to fully evaluate 'TypeRep' for use as @NFData(rnf)@ implementation -- -- @since 4.8.0.0 @@ -304,15 +378,6 @@ rnfTypeRep (TypeRep _ tyc krs tyrs) = rnfTyCon tyc `seq` go krs `seq` go tyrs go [] = () go (x:xs) = rnfTypeRep x `seq` go xs --- | Helper to fully evaluate 'TyCon' for use as @NFData(rnf)@ implementation --- --- @since 4.8.0.0 -rnfTyCon :: TyCon -> () -rnfTyCon (TyCon _ tcp tcm tcn) = go tcp `seq` go tcm `seq` go tcn - where - go [] = () - go (x:xs) = x `seq` go xs - -- Some (Show.TypeRep) helpers: showArgs :: Show a => ShowS -> [a] -> ShowS @@ -325,13 +390,68 @@ showTuple args = showChar '(' . showArgs (showChar ',') args . showChar ')' -listTc :: TyCon -listTc = typeRepTyCon (typeOf [()]) +{- ********************************************************* +* * +* TyCon definitions for GHC.Types * +* * +********************************************************* -} + +mkGhcTypesTyCon :: Addr# -> TyCon +{-# INLINE mkGhcTypesTyCon #-} +mkGhcTypesTyCon name = mkTyCon3# "ghc-prim"# "GHC.Types"# name + +tcBool, tc'True, tc'False, + tcOrdering, tc'GT, tc'EQ, tc'LT, + tcChar, tcInt, tcWord, tcFloat, tcDouble, tcFun, + tcIO, tcSPEC, tcTyCon, tcModule, + tcCoercible, tcEq, tcList :: TyCon + +tcBool = mkGhcTypesTyCon "Bool"# -- Bool is promotable +tc'True = mkGhcTypesTyCon "'True"# +tc'False = mkGhcTypesTyCon "'False"# +tcOrdering = mkGhcTypesTyCon "Ordering"# -- Ordering is promotable +tc'GT = mkGhcTypesTyCon "'GT"# +tc'EQ = mkGhcTypesTyCon "'EQ"# +tc'LT = mkGhcTypesTyCon "'LT"# + +-- None of the rest are promotable (see TysWiredIn) +tcChar = mkGhcTypesTyCon "Char"# +tcInt = mkGhcTypesTyCon "Int"# +tcWord = mkGhcTypesTyCon "Word"# +tcFloat = mkGhcTypesTyCon "Float"# +tcDouble = mkGhcTypesTyCon "Double"# +tcSPEC = mkGhcTypesTyCon "SPEC"# +tcIO = mkGhcTypesTyCon "IO"# +tcTyCon = mkGhcTypesTyCon "TyCon"# +tcModule = mkGhcTypesTyCon "Module"# +tcCoercible = mkGhcTypesTyCon "Coercible"# + +tcFun = mkGhcTypesTyCon "->"# +tcList = mkGhcTypesTyCon "[]"# -- Type rep for the list type constructor +tcEq = mkGhcTypesTyCon "~"# -- Type rep for the (~) type constructor + +tcLiftedKind, tcUnliftedKind, tcOpenKind, tcBOX, tcConstraint, tcAnyK :: TyCon +tcLiftedKind = mkGhcTypesTyCon "*"# +tcUnliftedKind = mkGhcTypesTyCon "#"# +tcOpenKind = mkGhcTypesTyCon "#"# +tcBOX = mkGhcTypesTyCon "BOX"# +tcAnyK = mkGhcTypesTyCon "AnyK"# +tcConstraint = mkGhcTypesTyCon "Constraint"# funTc :: TyCon -funTc = typeRepTyCon (typeRep (Proxy :: Proxy (->))) +funTc = tcFun -- Legacy + +{- ********************************************************* +* * +* TyCon/TypeRep definitions for type literals * +* (Symbol and Nat) * +* * +********************************************************* -} +mkTypeLitTyCon :: String -> TyCon +mkTypeLitTyCon name = mkTyCon3 "base" "GHC.TypeLits" name + -- | Used to make `'Typeable' instance for things of kind Nat typeNatTypeRep :: KnownNat a => Proxy# a -> TypeRep typeNatTypeRep p = typeLitTypeRep (show (natVal' p)) @@ -342,17 +462,5 @@ typeSymbolTypeRep p = typeLitTypeRep (show (symbolVal' p)) -- | An internal function, to make representations for type literals. typeLitTypeRep :: String -> TypeRep -typeLitTypeRep nm = rep - where - rep = mkTyConApp tc [] - tc = TyCon - { tyConFingerprint = fingerprintString (mk pack modu nm) - , tyConPackage = pack - , tyConModule = modu - , tyConName = nm - } - pack = "base" - modu = "GHC.TypeLits" - mk a b c = a ++ " " ++ b ++ " " ++ c - +typeLitTypeRep nm = mkTyConApp (mkTypeLitTyCon nm) [] diff --git a/libraries/base/GHC/Show.hs b/libraries/base/GHC/Show.hs index 4aeecb15f3..879d666bb0 100644 --- a/libraries/base/GHC/Show.hs +++ b/libraries/base/GHC/Show.hs @@ -194,6 +194,16 @@ showWord w# cs deriving instance Show a => Show (Maybe a) +instance Show TyCon where + showsPrec p (TyCon _ _ _ tc_name) = showsPrec p tc_name + +instance Show TrName where + showsPrec _ (TrNameS s) = showString (unpackCString# s) + showsPrec _ (TrNameD s) = showString s + +instance Show Module where + showsPrec _ (Module p m) = shows p . (':' :) . shows m + -------------------------------------------------------------- -- Show instances for the first few tuple -------------------------------------------------------------- diff --git a/libraries/base/GHC/Stack/Types.hs b/libraries/base/GHC/Stack/Types.hs index 5c37f64713..d3ea1d2147 100644 --- a/libraries/base/GHC/Stack/Types.hs +++ b/libraries/base/GHC/Stack/Types.hs @@ -21,6 +21,19 @@ module GHC.Stack.Types ( SrcLoc(..), CallStack(..), ) where +{- +Ideally these would live in GHC.Stack but sadly they can't due to this +import cycle, + + Module imports form a cycle: + module ‘Data.Maybe’ (libraries/base/Data/Maybe.hs) + imports ‘GHC.Base’ (libraries/base/GHC/Base.hs) + which imports ‘GHC.Err’ (libraries/base/GHC/Err.hs) + which imports ‘GHC.Stack’ (libraries/base/dist-install/build/GHC/Stack.hs) + which imports ‘GHC.Foreign’ (libraries/base/GHC/Foreign.hs) + which imports ‘Data.Maybe’ (libraries/base/Data/Maybe.hs) +-} + import GHC.Types -- Make implicit dependency known to build system diff --git a/libraries/ghc-prim/GHC/Classes.hs b/libraries/ghc-prim/GHC/Classes.hs index 18662ad539..12fe65f322 100644 --- a/libraries/ghc-prim/GHC/Classes.hs +++ b/libraries/ghc-prim/GHC/Classes.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP, Trustworthy #-} {-# LANGUAGE NoImplicitPrelude, MagicHash, StandaloneDeriving, BangPatterns, KindSignatures, DataKinds, ConstraintKinds, MultiParamTypeClasses, FunctionalDependencies #-} @@ -28,19 +28,28 @@ ----------------------------------------------------------------------------- module GHC.Classes( + -- * Implicit paramaters IP(..), + + -- * Equality and ordering Eq(..), eqInt, neInt, Ord(..), gtInt, geInt, leInt, ltInt, compareInt, compareInt#, + + -- * Functions over Bool (&&), (||), not, + + -- * Integer arithmetic divInt#, modInt# ) where -- GHC.Magic is used in some derived instances import GHC.Magic () +import GHC.IntWord64 import GHC.Prim import GHC.Tuple import GHC.Types +#include "MachDeps.h" infix 4 ==, /=, <, <=, >=, > infixr 3 && @@ -137,6 +146,31 @@ eqInt, neInt :: Int -> Int -> Bool (I# x) `eqInt` (I# y) = isTrue# (x ==# y) (I# x) `neInt` (I# y) = isTrue# (x /=# y) +#if WORD_SIZE_IN_BITS < 64 +instance Eq TyCon where + (==) (TyCon hi1 lo1 _ _) (TyCon hi2 lo2 _ _) + = isTrue# (hi1 `eqWord64#` hi2) && isTrue# (lo1 `eqWord64#` lo2) +instance Ord TyCon where + compare (TyCon hi1 lo1 _ _) (TyCon hi2 lo2 _ _) + | isTrue# (hi1 `gtWord64#` hi2) = GT + | isTrue# (hi1 `ltWord64#` hi2) = LT + | isTrue# (lo1 `gtWord64#` lo2) = GT + | isTrue# (lo1 `ltWord64#` lo2) = LT + | True = EQ +#else +instance Eq TyCon where + (==) (TyCon hi1 lo1 _ _) (TyCon hi2 lo2 _ _) + = isTrue# (hi1 `eqWord#` hi2) && isTrue# (lo1 `eqWord#` lo2) +instance Ord TyCon where + compare (TyCon hi1 lo1 _ _) (TyCon hi2 lo2 _ _) + | isTrue# (hi1 `gtWord#` hi2) = GT + | isTrue# (hi1 `ltWord#` hi2) = LT + | isTrue# (lo1 `gtWord#` lo2) = GT + | isTrue# (lo1 `ltWord#` lo2) = LT + | True = EQ +#endif + + -- | The 'Ord' class is used for totally ordered datatypes. -- -- Instances of 'Ord' can be derived for any user-defined diff --git a/libraries/ghc-prim/GHC/Magic.hs b/libraries/ghc-prim/GHC/Magic.hs index 22db69f2ae..740abb729e 100644 --- a/libraries/ghc-prim/GHC/Magic.hs +++ b/libraries/ghc-prim/GHC/Magic.hs @@ -19,6 +19,8 @@ module GHC.Magic ( inline, lazy, oneShot ) where +import GHC.CString () + -- | The call @inline f@ arranges that 'f' is inlined, regardless of -- its size. More precisely, the call @inline f@ rewrites to the -- right-hand side of @f@'s definition. This allows the programmer to diff --git a/libraries/ghc-prim/GHC/Tuple.hs b/libraries/ghc-prim/GHC/Tuple.hs index 4ebda15d84..b08d0b4fee 100644 --- a/libraries/ghc-prim/GHC/Tuple.hs +++ b/libraries/ghc-prim/GHC/Tuple.hs @@ -16,6 +16,9 @@ module GHC.Tuple where +import GHC.CString () -- Make sure we do it first, so that the + -- implicit Typeable stuff can see GHC.Types.TyCon + -- and unpackCString# etc default () -- Double and Integer aren't available yet diff --git a/libraries/ghc-prim/GHC/Types.hs b/libraries/ghc-prim/GHC/Types.hs index 294f15e6e4..63b4f0508f 100644 --- a/libraries/ghc-prim/GHC/Types.hs +++ b/libraries/ghc-prim/GHC/Types.hs @@ -1,5 +1,5 @@ {-# LANGUAGE MagicHash, NoImplicitPrelude, TypeFamilies, UnboxedTuples, - MultiParamTypeClasses, RoleAnnotations #-} + MultiParamTypeClasses, RoleAnnotations, CPP #-} ----------------------------------------------------------------------------- -- | -- Module : GHC.Types @@ -29,11 +29,12 @@ module GHC.Types ( isTrue#, SPEC(..), Nat, Symbol, - Coercible + Coercible, + -- * Runtime type representation + Module(..), TrName(..), TyCon(..) ) where import GHC.Prim -import GHC.Tuple () infixr 5 : @@ -308,3 +309,56 @@ you're reading this in 2023 then things went wrong). See #8326. -- Libraries can specify this by using 'SPEC' data type to inform which -- loops should be aggressively specialized. data SPEC = SPEC | SPEC2 + +{- ********************************************************************* +* * + Runtime represntation of TyCon +* * +********************************************************************* -} + +{- Note [Runtime representation of modules and tycons] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We generate a binding for M.$modName and M.$tcT for every module M and +data type T. Things to think about + + - We want them to be economical on space; ideally pure data with no thunks. + + - We do this for every module (except this module GHC.Types), so we can't + depend on anything else (eg string unpacking code) + +That's why we have these terribly low-level repesentations. The TrName +type lets us use the TrNameS constructor when allocating static data; +but we also need TrNameD for the case where we are deserialising a TyCon +or Module (for example when deserialising a TypeRep), in which case we +can't conveniently come up with an Addr#. + + +Note [Representations of types defined in GHC.Types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The representations for the types defined in GHC.Types are +defined in GHC.Typeable.Internal. + +-} + +#include "MachDeps.h" + +data Module = Module + TrName -- Package name + TrName -- Module name + +data TrName + = TrNameS Addr# -- Static + | TrNameD [Char] -- Dynamic + +#if WORD_SIZE_IN_BITS < 64 +data TyCon = TyCon + Word64# Word64# -- Fingerprint + Module -- Module in which this is defined + TrName -- Type constructor name +#else +data TyCon = TyCon + Word# Word# + Module + TrName +#endif diff --git a/testsuite/tests/codeGen/should_run/cgrun057.stderr b/testsuite/tests/codeGen/should_run/cgrun057.stderr index 64a4028b02..262d74912d 100644 --- a/testsuite/tests/codeGen/should_run/cgrun057.stderr +++ b/testsuite/tests/codeGen/should_run/cgrun057.stderr @@ -1,4 +1,4 @@ -*** Exception (reporting due to +RTS -xc): (THUNK_1_0), stack trace: +*** Exception (reporting due to +RTS -xc): (THUNK_2_0), stack trace: Main.g, called from Main.f, called from Main.main, diff --git a/testsuite/tests/deSugar/should_compile/T2431.stderr b/testsuite/tests/deSugar/should_compile/T2431.stderr index cd14bd1754..b4aa53d787 100644 --- a/testsuite/tests/deSugar/should_compile/T2431.stderr +++ b/testsuite/tests/deSugar/should_compile/T2431.stderr @@ -1,6 +1,6 @@ ==================== Tidy Core ==================== -Result size of Tidy Core = {terms: 8, types: 19, coercions: 1} +Result size of Tidy Core = {terms: 27, types: 24, coercions: 1} -- RHS size: {terms: 2, types: 3, coercions: 1} T2431.$WRefl [InlPrag=INLINE] :: forall a. a :~: a @@ -13,10 +13,35 @@ T2431.$WRefl [InlPrag=INLINE] :: forall a. a :~: a Tmpl= \ (@ a) -> T2431.Refl @ a @ a @~ (<a>_N :: a ~# a)}] T2431.$WRefl = \ (@ a) -> T2431.Refl @ a @ a @~ (<a>_N :: a ~# a) +-- RHS size: {terms: 2, types: 0, coercions: 0} +a :: TrName +[GblId, Caf=NoCafRefs, Str=DmdType] +a = TrNameS "main"# + +-- RHS size: {terms: 2, types: 0, coercions: 0} +a1 :: TrName +[GblId, Caf=NoCafRefs, Str=DmdType] +a1 = TrNameS "T2431"# + +-- RHS size: {terms: 3, types: 0, coercions: 0} +T2431.$trModule :: Module +[GblId[ReflectionId], Caf=NoCafRefs, Str=DmdType] +T2431.$trModule = Module a a1 + +-- RHS size: {terms: 2, types: 0, coercions: 0} +a2 :: TrName +[GblId, Caf=NoCafRefs, Str=DmdType] +a2 = TrNameS ":~:"# + +-- RHS size: {terms: 5, types: 0, coercions: 0} +T2431.$tc:~: :: TyCon +[GblId[ReflectionId], Caf=NoCafRefs, Str=DmdType] +T2431.$tc:~: = TyCon 0## 0## T2431.$trModule a2 + -- RHS size: {terms: 4, types: 7, coercions: 0} absurd :: forall a. Int :~: Bool -> a [GblId, Arity=1, Caf=NoCafRefs, Str=DmdType <L,U>b] -absurd = \ (@ a) (x :: Int :~: Bool) -> case x of _ [Occ=Dead] { } +absurd = \ (@ a3) (x :: Int :~: Bool) -> case x of _ [Occ=Dead] { } diff --git a/testsuite/tests/deriving/should_fail/T9687.stderr b/testsuite/tests/deriving/should_fail/T9687.stderr index ad95393db7..36425e48c8 100644 --- a/testsuite/tests/deriving/should_fail/T9687.stderr +++ b/testsuite/tests/deriving/should_fail/T9687.stderr @@ -1,3 +1,3 @@ -T9687.hs:4:10: - Class `Typeable` does not support user-specified instances. +T9687.hs:4:10: error: + Class ‘Typeable’ does not support user-specified instances diff --git a/testsuite/tests/ghci.debugger/scripts/T2740.stdout b/testsuite/tests/ghci.debugger/scripts/T2740.stdout index c6733bca9d..1f3e6d9ac5 100644 --- a/testsuite/tests/ghci.debugger/scripts/T2740.stdout +++ b/testsuite/tests/ghci.debugger/scripts/T2740.stdout @@ -1,5 +1,5 @@ Stopped at T2740.hs:(3,1)-(4,25) -_result :: a = _ +_result :: a2 = _ Stopped at T2740.hs:3:11-13 _result :: Bool = _ x :: Integer = 1 diff --git a/testsuite/tests/ghci.debugger/scripts/break006.stderr b/testsuite/tests/ghci.debugger/scripts/break006.stderr index b6e3cc9b12..56f40f2b21 100644 --- a/testsuite/tests/ghci.debugger/scripts/break006.stderr +++ b/testsuite/tests/ghci.debugger/scripts/break006.stderr @@ -12,7 +12,7 @@ Show (f a) => Show (Alt f a) -- Defined in ‘Data.Monoid’ - ...plus 33 others + ...plus 36 others (use -fprint-potential-instances to see them all) In a stmt of an interactive GHCi command: print it @@ -29,6 +29,6 @@ Show (f a) => Show (Alt f a) -- Defined in ‘Data.Monoid’ - ...plus 33 others + ...plus 36 others (use -fprint-potential-instances to see them all) In a stmt of an interactive GHCi command: print it diff --git a/testsuite/tests/ghci.debugger/scripts/break009.stdout b/testsuite/tests/ghci.debugger/scripts/break009.stdout index b926ed2474..14543668a1 100644 --- a/testsuite/tests/ghci.debugger/scripts/break009.stdout +++ b/testsuite/tests/ghci.debugger/scripts/break009.stdout @@ -1,6 +1,6 @@ Breakpoint 0 activated at ../Test6.hs:5:8-11 Stopped at ../Test6.hs:5:8-11 -_result :: a = _ +_result :: a2 = _ *** Exception: Prelude.head: empty list CallStack: - error, called at libraries/base/GHC/List.hs:1009:3 in base:GHC.List + error, called at libraries/base/GHC/List.hs:999:3 in base:GHC.List diff --git a/testsuite/tests/ghci.debugger/scripts/break010.stdout b/testsuite/tests/ghci.debugger/scripts/break010.stdout index 2751b6d160..682f4c3c1c 100644 --- a/testsuite/tests/ghci.debugger/scripts/break010.stdout +++ b/testsuite/tests/ghci.debugger/scripts/break010.stdout @@ -1,5 +1,5 @@ Breakpoint 0 activated at ../Test6.hs:5:8-11 Stopped at ../Test6.hs:5:8-11 -_result :: a = _ +_result :: a2 = _ Stopped at ../Test6.hs:5:8-11 -_result :: a = _ +_result :: a2 = _ diff --git a/testsuite/tests/ghci.debugger/scripts/break011.stdout b/testsuite/tests/ghci.debugger/scripts/break011.stdout index dafc1fc397..67bbec7ce1 100644 --- a/testsuite/tests/ghci.debugger/scripts/break011.stdout +++ b/testsuite/tests/ghci.debugger/scripts/break011.stdout @@ -9,12 +9,12 @@ _exception :: e = _ -2 : main (../Test7.hs:2:8-29) <end of history> Logged breakpoint at ../Test7.hs:2:18-28 -_result :: a12 +_result :: a14 Logged breakpoint at ../Test7.hs:2:8-29 -_result :: IO a12 +_result :: IO a14 no more logged breakpoints Logged breakpoint at ../Test7.hs:2:18-28 -_result :: a12 +_result :: a14 Stopped at <exception thrown> _exception :: e already at the beginning of the history @@ -23,7 +23,7 @@ _exception = SomeException "foo" "CallStack: error, called at ../Test7.hs:2:18 in main:Main") -_result :: a12 = _ +_result :: a14 = _ _exception :: SomeException = SomeException (ErrorCallWithLocation "foo" diff --git a/testsuite/tests/ghci.debugger/scripts/break012.stdout b/testsuite/tests/ghci.debugger/scripts/break012.stdout index 70fa0f37b9..88e8b3ee71 100644 --- a/testsuite/tests/ghci.debugger/scripts/break012.stdout +++ b/testsuite/tests/ghci.debugger/scripts/break012.stdout @@ -1,16 +1,16 @@ Stopped at break012.hs:(1,1)-(5,18) -_result :: (t, a1 -> a1, (), a -> a -> a) = _ +_result :: (t, a3 -> a3, (), a2 -> a2 -> a2) = _ Stopped at break012.hs:5:10-18 -_result :: (t, a1 -> a1, (), a -> a -> a) = _ +_result :: (t, a3 -> a3, (), a2 -> a2 -> a2) = _ a :: t = _ -b :: a2 -> a2 = _ +b :: a4 -> a4 = _ c :: () = _ -d :: a -> a -> a = _ +d :: a2 -> a2 -> a2 = _ a :: t -b :: a2 -> a2 +b :: a4 -> a4 c :: () -d :: a -> a -> a +d :: a2 -> a2 -> a2 a = (_t1::t) -b = (_t2::a2 -> a2) +b = (_t2::a4 -> a4) c = (_t3::()) -d = (_t4::a -> a -> a) +d = (_t4::a2 -> a2 -> a2) diff --git a/testsuite/tests/ghci.debugger/scripts/break018.stdout b/testsuite/tests/ghci.debugger/scripts/break018.stdout index a12e119a42..11ef5476b5 100644 --- a/testsuite/tests/ghci.debugger/scripts/break018.stdout +++ b/testsuite/tests/ghci.debugger/scripts/break018.stdout @@ -1,5 +1,5 @@ Stopped at ../mdo.hs:(30,1)-(32,27) -_result :: IO (N a) = _ +_result :: IO (N a6) = _ Stopped at ../mdo.hs:(30,16)-(32,27) _result :: IO (N Char) = _ x :: Char = 'h' @@ -10,4 +10,4 @@ f :: N Char = _ l :: N Char = _ x :: Char = 'h' Stopped at ../mdo.hs:(8,1)-(9,42) -_result :: IO (N a) = _ +_result :: IO (N a6) = _ diff --git a/testsuite/tests/ghci.debugger/scripts/break022/break022.stdout b/testsuite/tests/ghci.debugger/scripts/break022/break022.stdout index 99ac58dec2..a87ffce942 100644 --- a/testsuite/tests/ghci.debugger/scripts/break022/break022.stdout +++ b/testsuite/tests/ghci.debugger/scripts/break022/break022.stdout @@ -1,6 +1,6 @@ Breakpoint 0 activated at A.hs:4:1-9 Stopped at A.hs:4:1-9 -_result :: a1 = _ +_result :: a3 = _ Stopped at A.hs:4:7-9 _result :: () = _ x :: () = () diff --git a/testsuite/tests/ghci.debugger/scripts/break028.stdout b/testsuite/tests/ghci.debugger/scripts/break028.stdout index 2438d73a14..896a2416ef 100644 --- a/testsuite/tests/ghci.debugger/scripts/break028.stdout +++ b/testsuite/tests/ghci.debugger/scripts/break028.stdout @@ -1,5 +1,5 @@ Stopped at break028.hs:15:1-24 -_result :: Id a = _ +_result :: Id a3 = _ Stopped at break028.hs:15:23-24 -_result :: Id a = _ -x' :: Id a = _ +_result :: Id a3 = _ +x' :: Id a3 = _ diff --git a/testsuite/tests/ghci.debugger/scripts/print018.stdout b/testsuite/tests/ghci.debugger/scripts/print018.stdout index d5b7d4603c..a00d5374dd 100644 --- a/testsuite/tests/ghci.debugger/scripts/print018.stdout +++ b/testsuite/tests/ghci.debugger/scripts/print018.stdout @@ -3,9 +3,9 @@ Stopped at ../Test.hs:40:1-17 _result :: () = _ Stopped at ../Test.hs:40:10-17 _result :: () = _ -x :: a17 = _ -x = (_t1::a17) -x :: a17 +x :: a36 = _ +x = (_t1::a36) +x :: a36 () x = Unary x :: Unary diff --git a/testsuite/tests/ghci.debugger/scripts/print019.stderr b/testsuite/tests/ghci.debugger/scripts/print019.stderr index 894c553805..3c0edbde5a 100644 --- a/testsuite/tests/ghci.debugger/scripts/print019.stderr +++ b/testsuite/tests/ghci.debugger/scripts/print019.stderr @@ -5,9 +5,9 @@ Use :print or :force to determine these types Relevant bindings include it :: a1 (bound at <interactive>:10:1) These potential instances exist: - instance Show TyCon -- Defined in ‘Data.Typeable.Internal’ instance Show TypeRep -- Defined in ‘Data.Typeable.Internal’ + instance Show Module -- Defined in ‘GHC.Show’ instance Show Ordering -- Defined in ‘GHC.Show’ - ...plus 30 others + ...plus 32 others (use -fprint-potential-instances to see them all) In a stmt of an interactive GHCi command: print it diff --git a/testsuite/tests/ghci.debugger/scripts/print031.stdout b/testsuite/tests/ghci.debugger/scripts/print031.stdout index 529b6987b5..da3e14238d 100644 --- a/testsuite/tests/ghci.debugger/scripts/print031.stdout +++ b/testsuite/tests/ghci.debugger/scripts/print031.stdout @@ -4,5 +4,5 @@ Stopped at print031.hs:7:1-19 _result :: Bool = _ Stopped at print031.hs:7:7-19 _result :: Bool = _ -x :: t (Phantom a) = [Just (Phantom 1)] +x :: t (Phantom a5) = [Just (Phantom 1)] x = [Just (Phantom 1)] diff --git a/testsuite/tests/ghci/scripts/T4175.stdout b/testsuite/tests/ghci/scripts/T4175.stdout index 7c063a6481..cea9a01264 100644 --- a/testsuite/tests/ghci/scripts/T4175.stdout +++ b/testsuite/tests/ghci/scripts/T4175.stdout @@ -2,9 +2,7 @@ type family A a b :: * -- Defined at T4175.hs:7:1 type instance A (B a) b = () -- Defined at T4175.hs:10:1 type instance A (Maybe a) a = a -- Defined at T4175.hs:9:1 type instance A Int Int = () -- Defined at T4175.hs:8:1 -type role B nominal -data family B a - -- Defined at T4175.hs:12:1 +data family B a -- Defined at T4175.hs:12:1 instance G B -- Defined at T4175.hs:34:10 data instance B () = MkB -- Defined at T4175.hs:13:15 type instance A (B a) b = () -- Defined at T4175.hs:10:1 diff --git a/testsuite/tests/ghci/scripts/T5417.stdout b/testsuite/tests/ghci/scripts/T5417.stdout index 2640c4e04c..06329d9a1d 100644 --- a/testsuite/tests/ghci/scripts/T5417.stdout +++ b/testsuite/tests/ghci/scripts/T5417.stdout @@ -1,9 +1,7 @@ -data B1 a = B1 a
-data instance C.F (B1 a) = B2 a
-type role D nominal
-data family D a
-class C.C1 a where
- type role C.F nominal
- data family C.F a
- -- Defined at T5417a.hs:5:5
-data instance C.F (B1 a) = B2 a -- Defined at T5417.hs:8:10
+data B1 a = B1 a +data instance C.F (B1 a) = B2 a +data family D a +class C.C1 a where + data family C.F a + -- Defined at T5417a.hs:5:5 +data instance C.F (B1 a) = B2 a -- Defined at T5417.hs:8:10 diff --git a/testsuite/tests/ghci/scripts/T8674.stdout b/testsuite/tests/ghci/scripts/T8674.stdout index 6c13176e66..45d4f0af0e 100644 --- a/testsuite/tests/ghci/scripts/T8674.stdout +++ b/testsuite/tests/ghci/scripts/T8674.stdout @@ -1,5 +1,3 @@ -type role Sing nominal -data family Sing (a :: k) - -- Defined at T8674.hs:4:1 +data family Sing (a :: k) -- Defined at T8674.hs:4:1 data instance Sing Bool = SBool -- Defined at T8674.hs:6:15 data instance Sing a = SNil -- Defined at T8674.hs:5:15 diff --git a/testsuite/tests/indexed-types/should_compile/T3017.stderr b/testsuite/tests/indexed-types/should_compile/T3017.stderr index 2d2187c5a7..57e8b0d397 100644 --- a/testsuite/tests/indexed-types/should_compile/T3017.stderr +++ b/testsuite/tests/indexed-types/should_compile/T3017.stderr @@ -1,21 +1,21 @@ -TYPE SIGNATURES
- emptyL :: forall a. ListColl a
- test2 ::
- forall c t t1. (Num t, Num t1, Coll c, Elem c ~ (t, t1)) => c -> c
-TYPE CONSTRUCTORS
- class Coll c where
- type family Elem c :: * open
- empty :: c
- insert :: Elem c -> c -> c
- {-# MINIMAL empty, insert #-}
- data ListColl a = L [a]
- Promotable
-COERCION AXIOMS
- axiom Foo.TFCo:R:ElemListColl :: Elem (ListColl a) = a
-INSTANCES
- instance Coll (ListColl a) -- Defined at T3017.hs:12:11
-FAMILY INSTANCES
- type Elem (ListColl a)
-Dependent modules: []
-Dependent packages: [base-4.8.2.0, ghc-prim-0.4.0.0,
- integer-gmp-1.0.0.0]
+TYPE SIGNATURES + emptyL :: forall a. ListColl a + test2 :: + forall c t t1. (Num t, Num t1, Coll c, Elem c ~ (t, t1)) => c -> c +TYPE CONSTRUCTORS + class Coll c where + type family Elem c :: * open + empty :: c + insert :: Elem c -> c -> c + {-# MINIMAL empty, insert #-} + data ListColl a = L [a] + Promotable +COERCION AXIOMS + axiom Foo.TFCo:R:ElemListColl :: Elem (ListColl a) = a +INSTANCES + instance Coll (ListColl a) -- Defined at T3017.hs:12:11 +FAMILY INSTANCES + type Elem (ListColl a) +Dependent modules: [] +Dependent packages: [base-4.8.2.0, ghc-prim-0.4.0.0, + integer-gmp-1.0.0.0] diff --git a/testsuite/tests/numeric/should_compile/T7116.stdout b/testsuite/tests/numeric/should_compile/T7116.stdout index 6d4b412ba7..c9d744d6be 100644 --- a/testsuite/tests/numeric/should_compile/T7116.stdout +++ b/testsuite/tests/numeric/should_compile/T7116.stdout @@ -1,6 +1,33 @@ ==================== Tidy Core ==================== -Result size of Tidy Core = {terms: 22, types: 14, coercions: 0} +Result size of Tidy Core = {terms: 32, types: 17, coercions: 0} + +-- RHS size: {terms: 2, types: 0, coercions: 0} +T7116.$trModule2 :: TrName +[GblId, + Caf=NoCafRefs, + Str=DmdType m1, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 20}] +T7116.$trModule2 = TrNameS "main"# + +-- RHS size: {terms: 2, types: 0, coercions: 0} +T7116.$trModule1 :: TrName +[GblId, + Caf=NoCafRefs, + Str=DmdType m1, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 40 20}] +T7116.$trModule1 = TrNameS "T7116"# + +-- RHS size: {terms: 3, types: 0, coercions: 0} +T7116.$trModule :: Module +[GblId[ReflectionId], + Caf=NoCafRefs, + Str=DmdType m, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 30}] +T7116.$trModule = Module T7116.$trModule2 T7116.$trModule1 -- RHS size: {terms: 8, types: 3, coercions: 0} dr :: Double -> Double diff --git a/testsuite/tests/overloadedlists/should_fail/overloadedlistsfail01.stderr b/testsuite/tests/overloadedlists/should_fail/overloadedlistsfail01.stderr index 7faa9207a4..dbc250d794 100644 --- a/testsuite/tests/overloadedlists/should_fail/overloadedlistsfail01.stderr +++ b/testsuite/tests/overloadedlists/should_fail/overloadedlistsfail01.stderr @@ -5,9 +5,9 @@ overloadedlistsfail01.hs:5:8: error: Probable fix: use a type annotation to specify what ‘a0’ should be. These potential instances exist: instance [safe] Show Version -- Defined in ‘Data.Version’ + instance Show Module -- Defined in ‘GHC.Show’ instance Show Ordering -- Defined in ‘GHC.Show’ - instance Show Integer -- Defined in ‘GHC.Show’ - ...plus 23 others + ...plus 26 others (use -fprint-potential-instances to see them all) In the expression: print [1] In an equation for ‘main’: main = print [1] diff --git a/testsuite/tests/partial-sigs/should_compile/DataFamilyInstanceLHS.stderr b/testsuite/tests/partial-sigs/should_compile/DataFamilyInstanceLHS.stderr index 6ca37a9434..c2768c4d37 100644 --- a/testsuite/tests/partial-sigs/should_compile/DataFamilyInstanceLHS.stderr +++ b/testsuite/tests/partial-sigs/should_compile/DataFamilyInstanceLHS.stderr @@ -3,9 +3,7 @@ TYPE SIGNATURES TYPE CONSTRUCTORS data MyKind = A | B Promotable - type role Sing nominal data family Sing (a :: k) - RecFlag: Recursive COERCION AXIOMS axiom DataFamilyInstanceLHS.TFCo:R:SingMyKind_ :: Sing = DataFamilyInstanceLHS.R:SingMyKind_ diff --git a/testsuite/tests/perf/compiler/all.T b/testsuite/tests/perf/compiler/all.T index 9eb2d20aaa..2bd38f8b09 100644 --- a/testsuite/tests/perf/compiler/all.T +++ b/testsuite/tests/perf/compiler/all.T @@ -37,7 +37,7 @@ test('T1969', # 2013-02-10 14 (x86/OSX) # 2013-11-13 17 (x86/Windows, 64bit machine) # 2015-07-11 21 (x86/Linux, 64bit machine) use +RTS -G1 - (wordsize(64), 41, 20)]), + (wordsize(64), 55, 20)]), # 28 (amd64/Linux) # 34 (amd64/Linux) # 2012-09-20 23 (amd64/Linux) @@ -48,6 +48,7 @@ test('T1969', # 2013-09-11 30, 10 (amd64/Linux) # 2013-09-11 30, 15 (adapt to Phab CI) # 2015-06-03 41, (amd64/Linux) use +RTS -G1 + # 2015-10-28 55, (amd64/Linux) emit Typeable at definition site compiler_stats_num_field('max_bytes_used', [(platform('i386-unknown-mingw32'), 5719436, 20), # 2010-05-17 5717704 (x86/Windows) @@ -61,7 +62,7 @@ test('T1969', # 2014-01-22 6429864 (x86/Linux) # 2014-06-29 5949188 (x86/Linux) # 2015-07-11 6241108 (x86/Linux, 64bit machine) use +RTS -G1 - (wordsize(64), 11000000, 15)]), + (wordsize(64), 15017528, 15)]), # 2014-09-10 10463640, 10 # post-AMP-update (somewhat stabelish) # looks like the peak is around ~10M, but we're # unlikely to GC exactly on the peak. @@ -71,6 +72,7 @@ test('T1969', # 2014-09-14 9684256, 10 # try to lower it a bit more to match Phab's CI # 2014-11-03 10584344, # ghcspeed reports higher numbers consistently # 2015-07-11 11670120 (amd64/Linux) + # 2015-10-28 15017528 (amd64/Linux) emit typeable at definition site compiler_stats_num_field('bytes allocated', [(platform('i386-unknown-mingw32'), 301784492, 5), # 215582916 (x86/Windows) @@ -86,7 +88,7 @@ test('T1969', # 2014-01-22 316103268 (x86/Linux) # 2014-06-29 303300692 (x86/Linux) # 2015-07-11 288699104 (x86/Linux, 64-bit machine) use +RTS -G1 - (wordsize(64), 581460896, 5)]), + (wordsize(64), 737455896, 5)]), # 17/11/2009 434845560 (amd64/Linux) # 08/12/2009 459776680 (amd64/Linux) # 17/05/2010 519377728 (amd64/Linux) @@ -105,6 +107,7 @@ test('T1969', # 17/07/2014 651626680 (x86_64/Linux) roundabout update # 10/09/2014 630299456 (x86_64/Linux) post-AMP-cleanup # 03/06/2015 581460896 (x86_64/Linux) use +RTS -G1 + # 28/10/2015 737455896 (x86_64/Linux) emit Typeable at definition site only_ways(['normal']), extra_hc_opts('-dcore-lint -static'), @@ -142,7 +145,7 @@ test('T3294', # 2014-12-22 26525384 (x86/Windows) Increase due to silent superclasses? # 2015-07-11 43196344 (x86/Linux, 64-bit machine) use +RTS -G1 - (wordsize(64), 45000000, 20)]), + (wordsize(64), 96127384, 20)]), # prev: 25753192 (amd64/Linux) # 29/08/2012: 37724352 (amd64/Linux) # (increase due to new codegen, see #7198) @@ -156,6 +159,9 @@ test('T3294', # (reason unknown, setting expected value somewhere in between) # 2015-01-22: 45000000 (amd64/Linux) # varies between 40959592 and 52914488... increasing to +-20% + # 2015-10-28: 96127384 (amd64/Linux) + # D757: emit Typeable instances at site of type definition + # Opened #11030 to track this surprisingly large regression compiler_stats_num_field('bytes allocated', [(wordsize(32), 1377050640, 5), @@ -215,12 +221,13 @@ test('T4801', # 2014-01-22: 211198056 (x86/Linux) # 2014-09-03: 185242032 (Windows laptop) # 2014-12-01: 203962148 (Windows laptop) - (wordsize(64), 382056344, 10)]), + (wordsize(64), 434278248, 10)]), # prev: 360243576 (amd64/Linux) # 19/10/2012: 447190832 (amd64/Linux) (-fPIC turned on) # 19/10/2012: 392409984 (amd64/Linux) (-fPIC turned off) # 2014-04-08: 362939272 (amd64/Linux) cumulation of various smaller improvements over recent commits # 2014-10-08: 382056344 (amd64/Linux) stricter foldr2 488e95b + # 2015-10-28: 434278248 (amd64/Linux) emit Typeable at definition site ################################### # deactivated for now, as this metric became too volatile recently @@ -416,7 +423,7 @@ test('T783', # 2014-09-03: 223377364 (Windows) better specialisation, raft of core-to-core optimisations # 2014-12-22: 235002220 (Windows) not sure why - (wordsize(64), 470738808, 10)]), + (wordsize(64), 526230456, 10)]), # prev: 349263216 (amd64/Linux) # 07/08/2012: 384479856 (amd64/Linux) # 29/08/2012: 436927840 (amd64/Linux) @@ -429,16 +436,18 @@ test('T783', # (fix previous fix for #8456) # 2014-07-17: 640031840 (amd64/Linux) # (general round of updates) - # 2014-08-29: 441932632 (amd64/Linux) + # 2014-08-29: 441932632 (amd64/Linux) # (better specialisation, raft of core-to-core optimisations) - # 2014-08-29: 719814352 (amd64/Linux) - # (changed order of cmm block causes analyses to allocate much more, - # but the changed order is slighly better in terms of runtime, and - # this test seems to be an extreme outlier.) - # 2015-05-16: 548288760 (amd64/Linux) - # (improved sequenceBlocks in nativeCodeGen, #10422) - # 2015-08-07: 470738808 (amd64/Linux) - # (simplifying the switch plan code path for simple checks, #10677) + # 2014-08-29: 719814352 (amd64/Linux) + # (changed order of cmm block causes analyses to allocate much more, + # but the changed order is slighly better in terms of runtime, and + # this test seems to be an extreme outlier.) + # 2015-05-16: 548288760 (amd64/Linux) + # (improved sequenceBlocks in nativeCodeGen, #10422) + # 2015-08-07: 470738808 (amd64/Linux) + # (simplifying the switch plan code path for simple checks, #10677) + # 2015-08-28: 526230456 (amd64/Linux) + # (D757: Emit Typeable instances at site of type definition) extra_hc_opts('-static') ], compile,['']) @@ -477,7 +486,7 @@ test('T5321FD', # (increase due to new codegen) # 2014-07-31: 211699816 (Windows) (-11%) # (due to better optCoercion, 5e7406d9, #9233) - (wordsize(64), 470895536, 10)]) + (wordsize(64), 532365376, 10)]) # prev: 418306336 # 29/08/2012: 492905640 # (increase due to new codegen) @@ -494,6 +503,8 @@ test('T5321FD', # 2015-08-10: 470895536 # (undefined now takes an implicit parameter and GHC -O0 does # not recognize that the application is bottom) + # 2015-10-28: 532365376 + # D757: emit Typeable instances at site of type definition ], compile,['']) @@ -506,7 +517,7 @@ test('T5642', # 2014-09-03: 753045568 # 2014-12-10: 641085256 Improvements in constraints solver - (wordsize(64), 1282916024, 10)]) + (wordsize(64), 1412808976, 10)]) # prev: 1300000000 # 2014-07-17: 1358833928 (general round of updates) # 2014-08-07: 1402242360 (caused by 1fc60ea) @@ -517,6 +528,7 @@ test('T5642', # It's a bizarre program with LOTS of data types) # 2014-09-10: 1536924976 post-AMP-cleanup # 2014-12-10: 1282916024 Improvements in constraints solver + # 2015-10-28: 1412808976 Emit Typeable at definition site ], compile,['-O']) @@ -611,8 +623,9 @@ test('T9675', # 2015-07-11 56 (x86/Linux, 64-bit machine) use +RTS -G1 ]), compiler_stats_num_field('bytes allocated', - [(wordsize(64), 544489040, 10) + [(wordsize(64), 608284152, 10) # 2014-10-13 544489040 + # 2015-10-28 608284152 emit Typeable at definition site ,(wordsize(32), 279480696, 10) # 2015-07-11 279480696 (x86/Linux, 64-bit machine) use +RTS -G1 ]), @@ -679,10 +692,11 @@ test('T9872d', test('T9961', [ only_ways(['normal']), compiler_stats_num_field('bytes allocated', - [(wordsize(64), 663978160, 5), + [(wordsize(64), 708680480, 5), # 2015-01-12 807117816 Initally created # 2015-spring 772510192 Got better # 2015-05-22 663978160 Fix for #10370 improves it more + # 2015-10-28 708680480 Emit Typeable at definition site (wordsize(32), 375647160, 5) ]), ], diff --git a/testsuite/tests/perf/should_run/all.T b/testsuite/tests/perf/should_run/all.T index 262f4e12fa..8b132fe3c0 100644 --- a/testsuite/tests/perf/should_run/all.T +++ b/testsuite/tests/perf/should_run/all.T @@ -409,9 +409,10 @@ test('InlineCloneArrayAlloc', test('T9203', [stats_num_field('bytes allocated', [ (wordsize(32), 50000000, 5) - , (wordsize(64), 94547280, 5) ]), + , (wordsize(64), 43047088, 5) ]), # was 95747304 # 2019-09-10 94547280 post-AMP cleanup + # 2015-10-28 43047088 emit Typeable at definition site only_ways(['normal'])], compile_and_run, ['-O2']) diff --git a/testsuite/tests/polykinds/T8132.stderr b/testsuite/tests/polykinds/T8132.stderr index e4c46591c3..4a1ca2b4f6 100644 --- a/testsuite/tests/polykinds/T8132.stderr +++ b/testsuite/tests/polykinds/T8132.stderr @@ -1,3 +1,3 @@ -T8132.hs:6:10: - Class `Typeable` does not support user-specified instances. +T8132.hs:6:10: error: + Class ‘Typeable’ does not support user-specified instances diff --git a/testsuite/tests/quasiquotation/T7918.stdout b/testsuite/tests/quasiquotation/T7918.stdout index f4d406b591..4dff68d1ce 100644 --- a/testsuite/tests/quasiquotation/T7918.stdout +++ b/testsuite/tests/quasiquotation/T7918.stdout @@ -25,3 +25,6 @@ (undefined, T7918B.hs:18:16-24) (y, T7918B.hs:19:9-12) (undefined, T7918B.hs:19:16-24) +(Module, <no location info>) +(TrNameS, <no location info>) +(TrNameS, <no location info>) diff --git a/testsuite/tests/roles/should_compile/Roles1.stderr b/testsuite/tests/roles/should_compile/Roles1.stderr index d9f9943d63..a4beb6454d 100644 --- a/testsuite/tests/roles/should_compile/Roles1.stderr +++ b/testsuite/tests/roles/should_compile/Roles1.stderr @@ -21,4 +21,65 @@ Dependent packages: [base-4.8.2.0, ghc-prim-0.4.0.0, integer-gmp-1.0.0.0] ==================== Typechecker ==================== +Roles1.$tcT7 + = TyCon + 12795488517584970699## + 6852268802866176810## + Roles1.$trModule + (TrNameS "T7"#) +Roles1.$tcT6 + = TyCon + 1052116432298682626## + 4782516991847719023## + Roles1.$trModule + (TrNameS "T6"#) +Roles1.$tcT5 + = TyCon + 10855726709479635304## + 5574528370049939204## + Roles1.$trModule + (TrNameS "T5"#) +Roles1.$tc'K5 + = TyCon + 17986294396600628264## + 15784122741796850983## + Roles1.$trModule + (TrNameS "'K5"#) +Roles1.$tcT4 + = TyCon + 5809060867006837344## + 8795972313583150301## + Roles1.$trModule + (TrNameS "T4"#) +Roles1.$tcT3 + = TyCon + 17827258502042208248## + 10404219359416482652## + Roles1.$trModule + (TrNameS "T3"#) +Roles1.$tcT2 + = TyCon + 14324923875690440398## + 17626224477681351106## + Roles1.$trModule + (TrNameS "T2"#) +Roles1.$tc'K2 + = TyCon + 17795591238510508397## + 10155757471958311507## + Roles1.$trModule + (TrNameS "'K2"#) +Roles1.$tcT1 + = TyCon + 12633763300352597178## + 11103726621424210926## + Roles1.$trModule + (TrNameS "T1"#) +Roles1.$tc'K1 + = TyCon + 1949157551035372857## + 3576433963139282451## + Roles1.$trModule + (TrNameS "'K1"#) +Roles1.$trModule = Module (TrNameS "main"#) (TrNameS "Roles1"#) diff --git a/testsuite/tests/roles/should_compile/Roles13.stderr b/testsuite/tests/roles/should_compile/Roles13.stderr index 5ecdd16e10..4b7b2cb18d 100644 --- a/testsuite/tests/roles/should_compile/Roles13.stderr +++ b/testsuite/tests/roles/should_compile/Roles13.stderr @@ -1,17 +1,62 @@ ==================== Tidy Core ==================== -Result size of Tidy Core = {terms: 5, types: 9, coercions: 5} +Result size of Tidy Core = {terms: 42, types: 18, coercions: 5} + +-- RHS size: {terms: 2, types: 0, coercions: 0} +a :: TrName +[GblId, Caf=NoCafRefs, Str=DmdType] +a = TrNameS "main"# + +-- RHS size: {terms: 2, types: 0, coercions: 0} +a1 :: TrName +[GblId, Caf=NoCafRefs, Str=DmdType] +a1 = TrNameS "Roles13"# + +-- RHS size: {terms: 3, types: 0, coercions: 0} +Roles13.$trModule :: Module +[GblId[ReflectionId], Caf=NoCafRefs, Str=DmdType] +Roles13.$trModule = Module a a1 + +-- RHS size: {terms: 2, types: 0, coercions: 0} +a2 :: TrName +[GblId, Caf=NoCafRefs, Str=DmdType] +a2 = TrNameS "Age"# + +-- RHS size: {terms: 5, types: 0, coercions: 0} +Roles13.$tcAge :: TyCon +[GblId[ReflectionId], Caf=NoCafRefs, Str=DmdType] +Roles13.$tcAge = TyCon 0## 0## Roles13.$trModule a2 + +-- RHS size: {terms: 2, types: 0, coercions: 0} +a3 :: TrName +[GblId, Caf=NoCafRefs, Str=DmdType] +a3 = TrNameS "'MkWrap"# + +-- RHS size: {terms: 5, types: 0, coercions: 0} +Roles13.$tc'MkWrap :: TyCon +[GblId[ReflectionId], Caf=NoCafRefs, Str=DmdType] +Roles13.$tc'MkWrap = TyCon 0## 0## Roles13.$trModule a3 + +-- RHS size: {terms: 2, types: 0, coercions: 0} +a4 :: TrName +[GblId, Caf=NoCafRefs, Str=DmdType] +a4 = TrNameS "Wrap"# + +-- RHS size: {terms: 5, types: 0, coercions: 0} +Roles13.$tcWrap :: TyCon +[GblId[ReflectionId], Caf=NoCafRefs, Str=DmdType] +Roles13.$tcWrap = TyCon 0## 0## Roles13.$trModule a4 -- RHS size: {terms: 2, types: 2, coercions: 0} -a :: Wrap Age -> Wrap Age +a5 :: Wrap Age -> Wrap Age [GblId, Arity=1, Caf=NoCafRefs, Str=DmdType] -a = \ (ds :: Wrap Age) -> ds +a5 = \ (ds :: Wrap Age) -> ds -- RHS size: {terms: 1, types: 0, coercions: 5} convert :: Wrap Age -> Int [GblId, Arity=1, Caf=NoCafRefs, Str=DmdType] convert = - a + a5 `cast` (<Wrap Age>_R -> Roles13.NTCo:Wrap[0] Roles13.NTCo:Age[0] :: (Wrap Age -> Wrap Age) ~R# (Wrap Age -> Int)) diff --git a/testsuite/tests/roles/should_compile/Roles14.stderr b/testsuite/tests/roles/should_compile/Roles14.stderr index bb61133ce0..20c0bfe7a4 100644 --- a/testsuite/tests/roles/should_compile/Roles14.stderr +++ b/testsuite/tests/roles/should_compile/Roles14.stderr @@ -11,4 +11,11 @@ Dependent packages: [base-4.8.2.0, ghc-prim-0.4.0.0, integer-gmp-1.0.0.0] ==================== Typechecker ==================== +Roles12.$tcC2 + = TyCon + 4006088231579841122## + 4783761708993822739## + Roles12.$trModule + (TrNameS "C2"#) +Roles12.$trModule = Module (TrNameS "main"#) (TrNameS "Roles12"#) diff --git a/testsuite/tests/roles/should_compile/Roles2.stderr b/testsuite/tests/roles/should_compile/Roles2.stderr index d07314379f..35895a8ae4 100644 --- a/testsuite/tests/roles/should_compile/Roles2.stderr +++ b/testsuite/tests/roles/should_compile/Roles2.stderr @@ -9,4 +9,17 @@ Dependent packages: [base-4.8.2.0, ghc-prim-0.4.0.0, integer-gmp-1.0.0.0] ==================== Typechecker ==================== +Roles2.$tcT2 + = TyCon + 5934726586329293381## + 1923031187495159753## + Roles2.$trModule + (TrNameS "T2"#) +Roles2.$tcT1 + = TyCon + 13879106829711353992## + 15151456821588362072## + Roles2.$trModule + (TrNameS "T1"#) +Roles2.$trModule = Module (TrNameS "main"#) (TrNameS "Roles2"#) diff --git a/testsuite/tests/roles/should_compile/Roles3.stderr b/testsuite/tests/roles/should_compile/Roles3.stderr index 6f25b63691..483b349907 100644 --- a/testsuite/tests/roles/should_compile/Roles3.stderr +++ b/testsuite/tests/roles/should_compile/Roles3.stderr @@ -26,4 +26,29 @@ Dependent packages: [base-4.8.2.0, ghc-prim-0.4.0.0, integer-gmp-1.0.0.0] ==================== Typechecker ==================== +Roles3.$tcC4 + = TyCon + 12861862461396457184## + 6389612623460961504## + Roles3.$trModule + (TrNameS "C4"#) +Roles3.$tcC3 + = TyCon + 5998139369941479154## + 6816352641934636458## + Roles3.$trModule + (TrNameS "C3"#) +Roles3.$tcC2 + = TyCon + 8833962732139387711## + 7891126688522429937## + Roles3.$trModule + (TrNameS "C2"#) +Roles3.$tcC1 + = TyCon + 16242970448469140073## + 10229725431456576413## + Roles3.$trModule + (TrNameS "C1"#) +Roles3.$trModule = Module (TrNameS "main"#) (TrNameS "Roles3"#) diff --git a/testsuite/tests/roles/should_compile/Roles4.stderr b/testsuite/tests/roles/should_compile/Roles4.stderr index 0113869e42..2c19dd29d5 100644 --- a/testsuite/tests/roles/should_compile/Roles4.stderr +++ b/testsuite/tests/roles/should_compile/Roles4.stderr @@ -15,4 +15,17 @@ Dependent packages: [base-4.8.2.0, ghc-prim-0.4.0.0, integer-gmp-1.0.0.0] ==================== Typechecker ==================== +Roles4.$tcC3 + = TyCon + 16502190608089501863## + 13971441568961069854## + Roles4.$trModule + (TrNameS "C3"#) +Roles4.$tcC1 + = TyCon + 11951908835899020229## + 6518430686554778113## + Roles4.$trModule + (TrNameS "C1"#) +Roles4.$trModule = Module (TrNameS "main"#) (TrNameS "Roles4"#) diff --git a/testsuite/tests/roles/should_compile/T8958.stderr b/testsuite/tests/roles/should_compile/T8958.stderr index 87c3c0058e..c62d9c43dc 100644 --- a/testsuite/tests/roles/should_compile/T8958.stderr +++ b/testsuite/tests/roles/should_compile/T8958.stderr @@ -1,5 +1,5 @@ -T8958.hs:1:31: Warning: +T8958.hs:1:31: warning: -XDatatypeContexts is deprecated: It was widely considered a misfeature, and has been removed from the Haskell language. TYPE SIGNATURES TYPE CONSTRUCTORS @@ -20,6 +20,13 @@ Dependent packages: [base-4.8.2.0, ghc-prim-0.4.0.0, integer-gmp-1.0.0.0] ==================== Typechecker ==================== +T8958.$tcMap = TyCon 0## 0## T8958.$trModule (TrNameS "Map"#) +T8958.$tc'MkMap = TyCon 0## 0## T8958.$trModule (TrNameS "'MkMap"#) +T8958.$tcRepresentational + = TyCon 0## 0## T8958.$trModule (TrNameS "Representational"#) +T8958.$tcNominal + = TyCon 0## 0## T8958.$trModule (TrNameS "Nominal"#) +T8958.$trModule = Module (TrNameS "main"#) (TrNameS "T8958"#) AbsBinds [a] [] {Exports: [T8958.$fRepresentationala <= $dRepresentational <>] diff --git a/testsuite/tests/simplCore/should_compile/T3234.stderr b/testsuite/tests/simplCore/should_compile/T3234.stderr index c3591d02fe..d317991925 100644 --- a/testsuite/tests/simplCore/should_compile/T3234.stderr +++ b/testsuite/tests/simplCore/should_compile/T3234.stderr @@ -10,7 +10,7 @@ ==================== Grand total simplifier statistics ==================== -Total ticks: 45 +Total ticks: 46 14 PreInlineUnconditionally 1 n @@ -37,7 +37,7 @@ Total ticks: 45 1 foldr/single 1 unpack 1 unpack-list -1 LetFloatFromLet 1 +2 LetFloatFromLet 2 22 BetaReduction 1 a 1 b diff --git a/testsuite/tests/simplCore/should_compile/T3717.stderr b/testsuite/tests/simplCore/should_compile/T3717.stderr index 374533605e..f7fa084ef0 100644 --- a/testsuite/tests/simplCore/should_compile/T3717.stderr +++ b/testsuite/tests/simplCore/should_compile/T3717.stderr @@ -1,6 +1,33 @@ ==================== Tidy Core ==================== -Result size of Tidy Core = {terms: 22, types: 10, coercions: 0} +Result size of Tidy Core = {terms: 32, types: 13, coercions: 0} + +-- RHS size: {terms: 2, types: 0, coercions: 0} +T3717.$trModule2 :: TrName +[GblId, + Caf=NoCafRefs, + Str=DmdType m1, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 20}] +T3717.$trModule2 = TrNameS "main"# + +-- RHS size: {terms: 2, types: 0, coercions: 0} +T3717.$trModule1 :: TrName +[GblId, + Caf=NoCafRefs, + Str=DmdType m1, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 40 20}] +T3717.$trModule1 = TrNameS "T3717"# + +-- RHS size: {terms: 3, types: 0, coercions: 0} +T3717.$trModule :: Module +[GblId[ReflectionId], + Caf=NoCafRefs, + Str=DmdType m, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 30}] +T3717.$trModule = Module T3717.$trModule2 T3717.$trModule1 Rec { -- RHS size: {terms: 10, types: 2, coercions: 0} diff --git a/testsuite/tests/simplCore/should_compile/T3772.stdout b/testsuite/tests/simplCore/should_compile/T3772.stdout index e74fa39cb5..1ef8c79002 100644 --- a/testsuite/tests/simplCore/should_compile/T3772.stdout +++ b/testsuite/tests/simplCore/should_compile/T3772.stdout @@ -1,6 +1,6 @@ ==================== Tidy Core ==================== -Result size of Tidy Core = {terms: 26, types: 11, coercions: 0} +Result size of Tidy Core = {terms: 36, types: 14, coercions: 0} Rec { -- RHS size: {terms: 10, types: 2, coercions: 0} @@ -26,5 +26,32 @@ foo = } } +-- RHS size: {terms: 2, types: 0, coercions: 0} +T3772.$trModule1 :: TrName +[GblId, + Caf=NoCafRefs, + Str=DmdType m1, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 40 20}] +T3772.$trModule1 = TrNameS "T3772"# + +-- RHS size: {terms: 2, types: 0, coercions: 0} +T3772.$trModule2 :: TrName +[GblId, + Caf=NoCafRefs, + Str=DmdType m1, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 20}] +T3772.$trModule2 = TrNameS "main"# + +-- RHS size: {terms: 3, types: 0, coercions: 0} +T3772.$trModule :: Module +[GblId[ReflectionId], + Caf=NoCafRefs, + Str=DmdType m, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 30}] +T3772.$trModule = Module T3772.$trModule2 T3772.$trModule1 + diff --git a/testsuite/tests/simplCore/should_compile/T4908.stderr b/testsuite/tests/simplCore/should_compile/T4908.stderr index 6ad89470bb..334935ddd4 100644 --- a/testsuite/tests/simplCore/should_compile/T4908.stderr +++ b/testsuite/tests/simplCore/should_compile/T4908.stderr @@ -1,6 +1,33 @@ ==================== Tidy Core ==================== -Result size of Tidy Core = {terms: 54, types: 38, coercions: 0} +Result size of Tidy Core = {terms: 64, types: 41, coercions: 0} + +-- RHS size: {terms: 2, types: 0, coercions: 0} +T4908.$trModule2 :: TrName +[GblId, + Caf=NoCafRefs, + Str=DmdType m1, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 20}] +T4908.$trModule2 = TrNameS "main"# + +-- RHS size: {terms: 2, types: 0, coercions: 0} +T4908.$trModule1 :: TrName +[GblId, + Caf=NoCafRefs, + Str=DmdType m1, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 40 20}] +T4908.$trModule1 = TrNameS "T4908"# + +-- RHS size: {terms: 3, types: 0, coercions: 0} +T4908.$trModule :: Module +[GblId[ReflectionId], + Caf=NoCafRefs, + Str=DmdType m, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 30}] +T4908.$trModule = Module T4908.$trModule2 T4908.$trModule1 Rec { -- RHS size: {terms: 19, types: 5, coercions: 0} diff --git a/testsuite/tests/simplCore/should_compile/T4930.stderr b/testsuite/tests/simplCore/should_compile/T4930.stderr index 552c8a8ddc..9f71161d14 100644 --- a/testsuite/tests/simplCore/should_compile/T4930.stderr +++ b/testsuite/tests/simplCore/should_compile/T4930.stderr @@ -1,6 +1,33 @@ ==================== Tidy Core ==================== -Result size of Tidy Core = {terms: 35, types: 14, coercions: 0} +Result size of Tidy Core = {terms: 45, types: 17, coercions: 0} + +-- RHS size: {terms: 2, types: 0, coercions: 0} +T4930.$trModule2 :: TrName +[GblId, + Caf=NoCafRefs, + Str=DmdType m1, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 20}] +T4930.$trModule2 = TrNameS "main"# + +-- RHS size: {terms: 2, types: 0, coercions: 0} +T4930.$trModule1 :: TrName +[GblId, + Caf=NoCafRefs, + Str=DmdType m1, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 40 20}] +T4930.$trModule1 = TrNameS "T4930"# + +-- RHS size: {terms: 3, types: 0, coercions: 0} +T4930.$trModule :: Module +[GblId[ReflectionId], + Caf=NoCafRefs, + Str=DmdType m, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 30}] +T4930.$trModule = Module T4930.$trModule2 T4930.$trModule1 Rec { -- RHS size: {terms: 23, types: 6, coercions: 0} diff --git a/testsuite/tests/simplCore/should_compile/T7360.stderr b/testsuite/tests/simplCore/should_compile/T7360.stderr index f7979075ac..1cd13301f9 100644 --- a/testsuite/tests/simplCore/should_compile/T7360.stderr +++ b/testsuite/tests/simplCore/should_compile/T7360.stderr @@ -1,6 +1,6 @@ ==================== Tidy Core ==================== -Result size of Tidy Core = {terms: 36, types: 29, coercions: 0} +Result size of Tidy Core = {terms: 55, types: 34, coercions: 0} -- RHS size: {terms: 6, types: 3, coercions: 0} T7360.$WFoo3 [InlPrag=INLINE] :: Int -> Foo @@ -17,6 +17,51 @@ T7360.$WFoo3 = \ (dt [Occ=Once!] :: Int) -> case dt of _ [Occ=Dead] { I# dt [Occ=Once] -> T7360.Foo3 dt } +-- RHS size: {terms: 2, types: 0, coercions: 0} +T7360.$trModule2 :: TrName +[GblId, + Caf=NoCafRefs, + Str=DmdType m1, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 20}] +T7360.$trModule2 = TrNameS "main"# + +-- RHS size: {terms: 2, types: 0, coercions: 0} +T7360.$trModule1 :: TrName +[GblId, + Caf=NoCafRefs, + Str=DmdType m1, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 40 20}] +T7360.$trModule1 = TrNameS "T7360"# + +-- RHS size: {terms: 3, types: 0, coercions: 0} +T7360.$trModule :: Module +[GblId[ReflectionId], + Caf=NoCafRefs, + Str=DmdType m, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 30}] +T7360.$trModule = Module T7360.$trModule2 T7360.$trModule1 + +-- RHS size: {terms: 2, types: 0, coercions: 0} +T7360.$tcFoo1 :: TrName +[GblId, + Caf=NoCafRefs, + Str=DmdType m1, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 20}] +T7360.$tcFoo1 = TrNameS "Foo"# + +-- RHS size: {terms: 5, types: 0, coercions: 0} +T7360.$tcFoo :: TyCon +[GblId[ReflectionId], + Caf=NoCafRefs, + Str=DmdType m, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 50}] +T7360.$tcFoo = TyCon 0## 0## T7360.$trModule T7360.$tcFoo1 + -- RHS size: {terms: 5, types: 2, coercions: 0} fun1 [InlPrag=NOINLINE] :: Foo -> () [GblId, Arity=1, Caf=NoCafRefs, Str=DmdType <S,1*U>] diff --git a/testsuite/tests/simplCore/should_compile/T8274.stdout b/testsuite/tests/simplCore/should_compile/T8274.stdout index 35f2412bc4..6c0e36f8f9 100644 --- a/testsuite/tests/simplCore/should_compile/T8274.stdout +++ b/testsuite/tests/simplCore/should_compile/T8274.stdout @@ -1,2 +1,10 @@ +T8274.$trModule2 = TrNameS "main"# +T8274.$trModule1 = TrNameS "T8274"# +T8274.$tcP1 = TrNameS "P"# + 11095028091707994303## + 9476557054198009608## +T8274.$tcN1 = TrNameS "N"# + 7479687563082171902## + 17616649989360543185## p = T8274.Positives 42# 4.23# 4.23## '4'# 4## n = T8274.Negatives -4# -4.0# -4.0## diff --git a/testsuite/tests/simplCore/should_compile/T9400.stderr b/testsuite/tests/simplCore/should_compile/T9400.stderr index 5216d1ed5f..3bc95e42cc 100644 --- a/testsuite/tests/simplCore/should_compile/T9400.stderr +++ b/testsuite/tests/simplCore/should_compile/T9400.stderr @@ -1,6 +1,21 @@ ==================== Tidy Core ==================== -Result size of Tidy Core = {terms: 23, types: 16, coercions: 0} +Result size of Tidy Core = {terms: 33, types: 19, coercions: 0} + +-- RHS size: {terms: 2, types: 0, coercions: 0} +a :: TrName +[GblId, Caf=NoCafRefs, Str=DmdType] +a = TrNameS "main"# + +-- RHS size: {terms: 2, types: 0, coercions: 0} +a1 :: TrName +[GblId, Caf=NoCafRefs, Str=DmdType] +a1 = TrNameS "T9400"# + +-- RHS size: {terms: 3, types: 0, coercions: 0} +T9400.$trModule :: Module +[GblId[ReflectionId], Caf=NoCafRefs, Str=DmdType] +T9400.$trModule = Module a a1 -- RHS size: {terms: 22, types: 14, coercions: 0} main :: IO () diff --git a/testsuite/tests/simplCore/should_compile/rule2.stderr b/testsuite/tests/simplCore/should_compile/rule2.stderr index 082f9aa134..da97b8859c 100644 --- a/testsuite/tests/simplCore/should_compile/rule2.stderr +++ b/testsuite/tests/simplCore/should_compile/rule2.stderr @@ -10,13 +10,14 @@ ==================== Grand total simplifier statistics ==================== -Total ticks: 12 +Total ticks: 13 2 PreInlineUnconditionally 1 f 1 lvl 1 UnfoldingDone 1 Roman.bar 1 RuleFired 1 foo/bar +1 LetFloatFromLet 1 1 EtaReduction 1 ds 7 BetaReduction 1 f diff --git a/testsuite/tests/simplCore/should_compile/spec-inline.stderr b/testsuite/tests/simplCore/should_compile/spec-inline.stderr index 392d4fba73..7ae0e9c920 100644 --- a/testsuite/tests/simplCore/should_compile/spec-inline.stderr +++ b/testsuite/tests/simplCore/should_compile/spec-inline.stderr @@ -1,6 +1,33 @@ ==================== Tidy Core ==================== -Result size of Tidy Core = {terms: 162, types: 61, coercions: 0} +Result size of Tidy Core = {terms: 172, types: 64, coercions: 0} + +-- RHS size: {terms: 2, types: 0, coercions: 0} +Roman.$trModule2 :: TrName +[GblId, + Caf=NoCafRefs, + Str=DmdType m1, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 20}] +Roman.$trModule2 = TrNameS "main"# + +-- RHS size: {terms: 2, types: 0, coercions: 0} +Roman.$trModule1 :: TrName +[GblId, + Caf=NoCafRefs, + Str=DmdType m1, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 40 20}] +Roman.$trModule1 = TrNameS "Roman"# + +-- RHS size: {terms: 3, types: 0, coercions: 0} +Roman.$trModule :: Module +[GblId[ReflectionId], + Caf=NoCafRefs, + Str=DmdType m, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 30}] +Roman.$trModule = Module Roman.$trModule2 Roman.$trModule1 -- RHS size: {terms: 2, types: 1, coercions: 0} Roman.foo3 :: Int diff --git a/testsuite/tests/stranal/should_compile/T10694.stdout b/testsuite/tests/stranal/should_compile/T10694.stdout index 2797ce7407..64d5f7a1aa 100644 --- a/testsuite/tests/stranal/should_compile/T10694.stdout +++ b/testsuite/tests/stranal/should_compile/T10694.stdout @@ -1,2 +1,5 @@ + Str=DmdType m1, + Str=DmdType m1, + Str=DmdType m, [GblId, Arity=2, Str=DmdType <L,U(U)><L,U(U)>m] Str=DmdType <L,U(U)><L,U(U)>, diff --git a/testsuite/tests/stranal/sigs/BottomFromInnerLambda.stderr b/testsuite/tests/stranal/sigs/BottomFromInnerLambda.stderr index e8ae690147..4bc1e3f379 100644 --- a/testsuite/tests/stranal/sigs/BottomFromInnerLambda.stderr +++ b/testsuite/tests/stranal/sigs/BottomFromInnerLambda.stderr @@ -1,5 +1,6 @@ ==================== Strictness signatures ==================== +BottomFromInnerLambda.$trModule: m BottomFromInnerLambda.expensive: <S(S),1*U(U)>m BottomFromInnerLambda.f: <S(S),1*U(U)> diff --git a/testsuite/tests/stranal/sigs/DmdAnalGADTs.stderr b/testsuite/tests/stranal/sigs/DmdAnalGADTs.stderr index 7fb1a55223..aa7a2ef8b6 100644 --- a/testsuite/tests/stranal/sigs/DmdAnalGADTs.stderr +++ b/testsuite/tests/stranal/sigs/DmdAnalGADTs.stderr @@ -1,5 +1,7 @@ ==================== Strictness signatures ==================== +DmdAnalGADTs.$tcD: m +DmdAnalGADTs.$trModule: m DmdAnalGADTs.diverges: b DmdAnalGADTs.f: <S,1*U> DmdAnalGADTs.f': <S,1*U>m diff --git a/testsuite/tests/stranal/sigs/HyperStrUse.stderr b/testsuite/tests/stranal/sigs/HyperStrUse.stderr index 1a0ff337c1..f04a2118fd 100644 --- a/testsuite/tests/stranal/sigs/HyperStrUse.stderr +++ b/testsuite/tests/stranal/sigs/HyperStrUse.stderr @@ -1,5 +1,6 @@ ==================== Strictness signatures ==================== +HyperStrUse.$trModule: m HyperStrUse.f: <S(SL),1*U(1*U(U),A)><S,1*U>m diff --git a/testsuite/tests/stranal/sigs/StrAnalExample.stderr b/testsuite/tests/stranal/sigs/StrAnalExample.stderr index dbe4770080..bd82226bee 100644 --- a/testsuite/tests/stranal/sigs/StrAnalExample.stderr +++ b/testsuite/tests/stranal/sigs/StrAnalExample.stderr @@ -1,5 +1,6 @@ ==================== Strictness signatures ==================== +StrAnalExample.$trModule: m StrAnalExample.foo: <S,1*U> diff --git a/testsuite/tests/stranal/sigs/T8569.stderr b/testsuite/tests/stranal/sigs/T8569.stderr index d33935ee14..3013d769fb 100644 --- a/testsuite/tests/stranal/sigs/T8569.stderr +++ b/testsuite/tests/stranal/sigs/T8569.stderr @@ -1,5 +1,7 @@ ==================== Strictness signatures ==================== +T8569.$tcRep: m +T8569.$trModule: m T8569.addUp: <S,1*U><L,U> diff --git a/testsuite/tests/stranal/sigs/T8598.stderr b/testsuite/tests/stranal/sigs/T8598.stderr index 8de5d31a01..28d5dd0c7d 100644 --- a/testsuite/tests/stranal/sigs/T8598.stderr +++ b/testsuite/tests/stranal/sigs/T8598.stderr @@ -1,5 +1,6 @@ ==================== Strictness signatures ==================== +T8598.$trModule: m T8598.fun: <S(S),1*U(U)>m diff --git a/testsuite/tests/stranal/sigs/UnsatFun.stderr b/testsuite/tests/stranal/sigs/UnsatFun.stderr index 6e6402bacc..5f2d27ff20 100644 --- a/testsuite/tests/stranal/sigs/UnsatFun.stderr +++ b/testsuite/tests/stranal/sigs/UnsatFun.stderr @@ -1,5 +1,6 @@ ==================== Strictness signatures ==================== +UnsatFun.$trModule: m UnsatFun.f: <B,1*U(U)><B,A>b UnsatFun.g: <B,1*U(U)>b UnsatFun.g': <L,1*U(U)> diff --git a/testsuite/tests/th/TH_Roles2.stderr b/testsuite/tests/th/TH_Roles2.stderr index 8f078ba901..5ca909f7ab 100644 --- a/testsuite/tests/th/TH_Roles2.stderr +++ b/testsuite/tests/th/TH_Roles2.stderr @@ -9,4 +9,12 @@ Dependent packages: [array-0.5.1.0, base-4.8.2.0, deepseq-1.4.1.1, pretty-1.1.2.0, template-haskell-2.11.0.0] ==================== Typechecker ==================== +TH_Roles2.$tcT + = TyCon + 6325001754388382679## + 4656387726417942748## + TH_Roles2.$trModule + (TrNameS "T"#) +TH_Roles2.$trModule + = Module (TrNameS "main"#) (TrNameS "TH_Roles2"#) diff --git a/testsuite/tests/typecheck/should_compile/holes2.stderr b/testsuite/tests/typecheck/should_compile/holes2.stderr index ee3d627438..63891fa273 100644 --- a/testsuite/tests/typecheck/should_compile/holes2.stderr +++ b/testsuite/tests/typecheck/should_compile/holes2.stderr @@ -4,10 +4,10 @@ holes2.hs:3:5: warning: prevents the constraint ‘(Show a0)’ from being solved. Probable fix: use a type annotation to specify what ‘a0’ should be. These potential instances exist: + instance Show Module -- Defined in ‘GHC.Show’ instance Show Ordering -- Defined in ‘GHC.Show’ - instance Show Integer -- Defined in ‘GHC.Show’ - instance Show a => Show (Maybe a) -- Defined in ‘GHC.Show’ - ...plus 22 others + instance Show TrName -- Defined in ‘GHC.Show’ + ...plus 25 others (use -fprint-potential-instances to see them all) In the expression: show _ In an equation for ‘f’: f = show _ diff --git a/testsuite/tests/typecheck/should_fail/T5095.stderr b/testsuite/tests/typecheck/should_fail/T5095.stderr index 46667fb8f4..a854b7ea75 100644 --- a/testsuite/tests/typecheck/should_fail/T5095.stderr +++ b/testsuite/tests/typecheck/should_fail/T5095.stderr @@ -6,7 +6,7 @@ T5095.hs:9:11: error: instance (Eq a, Eq b) => Eq (Either a b) -- Defined in ‘Data.Either’ instance Eq All -- Defined in ‘Data.Monoid’ - ...plus 35 others + ...plus 36 others ...plus one instance involving out-of-scope types (use -fprint-potential-instances to see them all) (The choice depends on the instantiation of ‘a’ diff --git a/testsuite/tests/typecheck/should_fail/tcfail072.stderr b/testsuite/tests/typecheck/should_fail/tcfail072.stderr index 65b157332d..68d7283244 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail072.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail072.stderr @@ -8,10 +8,10 @@ tcfail072.hs:23:13: error: The type variable ‘p0’ is ambiguous These potential instances exist: instance Ord Ordering -- Defined in ‘GHC.Classes’ + instance Ord TyCon -- Defined in ‘GHC.Classes’ instance Ord Integer -- Defined in ‘integer-gmp-1.0.0.0:GHC.Integer.Type’ - instance Ord a => Ord (Maybe a) -- Defined in ‘GHC.Base’ - ...plus 22 others + ...plus 23 others ...plus one instance involving out-of-scope types (use -fprint-potential-instances to see them all) In the expression: g A diff --git a/testsuite/tests/typecheck/should_fail/tcfail133.stderr b/testsuite/tests/typecheck/should_fail/tcfail133.stderr index f61320f4c1..32f73422af 100644 --- a/testsuite/tests/typecheck/should_fail/tcfail133.stderr +++ b/testsuite/tests/typecheck/should_fail/tcfail133.stderr @@ -7,11 +7,10 @@ tcfail133.hs:68:7: error: prevents the constraint ‘(Show r0)’ from being solved. Probable fix: use a type annotation to specify what ‘r0’ should be. These potential instances exist: + instance Show Module -- Defined in ‘GHC.Show’ instance Show Ordering -- Defined in ‘GHC.Show’ - instance Show Integer -- Defined in ‘GHC.Show’ - instance (Show a, Show b, Number a, Digit b) => Show (a :@ b) - -- Defined at tcfail133.hs:11:54 - ...plus 25 others + instance Show TrName -- Defined in ‘GHC.Show’ + ...plus 28 others (use -fprint-potential-instances to see them all) In the expression: show In the expression: show $ add (One :@ Zero) (One :@ One) diff --git a/utils/haddock b/utils/haddock -Subproject 18de4f2f992d3ed41eb83cb073e63304f0271dc +Subproject 174f23631a0a8de7dc0f3cd67c393a5ca88c4a2 |