diff options
Diffstat (limited to 'compiler')
43 files changed, 1116 insertions, 1713 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 |