diff options
| author | Ben Gamari <ben@smart-cactus.org> | 2015-08-26 18:24:34 +0200 |
|---|---|---|
| committer | Ben Gamari <ben@smart-cactus.org> | 2015-09-28 13:15:58 +0200 |
| commit | 285cd0012dfafb3a03cbb002e8519199df3329e1 (patch) | |
| tree | 79dd66bb1ec6ca49a2c048f516e2b31c02f965e7 | |
| parent | cce05194164eb4068c8237eb227065ac773fc418 (diff) | |
| download | haskell-285cd0012dfafb3a03cbb002e8519199df3329e1.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
* T1969: GHC allocates 30% more
* T5642: GHC allocates 14% more
* T9872d: GHC allocates 5% more
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.
* Move mkDefaultMethodIds, mkRecSelBinds from TcTyClsDecls to TcTyDecls
46 files changed, 2024 insertions, 1264 deletions
diff --git a/compiler/basicTypes/DataCon.hs b/compiler/basicTypes/DataCon.hs index 07ed069c51..0384eccebb 100644 --- a/compiler/basicTypes/DataCon.hs +++ b/compiler/basicTypes/DataCon.hs @@ -32,7 +32,8 @@ module DataCon ( dataConSrcBangs, dataConSourceArity, dataConRepArity, dataConRepRepArity, dataConIsInfix, - dataConWorkId, dataConWrapId, dataConWrapId_maybe, dataConImplicitIds, + dataConWorkId, dataConWrapId, dataConWrapId_maybe, + dataConImplicitTyThings, dataConRepStrictness, dataConImplBangs, dataConBoxer, splitDataProductType_maybe, @@ -43,16 +44,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 @@ -68,11 +71,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 ) @@ -395,8 +398,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 @@ -667,7 +670,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 @@ -684,7 +689,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 @@ -729,15 +734,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 ] @@ -820,11 +822,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] @@ -1069,60 +1073,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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1152,7 +1208,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 @@ -1204,3 +1260,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 fa9d6ed7e6..b5e348b78f 100644 --- a/compiler/basicTypes/OccName.hs +++ b/compiler/basicTypes/OccName.hs @@ -71,6 +71,7 @@ module OccName ( mkPDatasTyConOcc, mkPDatasDataConOcc, mkPReprTyConOcc, mkPADFunOcc, + mkTyConRepUserOcc, mkTyConRepSysOcc, -- ** Deconstruction occNameFS, occNameString, occNameSpace, @@ -607,7 +608,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 @@ -630,11 +632,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 5ce9c64a0c..a53e9f0376 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 @@ -289,14 +295,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 @@ -304,10 +315,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/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs index 28e866d8e9..48873547fd 100644 --- a/compiler/deSugar/DsBinds.hs +++ b/compiler/deSugar/DsBinds.hs @@ -44,10 +44,9 @@ import TyCon import TcEvidence import TcType import Type -import Kind (returnsConstraintKind) import Coercion hiding (substCo) import TysWiredIn ( eqBoxDataCon, coercibleDataCon, mkListTy - , mkBoxedTupleTy, charTy, typeNatKind, typeSymbolKind ) + , mkBoxedTupleTy, charTy ) import Id import MkId(proxyHashId) import Class @@ -68,17 +67,15 @@ import BasicTypes hiding ( TopLevel ) import DynFlags import FastString import Util +import Control.Monad( zipWithM ) import MonadUtils import Control.Monad(liftM) -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 @@ -842,154 +839,144 @@ 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 (for ty) +ds_ev_typeable ty (EvTypeableTyCon ev_ts) + | Just (tc, kts) <- splitTyConApp_maybe ty + , (ks, ts) <- splitTyConArgs tc kts + = 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 + ; tReps <- zipWithM getRep ev_ts ts + ; kReps <- mapM kindRep ks + ; return (mkRep tcRep kReps tReps) } + +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 _) + = do { -- dict <- dsEvTerm ev + ; ctr <- dsLookupGlobalId typeLitTypeRepName + -- typeLitTypeRep :: String -> TypeRep + -- ; let finst = mkTyApps (Var ctr) [ty] + -- proxy = mkTyApps (Var proxyHashId) [typeKind ty, ty] + ; tag <- mkStringExpr str + ; return (mkApps (Var ctr) [tag]) } 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 = modulePackageKey modl - - modl_fs = moduleNameFS (moduleName modl) - pkg_fs = packageKeyFS 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 - - + str + | Just n <- isNumLitTy ty = show n + | Just s <- isStrLitTy ty = show s + | otherwise = panic "ds_ev_typeable: malformed TyLit evidence" + +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] ~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1001,8 +988,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 @@ -1014,7 +1004,7 @@ dsEvCallStack cs = do let srcLocTy = mkTyConTy srcLocTyCon let mkSrcLoc l = liftM (mkCoreConApps srcLocDataCon) - (sequence [ mkStringExpr (showPpr df $ modulePackageKey m) + (sequence [ mkStringExprFS (packageKeyFS $ modulePackageKey m) , mkStringExprFS (moduleNameFS $ moduleName m) , mkStringExprFS (srcSpanFile l) , return $ mkIntExprInt df (srcSpanStartLine l) @@ -1060,7 +1050,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/ghc.cabal.in b/compiler/ghc.cabal.in index 16918d6173..ede976818c 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -413,6 +413,7 @@ Library TcErrors TcTyClsDecls TcTyDecls + TcTypeable TcType TcEvidence TcUnify diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs index b45156288f..f3d001b4ab 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, nlConPat, @@ -314,6 +314,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 8efd342b22..9cce44a83a 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 } @@ -224,7 +231,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 @@ -237,10 +245,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 @@ -279,6 +284,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 -}] @@ -297,9 +303,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 } @@ -363,3 +368,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 61ec33e56c..cf85418e73 100644 --- a/compiler/iface/IfaceSyn.hs +++ b/compiler/iface/IfaceSyn.hs @@ -55,7 +55,7 @@ import Fingerprint import Binary import BooleanFormula ( BooleanFormula, pprBooleanFormula, isTrue ) import HsBinds -import TyCon ( Role (..), Injectivity(..) ) +import TyCon (Role (..), Injectivity(..) ) import StaticFlags (opt_PprStyle_Debug) import Util( filterOut, filterByList ) import InstEnv @@ -161,7 +161,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 @@ -188,7 +189,6 @@ data IfaceAxBranch = IfaceAxBranch { ifaxbTyVars :: [IfaceTvBndr] data IfaceConDecls = IfAbstractTyCon Bool -- c.f TyCon.AbstractTyCon - | IfDataFamTyCon -- Data family | IfDataTyCon [IfaceConDecl] -- Data type decls | IfNewTyCon IfaceConDecl -- Newtype decls @@ -333,7 +333,6 @@ 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] @@ -348,36 +347,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) @@ -401,6 +379,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 @@ -665,7 +651,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") @@ -719,7 +704,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 @@ -733,11 +723,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")) @@ -1143,12 +1135,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 @@ -1497,18 +1490,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 @@ -1548,15 +1545,13 @@ instance Binary IfaceAxBranch where instance Binary IfaceConDecls where put_ bh (IfAbstractTyCon d) = putByte bh 0 >> put_ bh d - put_ bh IfDataFamTyCon = putByte bh 1 - put_ bh (IfDataTyCon cs) = putByte bh 2 >> put_ bh cs - put_ bh (IfNewTyCon c) = putByte bh 3 >> put_ bh c + put_ bh (IfDataTyCon cs) = putByte bh 1 >> put_ bh cs + put_ bh (IfNewTyCon c) = putByte bh 2 >> put_ bh c get bh = do h <- getByte bh case h of 0 -> liftM IfAbstractTyCon $ get bh - 1 -> return IfDataFamTyCon - 2 -> liftM IfDataTyCon $ get bh + 1 -> liftM IfDataTyCon $ get bh _ -> liftM IfNewTyCon $ get bh instance Binary IfaceConDecl where diff --git a/compiler/iface/MkIface.hs b/compiler/iface/MkIface.hs index 99544c4e4f..71a5257c76 100644 --- a/compiler/iface/MkIface.hs +++ b/compiler/iface/MkIface.hs @@ -1670,7 +1670,7 @@ tyConToIfaceDecl env tycon ifCons = ifaceConDecls (algTyConRhs tycon), ifRec = boolToRecFlag (isRecursiveTyCon tycon), ifGadtSyntax = isGadtSyntaxTyCon tycon, - ifPromotable = isJust (promotableTyCon_maybe tycon), + ifPromotable = isPromotableTyCon tycon, ifParent = parent }) | otherwise -- FunTyCon, PrimTyCon, promoted TyCon/DataCon @@ -1708,16 +1708,13 @@ tyConToIfaceDecl env tycon axn = coAxiomName ax to_if_fam_flav (ClosedSynFamilyTyCon Nothing) = IfaceClosedSynFamilyTyCon Nothing - to_if_fam_flav AbstractClosedSynFamilyTyCon - = IfaceAbstractClosedSynFamilyTyCon - - to_if_fam_flav (BuiltInSynFamTyCon {}) - = IfaceBuiltInSynFamTyCon + to_if_fam_flav AbstractClosedSynFamilyTyCon = IfaceAbstractClosedSynFamilyTyCon + to_if_fam_flav (DataFamilyTyCon {}) = IfaceDataFamilyTyCon + to_if_fam_flav (BuiltInSynFamTyCon {}) = IfaceBuiltInSynFamTyCon ifaceConDecls (NewTyCon { data_con = con }) = IfNewTyCon (ifaceConDecl con) ifaceConDecls (DataTyCon { data_cons = cons }) = IfDataTyCon (map ifaceConDecl cons) - ifaceConDecls (DataFamilyTyCon {}) = IfDataFamTyCon ifaceConDecls (TupleTyCon { data_con = con }) = IfDataTyCon [ifaceConDecl con] 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 5f91bad0e3..2935a577b7 100644 --- a/compiler/iface/TcIface.hs +++ b/compiler/iface/TcIface.hs @@ -296,13 +296,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, @@ -313,7 +313,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, @@ -325,22 +325,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, @@ -364,20 +365,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") @@ -421,7 +427,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) $ @@ -504,11 +510,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 { data_cons <- mapM tc_con_decl cons ; return (mkDataTyConRhs data_cons) } IfNewTyCon con -> do { data_con <- tc_con_decl con @@ -524,14 +529,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 @@ -545,20 +550,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 @@ -879,7 +888,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) @@ -1351,7 +1360,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 e5c6ce14ec..1cc1f0d2d1 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -92,9 +92,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 @@ -179,7 +181,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 = [], @@ -192,6 +194,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 ddb4ca160b..a570e67d0f 100644 --- a/compiler/main/HscTypes.hs +++ b/compiler/main/HscTypes.hs @@ -1696,8 +1696,7 @@ 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 @@ -1709,7 +1708,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 @@ -1725,7 +1724,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 @@ -1733,10 +1733,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 5ab060e941..16f72e1c68 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 10d8747b73..e4f2f8c07c 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, + typeLitTypeRepName, -- Dynamic toDynName, @@ -666,11 +668,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") @@ -763,6 +760,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") @@ -1024,19 +1054,23 @@ ixClassName = clsQual gHC_ARR (fsLit "Ix") ixClassKey -- Class Typeable, and functions for constructing `Typeable` dictionaries typeableClassName , typeRepTyConName - , mkTyConName + , trTyConDataConName + , trModuleDataConName + , trNameSDataConName , mkPolyTyConAppName , mkAppTyName - , typeNatTypeRepName - , typeSymbolTypeRepName + , typeRepIdName + , typeLitTypeRepName :: 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 -typeSymbolTypeRepName = varQual tYPEABLE_INTERNAL (fsLit "typeSymbolTypeRep") typeSymbolTypeRepKey +typeLitTypeRepName = varQual tYPEABLE_INTERNAL (fsLit "typeLitTypeRep") typeLitTypeRepKey -- Dynamic @@ -1629,6 +1663,11 @@ srcLocDataConKey = mkPreludeDataConUnique 37 ipDataConKey :: Unique ipDataConKey = mkPreludeDataConUnique 38 +trTyConDataConKey, trModuleDataConKey, trNameSDataConKey :: Unique +trTyConDataConKey = mkPreludeDataConUnique 185 +trModuleDataConKey = mkPreludeDataConUnique 186 +trNameSDataConKey = mkPreludeDataConUnique 187 + {- ************************************************************************ * * @@ -1890,21 +1929,21 @@ proxyHashKey = mkPreludeMiscIdUnique 502 mkTyConKey , mkPolyTyConAppKey , mkAppTyKey - , typeNatTypeRepKey - , typeSymbolTypeRepKey + , typeLitTypeRepKey + , typeRepIdKey :: Unique mkTyConKey = mkPreludeMiscIdUnique 503 mkPolyTyConAppKey = mkPreludeMiscIdUnique 504 mkAppTyKey = mkPreludeMiscIdUnique 505 -typeNatTypeRepKey = mkPreludeMiscIdUnique 506 -typeSymbolTypeRepKey = mkPreludeMiscIdUnique 507 +typeLitTypeRepKey = mkPreludeMiscIdUnique 506 +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/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 97c84cd9f9..3246891e4c 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/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs index 48abcc805c..64ab1b2e78 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, @@ -65,6 +65,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 } + {- ************************************************************************ * * @@ -168,10 +183,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 @@ -181,15 +194,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/TcEvidence.hs b/compiler/typecheck/TcEvidence.hs index 83bbcca1b7..8b3ae04067 100644 --- a/compiler/typecheck/TcEvidence.hs +++ b/compiler/typecheck/TcEvidence.hs @@ -730,24 +730,30 @@ 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 [EvTerm] + -- ^ Dictionary for @Typeable (T k1..kn t1..tn)@ + -- The EvTerms are for the type args (but not the kind args) + -- We do not (yet) have dictionaries for kinds, (Typeable k) - | 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 +775,19 @@ 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] (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 +1028,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 +1042,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 es -> evVarsOfTerms es + EvTypeableTyApp e1 e2 -> evVarsOfTerms [e1,e2] + EvTypeableTyLit e -> evVarsOfTerm e {- ************************************************************************ @@ -1091,7 +1110,7 @@ instance Outputable EvTerm where 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 _ ev) = ppr ev instance Outputable EvLit where ppr (EvNum n) = integer n @@ -1108,9 +1127,9 @@ instance Outputable EvCallStack where 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) + EvTypeableTyCon ks -> parens (ptext (sLit "TC") <+> sep (map ppr ks)) + EvTypeableTyApp t1 t2 -> parens (ppr t1 <+> ppr t2) + EvTypeableTyLit t1 -> ptext (sLit "TyLit") <> ppr t1 ---------------------------------------------------------------------- diff --git a/compiler/typecheck/TcGenGenerics.hs b/compiler/typecheck/TcGenGenerics.hs index 6ea541c384..ed1adf6947 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 @@ -266,10 +266,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 abe367dcc0..1f3e3115a4 100644 --- a/compiler/typecheck/TcHsSyn.hs +++ b/compiler/typecheck/TcHsSyn.hs @@ -1272,19 +1272,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) @@ -1302,6 +1293,17 @@ zonkEvTerm env (EvDelayedError ty msg) = do { ty' <- zonkTcTypeToType env ty ; return (EvDelayedError ty' msg) } +zonkEvTypeable :: ZonkEnv -> EvTypeable -> TcM EvTypeable +zonkEvTypeable env (EvTypeableTyCon ts) + = do { ts' <- mapM (zonkEvTerm env) ts + ; return (EvTypeableTyCon ts') } +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 d5dee95b00..13c210bd71 100644 --- a/compiler/typecheck/TcInstDcls.hs +++ b/compiler/typecheck/TcInstDcls.hs @@ -435,7 +435,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. @@ -446,10 +446,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 @@ -679,7 +682,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 @@ -705,7 +708,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) @@ -716,7 +721,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..073e061389 100644 --- a/compiler/typecheck/TcInteract.hs +++ b/compiler/typecheck/TcInteract.hs @@ -14,12 +14,13 @@ import TcCanonical import TcFlatten import VarSet import Type -import Kind ( isKind ) +import Kind ( isKind, isConstraintKind ) 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 `hasKey` ipClassNameKey + , [_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. -- @@ -1907,53 +1934,36 @@ 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 for Typeable +* * +***********************************************************************-} -- | 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 - - -- See Note [No Typeable for qualified types] - | isForAllTy t = return NoInstance - - -- Is the type of the form `C => t`? - | isJust (tcSplitPredFunTy_maybe t) = return NoInstance - - | eqType k typeNatKind = doTyLit knownNatClassName - | eqType k typeSymbolKind = doTyLit knownSymbolClassName - - | Just (tc, ks) <- splitTyConApp_maybe t - , all isKind ks = doTyCon tc ks - - | Just (f,kt) <- splitAppTy_maybe t = doTyApp f kt - | otherwise = return NoInstance - + | isForAllTy k = return NoInstance + | isConstraintKind k = return NoInstance + | Just _ <- isNumLitTy t = doTyLit knownNatClassName + | Just _ <- isStrLitTy t = doTyLit knownSymbolClassName + | Just (tc, kts) <- splitTyConApp_maybe t = doTyConApp tc kts + | Just (f,kt) <- splitAppTy_maybe t = doTyApp f kt + | otherwise = return NoInstance 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 + doTyConApp :: TyCon -> [KindOrType] -> TcS LookupInstResult + doTyConApp tc kts + | (ks, ts) <- splitTyConArgs tc kts + , all is_ground_kind ks + = return $ GenInst (map mk_typeable_pred ts) + (\tReps -> EvTypeable t $ EvTypeableTyCon + (map EvId tReps)) + True + | otherwise + = return NoInstance {- Representation for an application of a type to a type-or-kind. This may happen when the type expression starts with a type variable. @@ -1963,30 +1973,37 @@ matchTypeableClass clas k t (Typeable f, Typeable Int, Typeable Char) --> (after some simp. steps) Typeable f -} + doTyApp :: Type -> KindOrType -> TcS LookupInstResult doTyApp f tk | isKind tk = return NoInstance -- We can't solve until we know the ctr. | otherwise = return $ GenInst [mk_typeable_pred f, mk_typeable_pred tk] - (\[t1,t2] -> EvTypeable $ EvTypeableTyApp (EvId t1,f) (EvId t2,tk)) + (\[t1,t2] -> EvTypeable t $ EvTypeableTyApp (EvId t1) (EvId t2)) 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 + is_ground_kind k + | Just (_, ks) <- splitTyConApp_maybe k + = all is_ground_kind ks + | otherwise + = False -- 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. + -- 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 -> TcS LookupInstResult doTyLit c = do clas <- tcLookupClass c let p = mkClassPred clas [ t ] - return $ GenInst [p] (\[i] -> EvTypeable - $ EvTypeableTyLit (EvId i,t)) True + return $ GenInst [p] + (\[ev] -> EvTypeable t + $ EvTypeableTyLit $ EvId ev) + True {- Note [No Typeable for polytype or for constraints] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/typecheck/TcPatSyn.hs b/compiler/typecheck/TcPatSyn.hs index b4bc78205c..a5297739a0 100644 --- a/compiler/typecheck/TcPatSyn.hs +++ b/compiler/typecheck/TcPatSyn.hs @@ -260,7 +260,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 @@ -333,7 +333,7 @@ mkPatSynBuilderId dir (L _ name) qtvs theta arg_tys pat_ty | otherwise = do { builder_name <- newImplicitBinder name mkBuilderOcc ; let builder_sigma = mkSigmaTy qtvs theta (mkFunTys builder_arg_tys pat_ty) - builder_id = mkExportedLocalId VanillaId builder_name builder_sigma + builder_id = mkExportedLocalId PatSynId builder_name builder_sigma -- See Note [Exported LocalIds] in Id ; return (Just (builder_id, need_dummy_arg)) } where diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs index 2c2e5d71a9..26954158b8 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 @@ -959,12 +966,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 @@ -996,7 +1004,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{} = @@ -2064,7 +2071,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 @@ -2081,20 +2088,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 2dbabfc8fd..a4650ac0d0 100644 --- a/compiler/typecheck/TcRnMonad.hs +++ b/compiler/typecheck/TcRnMonad.hs @@ -142,7 +142,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 c4de91de24..45ebe2e3ca 100644 --- a/compiler/typecheck/TcRnTypes.hs +++ b/compiler/typecheck/TcRnTypes.hs @@ -459,6 +459,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 @@ -877,7 +880,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 @@ -894,6 +897,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 5c28b63c51..32d3526f4d 100644 --- a/compiler/typecheck/TcTyClsDecls.hs +++ b/compiler/typecheck/TcTyClsDecls.hs @@ -28,15 +28,13 @@ import TcRnMonad import TcEnv import TcValidity import TcHsSyn -import TcBinds( tcRecSelBinds ) import TcTyDecls import TcClassDcl import TcHsType import TcMType import TcType -import TysWiredIn( unitTy ) import FamInst -import FamInstEnv +import FamInstEnv( mkCoAxBranch, mkBranchedCoAxiom ) import Coercion( ltRole ) import Type import TypeRep -- for checkValidRoles @@ -46,7 +44,6 @@ import CoAxiom import TyCon import DataCon import Id -import MkCore ( rEC_SEL_ERROR_ID ) import IdInfo import Var import VarEnv @@ -64,10 +61,8 @@ import ListSetOps import Digraph import DynFlags import FastString -import Unique ( mkBuiltinUnique ) import BasicTypes -import Bag import Control.Monad import Data.List @@ -170,16 +165,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 @@ -599,24 +585,24 @@ tcTyClDecl rec_info (L loc decl) | otherwise = setSrcSpan loc $ tcAddDeclCtxt decl $ do { traceTc "tcTyAndCl-x" (ppr decl) - ; tcTyClDecl1 NoParentTyCon rec_info decl } + ; tcTyClDecl1 Nothing rec_info decl } -- "type family" declarations -tcTyClDecl1 :: TyConParent -> RecTyInfo -> TyClDecl Name -> TcM [TyThing] +tcTyClDecl1 :: Maybe Class -> RecTyInfo -> TyClDecl Name -> TcM [TyThing] tcTyClDecl1 parent _rec_info (FamDecl { tcdFam = fd }) = tcFamDecl1 parent fd -- "type" synonym declaration tcTyClDecl1 _parent rec_info (SynDecl { tcdLName = L _ tc_name, tcdTyVars = tvs, tcdRhs = rhs }) - = ASSERT( isNoParent _parent ) + = ASSERT( isNothing _parent ) tcTyClTyVars tc_name tvs $ \ tvs' kind -> tcTySynRhs rec_info tc_name tvs' kind rhs -- "data/newtype" declaration tcTyClDecl1 _parent rec_info (DataDecl { tcdLName = L _ tc_name, tcdTyVars = tvs, tcdDataDefn = defn }) - = ASSERT( isNoParent _parent ) + = ASSERT( isNothing _parent ) tcTyClTyVars tc_name tvs $ \ tvs' kind -> tcDataDefn rec_info tc_name tvs' kind defn @@ -625,7 +611,7 @@ tcTyClDecl1 _parent rec_info , tcdCtxt = ctxt, tcdMeths = meths , tcdFDs = fundeps, tcdSigs = sigs , tcdATs = ats, tcdATDefs = at_defs }) - = ASSERT( isNoParent _parent ) + = ASSERT( isNothing _parent ) do { (clas, tvs', gen_dm_env) <- fixM $ \ ~(clas,_,_) -> tcTyClTyVars class_name tvs $ \ tvs' kind -> do { MASSERT( isConstraintKind kind ) @@ -642,7 +628,7 @@ tcTyClDecl1 _parent rec_info -- Squeeze out any kind unification variables ; fds' <- mapM (addLocM tc_fundep) fundeps ; (sig_stuff, gen_dm_env) <- tcClassSigs class_name sigs meths - ; at_stuff <- tcClassATs class_name (AssocFamilyTyCon clas) ats at_defs + ; at_stuff <- tcClassATs class_name clas ats at_defs ; mindef <- tcClassMinimalDef class_name sigs sig_stuff ; clas <- buildClass class_name tvs' roles ctxt' fds' at_stuff @@ -650,7 +636,7 @@ tcTyClDecl1 _parent rec_info ; traceTc "tcClassDecl" (ppr fundeps $$ ppr tvs' $$ ppr fds') ; return (clas, tvs', gen_dm_env) } - ; let { gen_dm_ids = [ AnId (mkExportedLocalId VanillaId gen_dm_name gen_dm_ty) + ; let { gen_dm_ids = [ AnId (mkExportedLocalId DefMethId gen_dm_name gen_dm_ty) | (sel_id, GenDefMeth gen_dm_name) <- classOpItems clas , let gen_dm_tau = expectJust "tcTyClDecl1" $ lookupNameEnv gen_dm_env (idName sel_id) @@ -681,10 +667,11 @@ tcFdTyVar (L _ name) Just tv' -> return tv' Nothing -> pprPanic "tcFdTyVar" (ppr name $$ ppr tv $$ ppr ty) } -tcFamDecl1 :: TyConParent -> FamilyDecl Name -> TcM [TyThing] -tcFamDecl1 parent (FamilyDecl { fdInfo = OpenTypeFamily, fdLName = L _ tc_name - , fdTyVars = tvs, fdResultSig = L _ sig - , fdInjectivityAnn = inj }) +tcFamDecl1 :: Maybe Class -> FamilyDecl Name -> TcM [TyThing] +tcFamDecl1 parent + (FamilyDecl { fdInfo = OpenTypeFamily, fdLName = L _ tc_name + , fdTyVars = tvs, fdResultSig = L _ sig + , fdInjectivityAnn = inj }) = tcTyClTyVars tc_name tvs $ \ tvs' kind -> do { traceTc "open type family:" (ppr tc_name) ; checkFamFlag tc_name @@ -751,18 +738,21 @@ tcFamDecl1 parent -- the tycon. Exception: checking equations overlap done by dropDominatedAxioms tcFamDecl1 parent - (FamilyDecl {fdInfo = DataFamily, fdLName = L _ tc_name, fdTyVars = tvs}) + (FamilyDecl { fdInfo = DataFamily + , fdLName = L _ tc_name, fdTyVars = tvs + , fdResultSig = L _ sig }) = tcTyClTyVars tc_name tvs $ \ tvs' kind -> do { traceTc "data family:" (ppr tc_name) ; checkFamFlag tc_name ; extra_tvs <- tcDataKindSig kind + ; tc_rep_name <- newTyConRepName tc_name ; let final_tvs = tvs' ++ extra_tvs -- we may not need these - roles = map (const Nominal) final_tvs - tycon = buildAlgTyCon tc_name final_tvs roles Nothing [] - DataFamilyTyCon Recursive - False -- Not promotable to the kind level - True -- GADT syntax - parent + tycon = buildFamilyTyCon tc_name final_tvs + (resultVariableName sig) + (DataFamilyTyCon tc_rep_name) + liftedTypeKind -- RHS kind + parent + NotInjective ; return [ATyCon tycon] } -- | Maybe return a list of Bools that say whether a type family was declared @@ -819,14 +809,16 @@ tcDataDefn :: RecTyInfo -> Name -> [TyVar] -> Kind -> HsDataDefn Name -> TcM [TyThing] -- NB: not used for newtype/data instances (whether associated or not) -tcDataDefn rec_info tc_name tvs kind - (HsDataDefn { dd_ND = new_or_data, dd_cType = cType - , dd_ctxt = ctxt, dd_kindSig = mb_ksig - , dd_cons = cons' }) +tcDataDefn rec_info -- Knot-tied; don't look at this eagerly + tc_name tvs kind + (HsDataDefn { dd_ND = new_or_data, dd_cType = cType + , dd_ctxt = ctxt, dd_kindSig = mb_ksig + , dd_cons = cons' }) = let cons = cons' -- AZ List monad coming in do { extra_tvs <- tcDataKindSig kind ; let final_tvs = tvs ++ extra_tvs roles = rti_roles rec_info tc_name + is_prom = rti_promotable rec_info -- Knot-tied ; stupid_tc_theta <- tcHsContext ctxt ; stupid_theta <- zonkTcTypeToTypes emptyZonkEnv stupid_tc_theta ; kind_signatures <- xoptM Opt_KindSignatures @@ -844,20 +836,25 @@ tcDataDefn rec_info tc_name tvs kind ; tycon <- fixM $ \ tycon -> do { let res_ty = mkTyConApp tycon (mkTyVarTys final_tvs) - ; data_cons <- tcConDecls new_or_data tycon (final_tvs, res_ty) cons - ; tc_rhs <- - if null cons && is_boot -- In a hs-boot file, empty cons means - then return totallyAbstractTyConRhs -- "don't know"; hence totally Abstract - else case new_or_data of - DataType -> return (mkDataTyConRhs data_cons) - NewType -> ASSERT( not (null data_cons) ) - mkNewTyConRhs tc_name tycon (head data_cons) + ; data_cons <- tcConDecls new_or_data is_prom tycon (final_tvs, res_ty) cons + ; tc_rhs <- mk_tc_rhs is_boot tycon data_cons + ; tc_rep_nm <- newTyConRepName tc_name ; return (buildAlgTyCon tc_name final_tvs roles (fmap unLoc cType) stupid_theta tc_rhs (rti_is_rec rec_info tc_name) - (rti_promotable rec_info) - gadt_syntax NoParentTyCon) } + is_prom + gadt_syntax + (VanillaAlgTyCon tc_rep_nm)) } ; return [ATyCon tycon] } + where + mk_tc_rhs is_boot tycon data_cons + | null data_cons, is_boot -- In a hs-boot file, empty cons means + = return totallyAbstractTyConRhs -- "don't know"; hence totally Abstract + | otherwise + = case new_or_data of + DataType -> return (mkDataTyConRhs data_cons) + NewType -> ASSERT( not (null data_cons) ) + mkNewTyConRhs tc_name tycon (head data_cons) {- ************************************************************************ @@ -882,11 +879,11 @@ families. -} tcClassATs :: Name -- The class name (not knot-tied) - -> TyConParent -- The class parent of this associated type + -> Class -- The class parent of this associated type -> [LFamilyDecl Name] -- Associated types. -> [LTyFamDefltEqn Name] -- Associated type defaults. -> TcM [ClassATItem] -tcClassATs class_name parent ats at_defs +tcClassATs class_name cls ats at_defs = do { -- Complain about associated type defaults for non associated-types sequence_ [ failWithTc (badATErr class_name n) | n <- map at_def_tycon at_defs @@ -907,7 +904,7 @@ tcClassATs class_name parent ats at_defs (at_def_tycon at_def) [at_def]) emptyNameEnv at_defs - tc_at at = do { [ATyCon fam_tc] <- addLocM (tcFamDecl1 parent) at + tc_at at = do { [ATyCon fam_tc] <- addLocM (tcFamDecl1 (Just cls)) at ; let at_defs = lookupNameEnv at_defs_map (at_fam_name at) `orElse` [] ; atd <- tcDefaultAssocDecl fam_tc at_defs @@ -1240,20 +1237,21 @@ consUseGadtSyntax _ = False -- All constructors have same shape ----------------------------------- -tcConDecls :: NewOrData -> TyCon -> ([TyVar], Type) +tcConDecls :: NewOrData -> Bool -> TyCon -> ([TyVar], Type) -> [LConDecl Name] -> TcM [DataCon] -tcConDecls new_or_data rep_tycon (tmpl_tvs, res_tmpl) cons - = concatMapM (addLocM $ tcConDecl new_or_data rep_tycon tmpl_tvs res_tmpl) - cons +tcConDecls new_or_data is_prom rep_tycon (tmpl_tvs, res_tmpl) + = concatMapM $ addLocM $ + tcConDecl new_or_data is_prom rep_tycon tmpl_tvs res_tmpl tcConDecl :: NewOrData - -> TyCon -- Representation tycon + -> Bool -- TyCon is promotable? Knot-tied! + -> TyCon -- Representation tycon. Knot-tied! -> [TyVar] -> Type -- Return type template (with its template tyvars) -- (tvs, T tys), where T is the family TyCon -> ConDecl Name -> TcM [DataCon] -tcConDecl new_or_data rep_tycon tmpl_tvs res_tmpl -- Data types +tcConDecl new_or_data is_prom rep_tycon tmpl_tvs res_tmpl (ConDecl { con_names = names , con_qvars = hs_tvs, con_cxt = hs_ctxt , con_details = hs_details, con_res = hs_res_ty }) @@ -1298,7 +1296,11 @@ tcConDecl new_or_data rep_tycon tmpl_tvs res_tmpl -- Data types ; let buildOneDataCon (L _ name) = do { is_infix <- tcConIsInfix name hs_details res_ty + ; rep_nm <- newTyConRepName name + ; buildDataCon fam_envs name is_infix + (if is_prom then Promoted rep_nm else NotPromoted) + -- Must be lazy in is_prom because it is knot-tied stricts Nothing field_lbls univ_tvs ex_tvs eq_preds ctxt arg_tys res_ty' rep_tycon @@ -1306,6 +1308,7 @@ tcConDecl new_or_data rep_tycon tmpl_tvs res_tmpl -- Data types -- constructor type signature into the data constructor; -- that way checkValidDataCon can complain if it's wrong. } + ; traceTc "tcConDecl 2" (ppr names) ; mapM buildOneDataCon names } @@ -1569,6 +1572,7 @@ checkValidTyCon tc ; checkTc hsBoot $ ptext (sLit "You may define an abstract closed type family") $$ ptext (sLit "only in a .hs-boot file") } + ; DataFamilyTyCon {} -> return () ; OpenSynFamilyTyCon -> return () ; BuiltInSynFamTyCon _ -> return () } @@ -1986,217 +1990,7 @@ checkValidRoles tc doc, ptext (sLit "Please report this as a GHC bug: http://www.haskell.org/ghc/reportabug")] -{- -************************************************************************ -* * - Building record selectors -* * -************************************************************************ --} - -mkDefaultMethodIds :: [TyThing] -> [Id] --- See Note [Default method Ids and Template Haskell] -mkDefaultMethodIds things - = [ mkExportedLocalId VanillaId dm_name (idType sel_id) - | ATyCon tc <- things - , Just cls <- [tyConClass_maybe tc] - , (sel_id, DefMeth dm_name) <- classOpItems cls ] - -{- -Note [Default method Ids and Template Haskell] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider this (Trac #4169): - class Numeric a where - fromIntegerNum :: a - fromIntegerNum = ... - - ast :: Q [Dec] - ast = [d| instance Numeric Int |] - -When we typecheck 'ast' we have done the first pass over the class decl -(in tcTyClDecls), but we have not yet typechecked the default-method -declarations (because they can mention value declarations). So we -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 tycons - = ValBindsOut [(NonRecursive, b) | b <- binds] sigs - where - (sigs, binds) = unzip rec_sels - rec_sels = map mkRecSelBind [ (tc,fld) - | ATyCon tc <- tycons - , fld <- tyConFields tc ] - -mkRecSelBind :: (TyCon, FieldLabel) -> (LSig Name, LHsBinds Name) -mkRecSelBind (tycon, sel_name) - = (L loc (IdSig sel_id), unitBag (L loc sel_bind)) - where - loc = getSrcSpan sel_name - sel_id = mkExportedLocalId rec_details sel_name sel_ty - rec_details = RecSelId { sel_tycon = tycon, sel_naughty = is_naughty } - - -- Find a representative constructor, con1 - all_cons = tyConDataCons tycon - cons_w_field = [ con | con <- all_cons - , sel_name `elem` dataConFieldLabels con ] - con1 = ASSERT( not (null cons_w_field) ) head cons_w_field - - -- Selector type; Note [Polymorphic selectors] - field_ty = dataConFieldType con1 sel_name - 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 (dataConStupidTheta con1) $ -- Urgh! - mkPhiTy field_theta $ -- Urgh! - mkFunTy data_ty field_tau - - -- Make the binding: sel (C2 { fld = x }) = x - -- sel (C7 { fld = x }) = x - -- where cons_w_field = [C2,C7] - sel_bind = mkTopFunBind Generated sel_lname alts - where - alts | is_naughty = [mkSimpleMatch [] unit_rhs] - | otherwise = map mk_match cons_w_field ++ deflt - mk_match con = mkSimpleMatch [L loc (mk_sel_pat con)] - (L loc (HsVar field_var)) - mk_sel_pat con = ConPatIn (L loc (getName con)) (RecCon rec_fields) - rec_fields = HsRecFields { rec_flds = [rec_field], rec_dotdot = Nothing } - rec_field = noLoc (HsRecField { hsRecFieldId = sel_lname - , hsRecFieldArg = L loc (VarPat field_var) - , hsRecPun = False }) - sel_lname = L loc sel_name - field_var = mkInternalName (mkBuiltinUnique 1) (getOccName sel_name) loc - - -- Add catch-all default case unless the case is exhaustive - -- We do this explicitly so that we get a nice error message that - -- mentions this particular record selector - deflt | all dealt_with all_cons = [] - | otherwise = [mkSimpleMatch [L loc (WildPat placeHolderType)] - (mkHsApp (L loc (HsVar (getName rEC_SEL_ERROR_ID))) - (L loc (HsLit msg_lit)))] - - -- Do not add a default case unless there are unmatched - -- constructors. We must take account of GADTs, else we - -- get overlap warning messages from the pattern-match checker - -- NB: we need to pass type args for the *representation* TyCon - -- to dataConCannotMatch, hence the calculation of inst_tys - -- This matters in data families - -- data instance T Int a where - -- A :: { fld :: Int } -> T Int Bool - -- B :: { fld :: Int } -> T Int Char - 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 "" $ unsafeMkByteString $ - occNameString (getOccName sel_name) - ---------------- -tyConFields :: TyCon -> [FieldLabel] -tyConFields tc - | isAlgTyCon tc = nub (concatMap dataConFieldLabels (tyConDataCons tc)) - | otherwise = [] - -{- -Note [Polymorphic selectors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When a record has a polymorphic field, we pull the foralls out to the front. - data T = MkT { f :: forall a. [a] -> a } -Then f :: forall a. T -> [a] -> a -NOT f :: T -> forall a. [a] -> a - -This is horrid. It's only needed in deeply obscure cases, which I hate. -The only case I know is test tc163, which is worth looking at. It's far -from clear that this test should succeed at all! - -Note [Naughty record selectors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -A "naughty" field is one for which we can't define a record -selector, because an existential type variable would escape. For example: - data T = forall a. MkT { x,y::a } -We obviously can't define - x (MkT v _) = v -Nevertheless we *do* put a RecSelId into the type environment -so that if the user tries to use 'x' as a selector we can bleat -helpfully, rather than saying unhelpfully that 'x' is not in scope. -Hence the sel_naughty flag, to identify record selectors that don't really exist. - -In general, a field is "naughty" if its type mentions a type variable that -isn't in the result type of the constructor. Note that this *allows* -GADT record selectors (Note [GADT record selectors]) whose types may look -like sel :: T [a] -> a - -For naughty selectors we make a dummy binding - sel = () -for naughty selectors, so that the later type-check will add them to the -environment, and they'll be exported. The function is never called, because -the tyepchecker spots the sel_naughty field. - -Note [GADT record selectors] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -For GADTs, we require that all constructors with a common field 'f' have the same -result type (modulo alpha conversion). [Checked in TcTyClsDecls.checkValidTyCon] -E.g. - data T where - T1 { f :: Maybe a } :: T [a] - T2 { f :: Maybe a, y :: b } :: T [a] - T3 :: T Int - -and now the selector takes that result type as its argument: - f :: forall a. T [a] -> Maybe a - -Details: the "real" types of T1,T2 are: - T1 :: forall r a. (r~[a]) => a -> T r - T2 :: forall r a b. (r~[a]) => a -> b -> T r - -So the selector loooks like this: - f :: forall a. T [a] -> Maybe a - f (a:*) (t:T [a]) - = case t of - T1 c (g:[a]~[c]) (v:Maybe c) -> v `cast` Maybe (right (sym g)) - T2 c d (g:[a]~[c]) (v:Maybe c) (w:d) -> v `cast` Maybe (right (sym g)) - T3 -> error "T3 does not have field f" - -Note the forall'd tyvars of the selector are just the free tyvars -of the result type; there may be other tyvars in the constructor's -type (e.g. 'b' in T2). - -Note the need for casts in the result! - -Note [Selector running example] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It's OK to combine GADTs and type families. Here's a running example: - - data instance T [a] where - T1 { fld :: b } :: T [Maybe b] - -The representation type looks like this - data :R7T a where - T1 { fld :: b } :: :R7T (Maybe b) - -and there's coercion from the family type to the representation type - :CoR7T a :: T [a] ~ :R7T a - -The selector we want for fld looks like this: - - fld :: forall b. T [Maybe b] -> b - fld = /\b. \(d::T [Maybe b]). - case d `cast` :CoR7T (Maybe b) of - T1 (x::b) -> x - -The scrutinee of the case has type :R7T (Maybe b), which can be -gotten by appying the eq_spec to the univ_tvs of the data con. - -************************************************************************ +{- ********************************************************************* * * Error messages * * diff --git a/compiler/typecheck/TcTyDecls.hs b/compiler/typecheck/TcTyDecls.hs index 827f21793c..5f0abce675 100644 --- a/compiler/typecheck/TcTyDecls.hs +++ b/compiler/typecheck/TcTyDecls.hs @@ -14,37 +14,52 @@ files for imported data types. module TcTyDecls( calcRecFlags, RecTyInfo(..), calcSynCycles, calcClassCycles, - RoleAnnots, extractRoleAnnots, emptyRoleAnnots, lookupRoleAnnots + + -- * Roles + RoleAnnots, extractRoleAnnots, emptyRoleAnnots, lookupRoleAnnots, + + -- * Implicits + tcAddImplicits ) where #include "HsVersions.h" -import TypeRep +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 HsSyn import Class import Type -import Kind -import TcRnTypes( SelfBootInfo(..) ) +import HscTypes import TyCon import DataCon -import Var import Name import NameEnv +import Id +import IdInfo import VarEnv import VarSet import NameSet import Coercion ( ltRole ) +import Bag import Digraph import BasicTypes import SrcLoc +import Unique ( mkBuiltinUnique ) import Outputable import UniqSet import Util import Maybes import Data.List +import FastString ( unsafeMkByteString ) #if __GLASGOW_HASKELL__ < 709 -import Control.Applicative (Applicative(..)) +-- import Control.Applicative (Applicative(..)) #endif import Control.Monad @@ -372,7 +387,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 @@ -466,70 +481,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 * * ************************************************************************ @@ -851,3 +802,240 @@ updateRoleEnv name n role role_env' = extendNameEnv role_env name roles' in 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 tycons + +---------------------------- +mkDefaultMethodIds :: [TyCon] -> [Id] +-- See Note [Default method Ids and Template Haskell] +mkDefaultMethodIds tycons + = [ mkExportedLocalId DefMethId dm_name (idType sel_id) + | tc <- tycons + , Just cls <- [tyConClass_maybe tc] + , (sel_id, DefMeth dm_name) <- classOpItems cls ] + +{- Note [Default method Ids and Template Haskell] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this (Trac #4169): + class Numeric a where + fromIntegerNum :: a + fromIntegerNum = ... + + ast :: Q [Dec] + ast = [d| instance Numeric Int |] + +When we typecheck 'ast' we have done the first pass over the class decl +(in tcTyClDecls), but we have not yet typechecked the default-method +declarations (because they can mention value declarations). So we +must bring the default method Ids into scope first (so they can be seen +when typechecking the [d| .. |] quote, and typecheck them later. +-} + +{- ********************************************************************* +* * + Building record selectors +* * +********************************************************************* -} + +mkRecSelBinds :: [TyCon] -> TcM ([Id], [LHsBinds Id]) +mkRecSelBinds tycons + = 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 <- tyConFields 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, sel_name) + = (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 + rec_details = RecSelId { sel_tycon = tycon, sel_naughty = is_naughty } + + -- Find a representative constructor, con1 + all_cons = tyConDataCons tycon + cons_w_field = [ con | con <- all_cons + , sel_name `elem` dataConFieldLabels con ] + con1 = ASSERT( not (null cons_w_field) ) head cons_w_field + + -- Selector type; Note [Polymorphic selectors] + field_ty = dataConFieldType con1 sel_name + 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 (dataConStupidTheta con1) $ -- Urgh! + mkPhiTy field_theta $ -- Urgh! + mkFunTy data_ty field_tau + + -- Make the binding: sel (C2 { fld = x }) = x + -- sel (C7 { fld = x }) = x + -- where cons_w_field = [C2,C7] + sel_bind = mkTopFunBind Generated sel_lname alts + where + alts | is_naughty = [mkSimpleMatch [] unit_rhs] + | otherwise = map mk_match cons_w_field ++ deflt + mk_match con = mkSimpleMatch [L loc (mk_sel_pat con)] + (L loc (HsVar field_var)) + mk_sel_pat con = ConPatIn (L loc (getName con)) (RecCon rec_fields) + rec_fields = HsRecFields { rec_flds = [rec_field], rec_dotdot = Nothing } + rec_field = noLoc (HsRecField { hsRecFieldId = sel_lname + , hsRecFieldArg = L loc (VarPat field_var) + , hsRecPun = False }) + sel_lname = L loc sel_name + field_var = mkInternalName (mkBuiltinUnique 1) (getOccName sel_name) loc + + -- Add catch-all default case unless the case is exhaustive + -- We do this explicitly so that we get a nice error message that + -- mentions this particular record selector + deflt | all dealt_with all_cons = [] + | otherwise = [mkSimpleMatch [L loc (WildPat placeHolderType)] + (mkHsApp (L loc (HsVar (getName rEC_SEL_ERROR_ID))) + (L loc (HsLit msg_lit)))] + + -- Do not add a default case unless there are unmatched + -- constructors. We must take account of GADTs, else we + -- get overlap warning messages from the pattern-match checker + -- NB: we need to pass type args for the *representation* TyCon + -- to dataConCannotMatch, hence the calculation of inst_tys + -- This matters in data families + -- data instance T Int a where + -- A :: { fld :: Int } -> T Int Bool + -- B :: { fld :: Int } -> T Int Char + 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 "" $ unsafeMkByteString $ + occNameString (getOccName sel_name) + +--------------- +tyConFields :: TyCon -> [FieldLabel] +tyConFields tc + | isAlgTyCon tc = nub (concatMap dataConFieldLabels (tyConDataCons tc)) + | otherwise = [] + +{- +Note [Polymorphic selectors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When a record has a polymorphic field, we pull the foralls out to the front. + data T = MkT { f :: forall a. [a] -> a } +Then f :: forall a. T -> [a] -> a +NOT f :: T -> forall a. [a] -> a + +This is horrid. It's only needed in deeply obscure cases, which I hate. +The only case I know is test tc163, which is worth looking at. It's far +from clear that this test should succeed at all! + +Note [Naughty record selectors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A "naughty" field is one for which we can't define a record +selector, because an existential type variable would escape. For example: + data T = forall a. MkT { x,y::a } +We obviously can't define + x (MkT v _) = v +Nevertheless we *do* put a RecSelId into the type environment +so that if the user tries to use 'x' as a selector we can bleat +helpfully, rather than saying unhelpfully that 'x' is not in scope. +Hence the sel_naughty flag, to identify record selectors that don't really exist. + +In general, a field is "naughty" if its type mentions a type variable that +isn't in the result type of the constructor. Note that this *allows* +GADT record selectors (Note [GADT record selectors]) whose types may look +like sel :: T [a] -> a + +For naughty selectors we make a dummy binding + sel = () +for naughty selectors, so that the later type-check will add them to the +environment, and they'll be exported. The function is never called, because +the tyepchecker spots the sel_naughty field. + +Note [GADT record selectors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For GADTs, we require that all constructors with a common field 'f' have the same +result type (modulo alpha conversion). [Checked in TcTyClsDecls.checkValidTyCon] +E.g. + data T where + T1 { f :: Maybe a } :: T [a] + T2 { f :: Maybe a, y :: b } :: T [a] + T3 :: T Int + +and now the selector takes that result type as its argument: + f :: forall a. T [a] -> Maybe a + +Details: the "real" types of T1,T2 are: + T1 :: forall r a. (r~[a]) => a -> T r + T2 :: forall r a b. (r~[a]) => a -> b -> T r + +So the selector loooks like this: + f :: forall a. T [a] -> Maybe a + f (a:*) (t:T [a]) + = case t of + T1 c (g:[a]~[c]) (v:Maybe c) -> v `cast` Maybe (right (sym g)) + T2 c d (g:[a]~[c]) (v:Maybe c) (w:d) -> v `cast` Maybe (right (sym g)) + T3 -> error "T3 does not have field f" + +Note the forall'd tyvars of the selector are just the free tyvars +of the result type; there may be other tyvars in the constructor's +type (e.g. 'b' in T2). + +Note the need for casts in the result! + +Note [Selector running example] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's OK to combine GADTs and type families. Here's a running example: + + data instance T [a] where + T1 { fld :: b } :: T [Maybe b] + +The representation type looks like this + data :R7T a where + T1 { fld :: b } :: :R7T (Maybe b) + +and there's coercion from the family type to the representation type + :CoR7T a :: T [a] ~ :R7T a + +The selector we want for fld looks like this: + + fld :: forall b. T [Maybe b] -> b + fld = /\b. \(d::T [Maybe b]). + case d `cast` :CoR7T (Maybe b) of + T1 (x::b) -> x + +The scrutinee of the case has type :R7T (Maybe b), which can be +gotten by appying the eq_spec to the univ_tvs of the data con. + +-} 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..08cfe86342 --- /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 (packageKeyFS (modulePackageKey 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 = packageKeyString (modulePackageKey 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 9aa0dfd3bf..3051608de8 100644 --- a/compiler/types/TyCon.hs +++ b/compiler/types/TyCon.hs @@ -13,8 +13,8 @@ module TyCon( TyCon, FieldLabel, AlgTyConRhs(..), visibleDataCons, - TyConParent(..), isNoParent, - FamTyConFlav(..), Role(..), Injectivity(..), + AlgTyConFlav(..), isNoParent, + FamTyConFlav(..), Role(..), Promoted(..), Injectivity(..), -- ** Constructing TyCons mkAlgTyCon, @@ -39,7 +39,7 @@ module TyCon( mightBeUnsaturatedTyCon, isPromotedDataCon, isPromotedTyCon, isPromotedDataCon_maybe, isPromotedTyCon_maybe, - promotableTyCon_maybe, promoteTyCon, + promotableTyCon_maybe, isPromotableTyCon, promoteTyCon, isDataTyCon, isProductTyCon, isDataProductTyCon_maybe, isEnumerationTyCon, @@ -68,7 +68,6 @@ module TyCon( tyConStupidTheta, tyConArity, tyConRoles, - tyConParent, tyConFlavour, tyConTuple_maybe, tyConClass_maybe, tyConFamInst_maybe, tyConFamInstSig_maybe, tyConFamilyCoercion_maybe, @@ -85,6 +84,9 @@ module TyCon( newTyConCo, newTyConCo_maybe, pprPromotionQuote, + -- * Runtime type representation + TyConRepName, tyConRepName_maybe, + -- * Primitive representations of Types PrimRep(..), PrimElemRep(..), tyConPrimRep, isVoidRep, isGcPtrRep, @@ -183,8 +185,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 @@ -216,9 +218,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 @@ -262,7 +264,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 @@ -368,15 +370,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 @@ -430,12 +443,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 @@ -465,7 +477,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 @@ -486,7 +499,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 @@ -501,8 +514,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 @@ -511,7 +525,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 @@ -535,9 +549,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. @@ -547,7 +565,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. @@ -556,7 +575,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 @@ -574,20 +594,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 @@ -641,18 +647,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] @@ -660,26 +663,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 @@ -700,27 +712,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 -------------------- @@ -731,8 +742,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 }@ @@ -870,7 +895,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 * * ************************************************************************ @@ -1024,13 +1076,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 @@ -1046,11 +1099,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 { @@ -1071,11 +1125,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' @@ -1083,8 +1138,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 { @@ -1096,7 +1151,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 }, algTcParent = parent, algTcRec = NonRecursive, algTcGadtSyntax = False, @@ -1106,20 +1162,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, @@ -1127,7 +1184,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' @@ -1145,7 +1203,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 @@ -1164,15 +1222,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 @@ -1187,7 +1246,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 @@ -1244,7 +1307,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 @@ -1280,7 +1342,6 @@ isGenerativeTyCon = isInjectiveTyCon isGenInjAlgRhs :: AlgTyConRhs -> Bool isGenInjAlgRhs (TupleTyCon {}) = True isGenInjAlgRhs (DataTyCon {}) = True -isGenInjAlgRhs (DataFamilyTyCon {}) = False isGenInjAlgRhs (AbstractTyCon distinct) = distinct isGenInjAlgRhs (NewTyCon {}) = False @@ -1369,8 +1430,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)? @@ -1379,8 +1439,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? @@ -1400,21 +1461,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 @@ -1439,10 +1505,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'? @@ -1450,9 +1515,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 @@ -1491,14 +1555,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 @@ -1540,13 +1609,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 @@ -1639,7 +1705,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) @@ -1736,50 +1801,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 {- ************************************************************************ @@ -1815,16 +1871,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" @@ -1832,14 +1889,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/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..f36db6a1d9 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,18 +66,13 @@ module Data.Typeable.Internal ( typeRepFingerprint, rnfTypeRep, showsTypeRep, - tyConString, - rnfTyCon, - listTc, funTc, typeRepKinds, - typeNatTypeRep, - typeSymbolTypeRep + typeLitTypeRep, ) where import GHC.Base import GHC.Word import GHC.Show -import GHC.TypeLits import Data.Proxy import GHC.Fingerprint.Type @@ -68,9 +82,109 @@ 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)) + +mkTypeLitTyCon :: Addr# -> TyCon +mkTypeLitTyCon name = mkTyCon3# "base"# "GHC.TypeLits"# 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 +195,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 +250,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,19 +263,9 @@ 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 +-- | An internal function, to make representations for type literals. +typeLitTypeRep :: Addr# -> TypeRep +typeLitTypeRep nm = mkTyConApp (mkTypeLitTyCon nm) [] ----------------- Observation --------------------- @@ -190,16 +281,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 +360,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 +375,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 +384,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,34 +396,53 @@ showTuple args = showChar '(' . showArgs (showChar ',') args . showChar ')' -listTc :: TyCon -listTc = typeRepTyCon (typeOf [()]) +{- ********************************************************* + TyCon definitions for GHC.Types + + The Ty +********************************************************* -} + +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 (->))) - - --- | Used to make `'Typeable' instance for things of kind Nat -typeNatTypeRep :: KnownNat a => Proxy# a -> TypeRep -typeNatTypeRep p = typeLitTypeRep (show (natVal' p)) - --- | Used to make `'Typeable' instance for things of kind Symbol -typeSymbolTypeRep :: KnownSymbol a => Proxy# a -> TypeRep -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 - - +funTc = tcFun -- Legacy 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 77c8f7583f..202b0e0c92 100644 --- a/libraries/ghc-prim/GHC/Types.hs +++ b/libraries/ghc-prim/GHC/Types.hs @@ -34,7 +34,6 @@ module GHC.Types ( ) where import GHC.Prim -import GHC.Tuple () infixr 5 : @@ -309,3 +308,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/utils/haddock b/utils/haddock -Subproject 5890a2d503b3200e9897ce331ad61d808a67fca +Subproject 289ef817aad02c341beb6d4c28ba0495872f5a0 |