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