diff options
| author | Ben Gamari <ben@smart-cactus.org> | 2017-02-02 01:29:26 -0500 |
|---|---|---|
| committer | Ben Gamari <ben@smart-cactus.org> | 2017-02-18 00:09:27 -0500 |
| commit | 8fa4bf9ab3f4ea4b208f4a43cc90857987e6d497 (patch) | |
| tree | ad5f6ea9449e0ff9e92edb1f67c86cb38300cd71 | |
| parent | b207b536ded40156f9adb168565ca78e1eef2c74 (diff) | |
| download | haskell-8fa4bf9ab3f4ea4b208f4a43cc90857987e6d497.tar.gz | |
Type-indexed Typeable
This at long last realizes the ideas for type-indexed Typeable discussed in A
Reflection on Types (#11011). The general sketch of the project is described on
the Wiki (Typeable/BenGamari). The general idea is that we are adding a type
index to `TypeRep`,
data TypeRep (a :: k)
This index allows the typechecker to reason about the type represented by the `TypeRep`.
This index representation mechanism is exposed as `Type.Reflection`, which also provides
a number of patterns for inspecting `TypeRep`s,
```lang=haskell
pattern TRFun :: forall k (fun :: k). ()
=> forall (r1 :: RuntimeRep) (r2 :: RuntimeRep)
(arg :: TYPE r1) (res :: TYPE r2).
(k ~ Type, fun ~~ (arg -> res))
=> TypeRep arg
-> TypeRep res
-> TypeRep fun
pattern TRApp :: forall k2 (t :: k2). ()
=> forall k1 (a :: k1 -> k2) (b :: k1). (t ~ a b)
=> TypeRep a -> TypeRep b -> TypeRep t
-- | Pattern match on a type constructor.
pattern TRCon :: forall k (a :: k). TyCon -> TypeRep a
-- | Pattern match on a type constructor including its instantiated kind
-- variables.
pattern TRCon' :: forall k (a :: k). TyCon -> [SomeTypeRep] -> TypeRep a
```
In addition, we give the user access to the kind of a `TypeRep` (#10343),
typeRepKind :: TypeRep (a :: k) -> TypeRep k
Moreover, all of this plays nicely with 8.2's levity polymorphism, including the
newly levity polymorphic (->) type constructor.
Library changes
---------------
The primary change here is the introduction of a Type.Reflection module to base.
This module provides access to the new type-indexed TypeRep introduced in this
patch. We also continue to provide the unindexed Data.Typeable interface, which
is simply a type synonym for the existentially quantified SomeTypeRep,
data SomeTypeRep where SomeTypeRep :: TypeRep a -> SomeTypeRep
Naturally, this change also touched Data.Dynamic, which can now export the
Dynamic data constructor. Moreover, I removed a blanket reexport of
Data.Typeable from Data.Dynamic (which itself doesn't even import Data.Typeable
now).
We also add a kind heterogeneous type equality type, (:~~:), to
Data.Type.Equality.
Implementation
--------------
The implementation strategy is described in Note [Grand plan for Typeable] in
TcTypeable. None of it was difficult, but it did exercise a number of parts of
the new levity polymorphism story which had not yet been exercised, which took
some sorting out.
The rough idea is that we augment the TyCon produced for each type constructor
with information about the constructor's kind (which we call a KindRep). This
allows us to reconstruct the monomorphic result kind of an particular
instantiation of a type constructor given its kind arguments.
Unfortunately all of this takes a fair amount of work to generate and send
through the compilation pipeline. In particular, the KindReps can unfortunately
get quite large. Moreover, the simplifier will float out various pieces of them,
resulting in numerous top-level bindings. Consequently we mark the KindRep
bindings as noinline, ensuring that the float-outs don't make it into the
interface file. This is important since there is generally little benefit to
inlining KindReps and they would otherwise strongly affect compiler performance.
Performance
-----------
Initially I was hoping to also clear up the remaining holes in Typeable's
coverage by adding support for both unboxed tuples (#12409) and unboxed sums
(#13276). While the former was fairly straightforward, the latter ended up being
quite difficult: while the implementation can support them easily, enabling this
support causes thousands of Typeable bindings to be emitted to the GHC.Types as
each arity-N sum tycon brings with it N promoted datacons, each of which has a
KindRep whose size which itself scales with N. Doing this was simply too
expensive to be practical; consequently I've disabled support for the time
being.
Even after disabling sums this change regresses compiler performance far more
than I would like. In particular there are several testcases in the testsuite
which consist mostly of types which regress by over 30% in compiler allocations.
These include (considering the "bytes allocated" metric),
* T1969: +10%
* T10858: +23%
* T3294: +19%
* T5631: +41%
* T6048: +23%
* T9675: +20%
* T9872a: +5.2%
* T9872d: +12%
* T9233: +10%
* T10370: +34%
* T12425: +30%
* T12234: +16%
* 13035: +17%
* T4029: +6.1%
I've spent quite some time chasing down the source of this regression and while
I was able to make som improvements, I think this approach of generating
Typeable bindings at time of type definition is doomed to give us unnecessarily
large compile-time overhead.
In the future I think we should consider moving some of all of the Typeable
binding generation logic back to the solver (where it was prior to
91c6b1f54aea658b0056caec45655475897f1972). I've opened #13261 documenting this
proposal.
79 files changed, 3111 insertions, 1026 deletions
diff --git a/compiler/backpack/RnModIface.hs b/compiler/backpack/RnModIface.hs index d77d061fb9..1b11a0f900 100644 --- a/compiler/backpack/RnModIface.hs +++ b/compiler/backpack/RnModIface.hs @@ -405,6 +405,9 @@ rnIfaceDecl d@IfaceId{} = do IfDFunId -> rnIfaceNeverExported (ifName d) _ | isDefaultMethodOcc (occName (ifName d)) -> rnIfaceNeverExported (ifName d) + -- Typeable bindings. See Note [Grand plan for Typeable]. + _ | isTypeableBindOcc (occName (ifName d)) + -> rnIfaceNeverExported (ifName d) | otherwise -> rnIfaceGlobal (ifName d) ty <- rnIfaceType (ifType d) details <- rnIfaceIdDetails (ifIdDetails d) diff --git a/compiler/basicTypes/MkId.hs b/compiler/basicTypes/MkId.hs index 65860d9045..8a204be421 100644 --- a/compiler/basicTypes/MkId.hs +++ b/compiler/basicTypes/MkId.hs @@ -31,7 +31,7 @@ module MkId ( voidPrimId, voidArgId, nullAddrId, seqId, lazyId, lazyIdKey, runRWId, coercionTokenId, magicDictId, coerceId, - proxyHashId, noinlineIdName, + proxyHashId, noinlineId, noinlineIdName, -- Re-export error Ids module PrelRules diff --git a/compiler/basicTypes/OccName.hs b/compiler/basicTypes/OccName.hs index 0de9801117..cde7cc569b 100644 --- a/compiler/basicTypes/OccName.hs +++ b/compiler/basicTypes/OccName.hs @@ -57,7 +57,7 @@ module OccName ( isDerivedOccName, mkDataConWrapperOcc, mkWorkerOcc, mkMatcherOcc, mkBuilderOcc, - mkDefaultMethodOcc, isDefaultMethodOcc, + mkDefaultMethodOcc, isDefaultMethodOcc, isTypeableBindOcc, mkNewTyCoOcc, mkClassOpAuxOcc, mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc, mkClassDataConOcc, mkDictOcc, mkIPOcc, @@ -601,6 +601,16 @@ isDefaultMethodOcc occ = '$':'d':'m':_ -> True _ -> False +-- | Is an 'OccName' one of a Typeable @TyCon@ or @Module@ binding? +-- This is needed as these bindings are renamed differently. +-- See Note [Grand plan for Typeable] in TcTypeable. +isTypeableBindOcc :: OccName -> Bool +isTypeableBindOcc occ = + case occNameString occ of + '$':'t':'c':_ -> True -- mkTyConRepOcc + '$':'t':'r':_ -> True -- Module binding + _ -> False + mkDataConWrapperOcc, mkWorkerOcc, mkMatcherOcc, mkBuilderOcc, mkDefaultMethodOcc, diff --git a/compiler/coreSyn/CoreLint.hs b/compiler/coreSyn/CoreLint.hs index 2f34046d6a..4aa7d44713 100644 --- a/compiler/coreSyn/CoreLint.hs +++ b/compiler/coreSyn/CoreLint.hs @@ -1031,7 +1031,7 @@ lintTyKind tyvar arg_ty -- and then apply it to both boxed and unboxed types. = do { arg_kind <- lintType arg_ty ; unless (arg_kind `eqType` tyvar_kind) - (addErrL (mkKindErrMsg tyvar arg_ty $$ (text "xx" <+> ppr arg_kind))) } + (addErrL (mkKindErrMsg tyvar arg_ty $$ (text "Linted Arg kind:" <+> ppr arg_kind))) } where tyvar_kind = tyVarKind tyvar diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs index b367d69a02..efe3e7a8da 100644 --- a/compiler/deSugar/DsBinds.hs +++ b/compiler/deSugar/DsBinds.hs @@ -38,7 +38,6 @@ import CoreFVs import Digraph import PrelNames -import TysPrim ( mkProxyPrimTy ) import TyCon import TcEvidence import TcType @@ -1195,49 +1194,71 @@ dsEvTypeable :: Type -> EvTypeable -> DsM CoreExpr -- This code is tightly coupled to the representation -- of TypeRep, in base library Data.Typeable.Internals dsEvTypeable ty ev - = do { tyCl <- dsLookupTyCon typeableClassName -- Typeable + = do { tyCl <- dsLookupTyCon typeableClassName -- Typeable ; let kind = typeKind ty Just typeable_data_con - = tyConSingleDataCon_maybe tyCl -- "Data constructor" - -- for Typeable + = 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) + ; rep_expr <- ds_ev_typeable ty ev -- :: TypeRep a -- Package up the method as `Typeable` dictionary - ; return $ mkConApp typeable_data_con [Type kind, Type ty, method] } + ; return $ mkConApp typeable_data_con [Type kind, Type ty, rep_expr] } +type TypeRepExpr = CoreExpr +-- | Returns a @CoreExpr :: TypeRep ty@ ds_ev_typeable :: Type -> EvTypeable -> DsM CoreExpr --- Returns a CoreExpr :: TypeRep ty -ds_ev_typeable ty (EvTypeableTyCon evs) - | Just (tc, ks) <- splitTyConApp_maybe ty - = 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 ] - - - ; tcRep <- tyConRep tc - ; kReps <- zipWithM getRep evs ks - ; return (mkRep tcRep kReps []) } +ds_ev_typeable ty (EvTypeableTyCon tc kind_ev) + = do { mkTrCon <- dsLookupGlobalId mkTrConName + -- mkTrCon :: forall k (a :: k). TyCon -> TypeRep k -> TypeRep a + ; someTypeRepTyCon <- dsLookupTyCon someTypeRepTyConName + ; someTypeRepDataCon <- dsLookupDataCon someTypeRepDataConName + -- SomeTypeRep :: forall k (a :: k). TypeRep a -> SomeTypeRep + + ; tc_rep <- tyConRep tc -- :: TyCon + ; let ks = tyConAppArgs ty + -- Construct a SomeTypeRep + toSomeTypeRep :: Type -> EvTerm -> DsM CoreExpr + toSomeTypeRep t ev = do + rep <- getRep ev t + return $ mkCoreConApps someTypeRepDataCon [Type (typeKind t), Type t, rep] + ; kind_arg_reps <- sequence $ zipWith toSomeTypeRep ks kind_ev -- :: TypeRep t + ; let -- :: [SomeTypeRep] + kind_args = mkListExpr (mkTyConTy someTypeRepTyCon) kind_arg_reps + + -- Note that we use the kind of the type, not the TyCon from which it + -- is constructed since the latter may be kind polymorphic whereas the + -- former we know is not (we checked in the solver). + ; return $ mkApps (Var mkTrCon) [ Type (typeKind ty) + , Type ty + , tc_rep + , kind_args ] + } 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 ] ) } + ; mkTrApp <- dsLookupGlobalId mkTrAppName + -- mkTrApp :: forall k1 k2 (a :: k1 -> k2) (b :: k1). + -- TypeRep a -> TypeRep b -> TypeRep (a b) + ; let (k1, k2) = splitFunTy (typeKind t1) + ; return $ mkApps (mkTyApps (Var mkTrApp) [ k1, k2, t1, t2 ]) + [ e1, e2 ] } + +ds_ev_typeable ty (EvTypeableTrFun ev1 ev2) + | Just (t1,t2) <- splitFunTy_maybe ty + = do { e1 <- getRep ev1 t1 + ; e2 <- getRep ev2 t2 + ; mkTrFun <- dsLookupGlobalId mkTrFunName + -- mkTrFun :: forall r1 r2 (a :: TYPE r1) (b :: TYPE r2). + -- TypeRep a -> TypeRep b -> TypeRep (a -> b) + ; let r1 = getRuntimeRep "ds_ev_typeable" t1 + r2 = getRuntimeRep "ds_ev_typeable" t2 + ; return $ mkApps (mkTyApps (Var mkTrFun) [r1, r2, t1, t2]) + [ e1, e2 ] + } ds_ev_typeable ty (EvTypeableTyLit ev) = do { fun <- dsLookupGlobalId tr_fun @@ -1248,28 +1269,26 @@ ds_ev_typeable ty (EvTypeableTyLit ev) ty_kind = typeKind ty -- tr_fun is the Name of - -- typeNatTypeRep :: KnownNat a => Proxy# a -> TypeRep - -- of typeSymbolTypeRep :: KnownSymbol a => Proxy# a -> TypeRep + -- typeNatTypeRep :: KnownNat a => Proxy# a -> TypeRep a + -- of typeSymbolTypeRep :: KnownSymbol a => Proxy# a -> TypeRep a 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) +getRep :: EvTerm -- ^ EvTerm for @Typeable ty@ + -> Type -- ^ The type @ty@ + -> DsM TypeRepExpr -- ^ Return @CoreExpr :: TypeRep ty@ + -- namely @typeRep# dict@ -- Remember that --- typeRep# :: forall k (a::k). Typeable k a -> Proxy k a -> TypeRep +-- typeRep# :: forall k (a::k). Typeable k a -> TypeRep a 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 ]) } + ; return (mkApps (mkTyApps (Var typeRepId) ty_args) [ typeable_expr ]) } tyConRep :: TyCon -> DsM CoreExpr -- Returns CoreExpr :: TyCon diff --git a/compiler/prelude/KnownUniques.hs b/compiler/prelude/KnownUniques.hs index 2dc6f8388d..8f1b0b6347 100644 --- a/compiler/prelude/KnownUniques.hs +++ b/compiler/prelude/KnownUniques.hs @@ -58,32 +58,57 @@ knownUniqueName u = -- Anonymous sums -- -- Sum arities start from 2. The encoding is a bit funny: we break up the --- integral part into bitfields for the arity and alternative index (which is --- taken to be 0xff in the case of the TyCon) +-- integral part into bitfields for the arity, an alternative index (which is +-- taken to be 0xff in the case of the TyCon), and, in the case of a datacon, a +-- tag (used to identify the sum's TypeRep binding). +-- +-- This layout is chosen to remain compatible with the usual unique allocation +-- for wired-in data constructors described in Unique.hs -- -- TyCon for sum of arity k: --- 00000000 kkkkkkkk 11111111 +-- 00000000 kkkkkkkk 11111100 + +-- TypeRep of TyCon for sum of arity k: +-- 00000000 kkkkkkkk 11111101 +-- -- DataCon for sum of arity k and alternative n (zero-based): --- 00000000 kkkkkkkk nnnnnnnn +-- 00000000 kkkkkkkk nnnnnn00 +-- +-- TypeRep for sum DataCon of arity k and alternative n (zero-based): +-- 00000000 kkkkkkkk nnnnnn10 mkSumTyConUnique :: Arity -> Unique mkSumTyConUnique arity = ASSERT(arity < 0xff) - mkUnique 'z' (arity `shiftL` 8 .|. 0xff) + mkUnique 'z' (arity `shiftL` 8 .|. 0xfc) mkSumDataConUnique :: ConTagZ -> Arity -> Unique mkSumDataConUnique alt arity | alt >= arity = panic ("mkSumDataConUnique: " ++ show alt ++ " >= " ++ show arity) | otherwise - = mkUnique 'z' (arity `shiftL` 8 + alt) {- skip the tycon -} + = mkUnique 'z' (arity `shiftL` 8 + alt `shiftL` 2) {- skip the tycon -} getUnboxedSumName :: Int -> Name -getUnboxedSumName n = - case n .&. 0xff of - 0xff -> tyConName $ sumTyCon arity - alt -> dataConName $ sumDataCon (alt + 1) arity - where arity = n `shiftR` 8 +getUnboxedSumName n + | n .&. 0xfc == 0xfc + = case tag of + 0x0 -> tyConName $ sumTyCon arity + 0x1 -> getRep $ sumTyCon arity + _ -> pprPanic "getUnboxedSumName: invalid tag" (ppr tag) + | tag == 0x0 + = dataConName $ sumDataCon (alt + 1) arity + | tag == 0x2 + = getRep $ promoteDataCon $ sumDataCon (alt + 1) arity + | otherwise + = pprPanic "getUnboxedSumName" (ppr n) + where + arity = n `shiftR` 8 + alt = (n .&. 0xff) `shiftR` 2 + tag = 0x3 .&. n + getRep tycon = + fromMaybe (pprPanic "getUnboxedSumName" (ppr tycon)) + $ tyConRepName_maybe tycon -- Note [Uniques for tuple type and data constructors] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/prelude/PrelNames.hs b/compiler/prelude/PrelNames.hs index 47b78f1d14..470b736286 100644 --- a/compiler/prelude/PrelNames.hs +++ b/compiler/prelude/PrelNames.hs @@ -224,9 +224,23 @@ basicKnownKeyNames -- Typeable typeableClassName, typeRepTyConName, + someTypeRepTyConName, + someTypeRepDataConName, + kindRepTyConName, + kindRepTyConAppDataConName, + kindRepVarDataConName, + kindRepAppDataConName, + kindRepFunDataConName, + kindRepTYPEDataConName, + kindRepTypeLitSDataConName, + kindRepTypeLitDDataConName, + typeLitSortTyConName, + typeLitSymbolDataConName, + typeLitNatDataConName, typeRepIdName, - mkPolyTyConAppName, - mkAppTyName, + mkTrConName, + mkTrAppName, + mkTrFunName, typeSymbolTypeRepName, typeNatTypeRepName, trGhcPrimModuleName, @@ -1200,11 +1214,40 @@ trNameDDataConName = dcQual gHC_TYPES (fsLit "TrNameD") trNam trTyConTyConName = tcQual gHC_TYPES (fsLit "TyCon") trTyConTyConKey trTyConDataConName = dcQual gHC_TYPES (fsLit "TyCon") trTyConDataConKey +kindRepTyConName + , kindRepTyConAppDataConName + , kindRepVarDataConName + , kindRepAppDataConName + , kindRepFunDataConName + , kindRepTYPEDataConName + , kindRepTypeLitSDataConName + , kindRepTypeLitDDataConName + :: Name +kindRepTyConName = tcQual gHC_TYPES (fsLit "KindRep") kindRepTyConKey +kindRepTyConAppDataConName = dcQual gHC_TYPES (fsLit "KindRepTyConApp") kindRepTyConAppDataConKey +kindRepVarDataConName = dcQual gHC_TYPES (fsLit "KindRepVar") kindRepVarDataConKey +kindRepAppDataConName = dcQual gHC_TYPES (fsLit "KindRepApp") kindRepAppDataConKey +kindRepFunDataConName = dcQual gHC_TYPES (fsLit "KindRepFun") kindRepFunDataConKey +kindRepTYPEDataConName = dcQual gHC_TYPES (fsLit "KindRepTYPE") kindRepTYPEDataConKey +kindRepTypeLitSDataConName = dcQual gHC_TYPES (fsLit "KindRepTypeLitS") kindRepTypeLitSDataConKey +kindRepTypeLitDDataConName = dcQual gHC_TYPES (fsLit "KindRepTypeLitD") kindRepTypeLitDDataConKey + +typeLitSortTyConName + , typeLitSymbolDataConName + , typeLitNatDataConName + :: Name +typeLitSortTyConName = tcQual gHC_TYPES (fsLit "TypeLitSort") typeLitSortTyConKey +typeLitSymbolDataConName = dcQual gHC_TYPES (fsLit "TypeLitSymbol") typeLitSymbolDataConKey +typeLitNatDataConName = dcQual gHC_TYPES (fsLit "TypeLitNat") typeLitNatDataConKey + -- Class Typeable, and functions for constructing `Typeable` dictionaries typeableClassName , typeRepTyConName - , mkPolyTyConAppName - , mkAppTyName + , someTypeRepTyConName + , someTypeRepDataConName + , mkTrConName + , mkTrAppName + , mkTrFunName , typeRepIdName , typeNatTypeRepName , typeSymbolTypeRepName @@ -1212,9 +1255,12 @@ typeableClassName :: Name typeableClassName = clsQual tYPEABLE_INTERNAL (fsLit "Typeable") typeableClassKey typeRepTyConName = tcQual tYPEABLE_INTERNAL (fsLit "TypeRep") typeRepTyConKey +someTypeRepTyConName = tcQual tYPEABLE_INTERNAL (fsLit "SomeTypeRep") someTypeRepTyConKey +someTypeRepDataConName = dcQual tYPEABLE_INTERNAL (fsLit "SomeTypeRep") someTypeRepDataConKey typeRepIdName = varQual tYPEABLE_INTERNAL (fsLit "typeRep#") typeRepIdKey -mkPolyTyConAppName = varQual tYPEABLE_INTERNAL (fsLit "mkPolyTyConApp") mkPolyTyConAppKey -mkAppTyName = varQual tYPEABLE_INTERNAL (fsLit "mkAppTy") mkAppTyKey +mkTrConName = varQual tYPEABLE_INTERNAL (fsLit "mkTrCon") mkTrConKey +mkTrAppName = varQual tYPEABLE_INTERNAL (fsLit "mkTrApp") mkTrAppKey +mkTrFunName = varQual tYPEABLE_INTERNAL (fsLit "mkTrFun") mkTrFunKey typeNatTypeRepName = varQual tYPEABLE_INTERNAL (fsLit "typeNatTypeRep") typeNatTypeRepKey typeSymbolTypeRepName = varQual tYPEABLE_INTERNAL (fsLit "typeSymbolTypeRep") typeSymbolTypeRepKey -- this is the Typeable 'Module' for GHC.Prim (which has no code, so we place in GHC.Types) @@ -1802,11 +1848,14 @@ callStackTyConKey :: Unique callStackTyConKey = mkPreludeTyConUnique 183 -- Typeables -typeRepTyConKey :: Unique -typeRepTyConKey = mkPreludeTyConUnique 184 +typeRepTyConKey, someTypeRepTyConKey, someTypeRepDataConKey :: Unique +typeRepTyConKey = mkPreludeTyConUnique 184 +someTypeRepTyConKey = mkPreludeTyConUnique 185 +someTypeRepDataConKey = mkPreludeTyConUnique 186 + typeSymbolAppendFamNameKey :: Unique -typeSymbolAppendFamNameKey = mkPreludeTyConUnique 185 +typeSymbolAppendFamNameKey = mkPreludeTyConUnique 187 ---------------- Template Haskell ------------------- -- THNames.hs: USES TyConUniques 200-299 @@ -1888,15 +1937,18 @@ srcLocDataConKey = mkPreludeDataConUnique 37 trTyConTyConKey, trTyConDataConKey, trModuleTyConKey, trModuleDataConKey, trNameTyConKey, trNameSDataConKey, trNameDDataConKey, - trGhcPrimModuleKey :: Unique -trTyConTyConKey = mkPreludeDataConUnique 41 -trTyConDataConKey = mkPreludeDataConUnique 42 -trModuleTyConKey = mkPreludeDataConUnique 43 -trModuleDataConKey = mkPreludeDataConUnique 44 -trNameTyConKey = mkPreludeDataConUnique 45 -trNameSDataConKey = mkPreludeDataConUnique 46 -trNameDDataConKey = mkPreludeDataConUnique 47 -trGhcPrimModuleKey = mkPreludeDataConUnique 48 + trGhcPrimModuleKey, kindRepTyConKey, + typeLitSortTyConKey :: Unique +trTyConTyConKey = mkPreludeDataConUnique 40 +trTyConDataConKey = mkPreludeDataConUnique 41 +trModuleTyConKey = mkPreludeDataConUnique 42 +trModuleDataConKey = mkPreludeDataConUnique 43 +trNameTyConKey = mkPreludeDataConUnique 44 +trNameSDataConKey = mkPreludeDataConUnique 45 +trNameDDataConKey = mkPreludeDataConUnique 46 +trGhcPrimModuleKey = mkPreludeDataConUnique 47 +kindRepTyConKey = mkPreludeDataConUnique 48 +typeLitSortTyConKey = mkPreludeDataConUnique 49 typeErrorTextDataConKey, typeErrorAppendDataConKey, @@ -1955,8 +2007,26 @@ vecCountDataConKeys = map mkPreludeDataConUnique [83..88] vecElemDataConKeys :: [Unique] vecElemDataConKeys = map mkPreludeDataConUnique [89..98] +-- Typeable things +kindRepTyConAppDataConKey, kindRepVarDataConKey, kindRepAppDataConKey, + kindRepFunDataConKey, kindRepTYPEDataConKey, + kindRepTypeLitSDataConKey, kindRepTypeLitDDataConKey + :: Unique +kindRepTyConAppDataConKey = mkPreludeDataConUnique 100 +kindRepVarDataConKey = mkPreludeDataConUnique 101 +kindRepAppDataConKey = mkPreludeDataConUnique 102 +kindRepFunDataConKey = mkPreludeDataConUnique 103 +kindRepTYPEDataConKey = mkPreludeDataConUnique 104 +kindRepTypeLitSDataConKey = mkPreludeDataConUnique 105 +kindRepTypeLitDDataConKey = mkPreludeDataConUnique 106 + +typeLitSymbolDataConKey, typeLitNatDataConKey :: Unique +typeLitSymbolDataConKey = mkPreludeDataConUnique 107 +typeLitNatDataConKey = mkPreludeDataConUnique 108 + + ---------------- Template Haskell ------------------- --- THNames.hs: USES DataUniques 100-150 +-- THNames.hs: USES DataUniques 200-250 ----------------------------------------------------- @@ -2229,41 +2299,54 @@ proxyHashKey = mkPreludeMiscIdUnique 502 -- Used to make `Typeable` dictionaries mkTyConKey - , mkPolyTyConAppKey - , mkAppTyKey + , mkTrConKey + , mkTrAppKey + , mkTrFunKey , typeNatTypeRepKey , typeSymbolTypeRepKey , typeRepIdKey :: Unique mkTyConKey = mkPreludeMiscIdUnique 503 -mkPolyTyConAppKey = mkPreludeMiscIdUnique 504 -mkAppTyKey = mkPreludeMiscIdUnique 505 +mkTrConKey = mkPreludeMiscIdUnique 504 +mkTrAppKey = mkPreludeMiscIdUnique 505 typeNatTypeRepKey = mkPreludeMiscIdUnique 506 typeSymbolTypeRepKey = mkPreludeMiscIdUnique 507 typeRepIdKey = mkPreludeMiscIdUnique 508 +mkTrFunKey = mkPreludeMiscIdUnique 509 + +-- Representations for primitive types +trTYPEKey + ,trTYPE'PtrRepLiftedKey + , trRuntimeRepKey + , tr'PtrRepLiftedKey + :: Unique +trTYPEKey = mkPreludeMiscIdUnique 510 +trTYPE'PtrRepLiftedKey = mkPreludeMiscIdUnique 511 +trRuntimeRepKey = mkPreludeMiscIdUnique 512 +tr'PtrRepLiftedKey = mkPreludeMiscIdUnique 513 -- Dynamic toDynIdKey :: Unique -toDynIdKey = mkPreludeMiscIdUnique 509 +toDynIdKey = mkPreludeMiscIdUnique 550 bitIntegerIdKey :: Unique -bitIntegerIdKey = mkPreludeMiscIdUnique 510 +bitIntegerIdKey = mkPreludeMiscIdUnique 551 heqSCSelIdKey, coercibleSCSelIdKey :: Unique -heqSCSelIdKey = mkPreludeMiscIdUnique 511 -coercibleSCSelIdKey = mkPreludeMiscIdUnique 512 +heqSCSelIdKey = mkPreludeMiscIdUnique 552 +coercibleSCSelIdKey = mkPreludeMiscIdUnique 553 sappendClassOpKey :: Unique -sappendClassOpKey = mkPreludeMiscIdUnique 513 +sappendClassOpKey = mkPreludeMiscIdUnique 554 memptyClassOpKey, mappendClassOpKey, mconcatClassOpKey :: Unique -memptyClassOpKey = mkPreludeMiscIdUnique 514 -mappendClassOpKey = mkPreludeMiscIdUnique 515 -mconcatClassOpKey = mkPreludeMiscIdUnique 516 +memptyClassOpKey = mkPreludeMiscIdUnique 555 +mappendClassOpKey = mkPreludeMiscIdUnique 556 +mconcatClassOpKey = mkPreludeMiscIdUnique 557 emptyCallStackKey, pushCallStackKey :: Unique -emptyCallStackKey = mkPreludeMiscIdUnique 517 -pushCallStackKey = mkPreludeMiscIdUnique 518 +emptyCallStackKey = mkPreludeMiscIdUnique 558 +pushCallStackKey = mkPreludeMiscIdUnique 559 fromStaticPtrClassOpKey :: Unique fromStaticPtrClassOpKey = mkPreludeMiscIdUnique 519 diff --git a/compiler/prelude/THNames.hs b/compiler/prelude/THNames.hs index 253a89b6e3..1b9e624c67 100644 --- a/compiler/prelude/THNames.hs +++ b/compiler/prelude/THNames.hs @@ -678,40 +678,40 @@ derivStrategyTyConKey = mkPreludeTyConUnique 235 -- data Inline = ... noInlineDataConKey, inlineDataConKey, inlinableDataConKey :: Unique -noInlineDataConKey = mkPreludeDataConUnique 100 -inlineDataConKey = mkPreludeDataConUnique 101 -inlinableDataConKey = mkPreludeDataConUnique 102 +noInlineDataConKey = mkPreludeDataConUnique 200 +inlineDataConKey = mkPreludeDataConUnique 201 +inlinableDataConKey = mkPreludeDataConUnique 202 -- data RuleMatch = ... conLikeDataConKey, funLikeDataConKey :: Unique -conLikeDataConKey = mkPreludeDataConUnique 103 -funLikeDataConKey = mkPreludeDataConUnique 104 +conLikeDataConKey = mkPreludeDataConUnique 203 +funLikeDataConKey = mkPreludeDataConUnique 204 -- data Phases = ... allPhasesDataConKey, fromPhaseDataConKey, beforePhaseDataConKey :: Unique -allPhasesDataConKey = mkPreludeDataConUnique 105 -fromPhaseDataConKey = mkPreludeDataConUnique 106 -beforePhaseDataConKey = mkPreludeDataConUnique 107 +allPhasesDataConKey = mkPreludeDataConUnique 205 +fromPhaseDataConKey = mkPreludeDataConUnique 206 +beforePhaseDataConKey = mkPreludeDataConUnique 207 -- newtype TExp a = ... tExpDataConKey :: Unique -tExpDataConKey = mkPreludeDataConUnique 108 +tExpDataConKey = mkPreludeDataConUnique 208 -- data Overlap = .. overlappableDataConKey, overlappingDataConKey, overlapsDataConKey, incoherentDataConKey :: Unique -overlappableDataConKey = mkPreludeDataConUnique 109 -overlappingDataConKey = mkPreludeDataConUnique 110 -overlapsDataConKey = mkPreludeDataConUnique 111 -incoherentDataConKey = mkPreludeDataConUnique 112 +overlappableDataConKey = mkPreludeDataConUnique 209 +overlappingDataConKey = mkPreludeDataConUnique 210 +overlapsDataConKey = mkPreludeDataConUnique 211 +incoherentDataConKey = mkPreludeDataConUnique 212 -- data DerivStrategy = ... stockDataConKey, anyclassDataConKey, newtypeDataConKey :: Unique -stockDataConKey = mkPreludeDataConUnique 113 -anyclassDataConKey = mkPreludeDataConUnique 114 -newtypeDataConKey = mkPreludeDataConUnique 115 +stockDataConKey = mkPreludeDataConUnique 213 +anyclassDataConKey = mkPreludeDataConUnique 214 +newtypeDataConKey = mkPreludeDataConUnique 215 {- ********************************************************************* * * diff --git a/compiler/prelude/TysWiredIn.hs b/compiler/prelude/TysWiredIn.hs index 0eeb5e323a..85771a0da2 100644 --- a/compiler/prelude/TysWiredIn.hs +++ b/compiler/prelude/TysWiredIn.hs @@ -865,7 +865,7 @@ mk_tuple Unboxed arity = (tycon, tuple_con) tc_res_kind = unboxedTupleKind rr_tys tc_arity = arity * 2 - flavour = UnboxedAlgTyCon + flavour = UnboxedAlgTyCon (mkPrelTyConRepName tc_name) dc_tvs = binderVars tc_binders (rr_tys, dc_arg_tys) = splitAt arity (mkTyVarTys dc_tvs) @@ -974,7 +974,7 @@ mk_sum :: Arity -> (TyCon, Array ConTagZ DataCon) mk_sum arity = (tycon, sum_cons) where tycon = mkSumTyCon tc_name tc_binders tc_res_kind (arity * 2) tyvars (elems sum_cons) - UnboxedAlgTyCon + (UnboxedAlgTyCon (mkPrelTyConRepName tc_name)) tc_binders = mkTemplateTyConBinders (nOfThem arity runtimeRepTy) (\ks -> map tYPE ks) diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs index 65acf808ab..3e462744e1 100644 --- a/compiler/rename/RnSource.hs +++ b/compiler/rename/RnSource.hs @@ -60,25 +60,22 @@ import Data.List ( sortBy, mapAccumL ) import Data.Maybe ( isJust ) import qualified Data.Set as Set ( difference, fromList, toList, null ) -{- -@rnSourceDecl@ `renames' declarations. +{- | @rnSourceDecl@ "renames" declarations. It simultaneously performs dependency analysis and precedence parsing. It also does the following error checks: -\begin{enumerate} -\item -Checks that tyvars are used properly. This includes checking -for undefined tyvars, and tyvars in contexts that are ambiguous. -(Some of this checking has now been moved to module @TcMonoType@, -since we don't have functional dependency information at this point.) -\item -Checks that all variable occurrences are defined. -\item -Checks the @(..)@ etc constraints in the export list. -\end{enumerate} --} --- Brings the binders of the group into scope in the appropriate places; --- does NOT assume that anything is in scope already +* Checks that tyvars are used properly. This includes checking + for undefined tyvars, and tyvars in contexts that are ambiguous. + (Some of this checking has now been moved to module @TcMonoType@, + since we don't have functional dependency information at this point.) + +* Checks that all variable occurrences are defined. + +* Checks the @(..)@ etc constraints in the export list. + +Brings the binders of the group into scope in the appropriate places; +does NOT assume that anything is in scope already +-} rnSrcDecls :: HsGroup RdrName -> RnM (TcGblEnv, HsGroup Name) -- Rename a top-level HsGroup; used for normal source files *and* hs-boot files rnSrcDecls group@(HsGroup { hs_valds = val_decls, diff --git a/compiler/typecheck/TcBackpack.hs b/compiler/typecheck/TcBackpack.hs index a2e5abef9e..2b4b05cd9b 100644 --- a/compiler/typecheck/TcBackpack.hs +++ b/compiler/typecheck/TcBackpack.hs @@ -438,8 +438,8 @@ inheritedSigPvpWarning = -- the export lists of two signatures is just merging the declarations -- of two signatures writ small. Of course, in GHC Haskell, there are a -- few important things which are not explicitly exported but still can --- be used: in particular, dictionary functions for instances and --- coercion axioms for type families also count. +-- be used: in particular, dictionary functions for instances, Typeable +-- TyCon bindings, and coercion axioms for type families also count. -- -- When handling these non-exported things, there two primary things -- we need to watch out for: diff --git a/compiler/typecheck/TcEvidence.hs b/compiler/typecheck/TcEvidence.hs index 2de2223ed6..4455c9bd6a 100644 --- a/compiler/typecheck/TcEvidence.hs +++ b/compiler/typecheck/TcEvidence.hs @@ -493,19 +493,24 @@ data EvTerm -- | Instructions on how to make a 'Typeable' dictionary. -- See Note [Typeable evidence terms] data EvTypeable - = EvTypeableTyCon [EvTerm] -- ^ Dictionary for @Typeable (T k1..kn)@. - -- The EvTerms are for the arguments + = EvTypeableTyCon TyCon [EvTerm] + -- ^ Dictionary for @Typeable T@ where @T@ is a type constructor with all of + -- its kind variables saturated. The @[EvTerm]@ is @Typeable@ evidence for + -- the applied kinds.. | EvTypeableTyApp EvTerm EvTerm -- ^ Dictionary for @Typeable (s t)@, - -- given a dictionaries for @s@ and @t@ + -- given a dictionaries for @s@ and @t@. + + | EvTypeableTrFun EvTerm EvTerm + -- ^ Dictionary for @Typeable (s -> t)@, + -- given a dictionaries for @s@ and @t@. | EvTypeableTyLit EvTerm -- ^ Dictionary for a type literal, -- e.g. @Typeable "foo"@ or @Typeable 3@ -- The 'EvTerm' is evidence of, e.g., @KnownNat 3@ -- (see Trac #10348) - deriving Data.Data data EvLit @@ -817,8 +822,9 @@ evVarsOfCallStack cs = case cs of evVarsOfTypeable :: EvTypeable -> VarSet evVarsOfTypeable ev = case ev of - EvTypeableTyCon es -> evVarsOfTerms es + EvTypeableTyCon _ e -> mapUnionVarSet evVarsOfTerm e EvTypeableTyApp e1 e2 -> evVarsOfTerms [e1,e2] + EvTypeableTrFun e1 e2 -> evVarsOfTerms [e1,e2] EvTypeableTyLit e -> evVarsOfTerm e {- @@ -908,8 +914,9 @@ instance Outputable EvCallStack where = ppr (name,loc) <+> text ":" <+> ppr tm instance Outputable EvTypeable where - ppr (EvTypeableTyCon ts) = text "TC" <+> ppr ts + ppr (EvTypeableTyCon ts _) = text "TyCon" <+> ppr ts ppr (EvTypeableTyApp t1 t2) = parens (ppr t1 <+> ppr t2) + ppr (EvTypeableTrFun t1 t2) = parens (ppr t1 <+> arrow <+> ppr t2) ppr (EvTypeableTyLit t1) = text "TyLit" <> ppr t1 diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs index 6061eccf60..6ad2b281f9 100644 --- a/compiler/typecheck/TcHsSyn.hs +++ b/compiler/typecheck/TcHsSyn.hs @@ -615,7 +615,7 @@ zonkLExprs env exprs = mapM (zonkLExpr env) exprs zonkLExpr env expr = wrapLocM (zonkExpr env) expr zonkExpr env (HsVar (L l id)) - = ASSERT( isNothing (isDataConId_maybe id) ) + = ASSERT2( isNothing (isDataConId_maybe id), ppr id ) return (HsVar (L l (zonkIdOcc env id))) zonkExpr _ e@(HsConLikeOut {}) = return e @@ -1451,13 +1451,17 @@ zonkEvTerm env (EvSelector sel_id tys tms) ; return (EvSelector sel_id' tys' tms') } zonkEvTypeable :: ZonkEnv -> EvTypeable -> TcM EvTypeable -zonkEvTypeable env (EvTypeableTyCon ts) - = do { ts' <- mapM (zonkEvTerm env) ts - ; return $ EvTypeableTyCon ts' } +zonkEvTypeable env (EvTypeableTyCon tycon e) + = do { e' <- mapM (zonkEvTerm env) e + ; return $ EvTypeableTyCon tycon e' } zonkEvTypeable env (EvTypeableTyApp t1 t2) = do { t1' <- zonkEvTerm env t1 ; t2' <- zonkEvTerm env t2 ; return (EvTypeableTyApp t1' t2') } +zonkEvTypeable env (EvTypeableTrFun t1 t2) + = do { t1' <- zonkEvTerm env t1 + ; t2' <- zonkEvTerm env t2 + ; return (EvTypeableTrFun t1' t2') } zonkEvTypeable env (EvTypeableTyLit t1) = do { t1' <- zonkEvTerm env t1 ; return (EvTypeableTyLit t1') } diff --git a/compiler/typecheck/TcInteract.hs b/compiler/typecheck/TcInteract.hs index e01bd64f36..e1ad484d58 100644 --- a/compiler/typecheck/TcInteract.hs +++ b/compiler/typecheck/TcInteract.hs @@ -2403,28 +2403,41 @@ matchTypeable clas [k,t] -- clas = Typeable | 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 + | k `eqType` typeNatKind = doTyLit knownNatClassName t + | k `eqType` typeSymbolKind = doTyLit knownSymbolClassName t + | Just (arg,ret) <- splitFunTy_maybe t = doFunTy clas t arg ret | Just (tc, ks) <- splitTyConApp_maybe t -- See Note [Typeable (T a b c)] - , onlyNamedBndrsApplied tc ks = doTyConApp clas t ks + , onlyNamedBndrsApplied tc ks = doTyConApp clas t tc ks | Just (f,kt) <- splitAppTy_maybe t = doTyApp clas t f kt matchTypeable _ _ = return NoInstance -doTyConApp :: Class -> Type -> [Kind] -> TcS LookupInstResult --- Representation for type constructor applied to some kinds -doTyConApp clas ty args - = return $ GenInst (map (mk_typeable_pred clas) args) - (\tms -> EvTypeable ty $ EvTypeableTyCon tms) +-- | Representation for a type @ty@ of the form @arg -> ret@. +doFunTy :: Class -> Type -> Type -> Type -> TcS LookupInstResult +doFunTy clas ty arg_ty ret_ty + = do { let preds = map (mk_typeable_pred clas) [arg_ty, ret_ty] + build_ev [arg_ev, ret_ev] = + EvTypeable ty $ EvTypeableTrFun arg_ev ret_ev + build_ev _ = panic "TcInteract.doFunTy" + ; return $ GenInst preds build_ev True + } + +-- | Representation for type constructor applied to some kinds. +-- 'onlyNamedBndrsApplied' has ensured that this application results in a type +-- of monomorphic kind (e.g. all kind variables have been instantiated). +doTyConApp :: Class -> Type -> TyCon -> [Kind] -> TcS LookupInstResult +doTyConApp clas ty tc kind_args + = return $ GenInst (map (mk_typeable_pred clas) kind_args) + (\kinds -> EvTypeable ty $ EvTypeableTyCon tc kinds) True --- Representation for concrete kinds. We just use the kind itself, --- but first we must make sure that we've instantiated all kind- +-- | Representation for TyCon applications of a concrete kind. We just use the +-- kind itself, but first we must make sure that we've instantiated all kind- -- polymorphism, but no more. onlyNamedBndrsApplied :: TyCon -> [KindOrType] -> Bool onlyNamedBndrsApplied tc ks - = all isNamedTyConBinder used_bndrs && - all (not . isNamedTyConBinder) leftover_bndrs + = all isNamedTyConBinder used_bndrs && + not (any isNamedTyConBinder leftover_bndrs) where bndrs = tyConBinders tc (used_bndrs, leftover_bndrs) = splitAtList ks bndrs @@ -2441,10 +2454,9 @@ doTyApp clas ty f tk | isForAllTy (typeKind f) = return NoInstance -- We can't solve until we know the ctr. | otherwise - = do { traceTcS "doTyApp" (ppr clas $$ ppr ty $$ ppr f $$ ppr tk) - ; return $ GenInst [mk_typeable_pred clas f, mk_typeable_pred clas tk] + = return $ GenInst (map (mk_typeable_pred clas) [f, tk]) (\[t1,t2] -> EvTypeable ty $ EvTypeableTyApp t1 t2) - True } + True -- Emit a `Typeable` constraint for the given type. mk_typeable_pred :: Class -> Type -> PredType @@ -2472,7 +2484,9 @@ To solve Typeable (Proxy (* -> *) Maybe) we - Then solve (Typeable (Proxy (* -> *))) with doTyConApp If we attempt to short-cut by solving it all at once, via -doTyCOnAPp +doTyConApp + +(this note is sadly truncated FIXME) Note [No Typeable for polytypes or qualified types] diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs index 05ed92a0d1..082b2fd693 100644 --- a/compiler/typecheck/TcRnDriver.hs +++ b/compiler/typecheck/TcRnDriver.hs @@ -588,6 +588,10 @@ tcRnHsBootDecls hsc_src decls <- tcTyClsInstDecls tycl_decls deriv_decls val_binds ; setGblEnv tcg_env $ do { + -- Emit Typeable bindings + ; tcg_env <- mkTypeableBinds + ; setGblEnv tcg_env $ do { + -- Typecheck value declarations ; traceTc "Tc5" empty ; val_ids <- tcHsBootSigs val_binds val_sigs @@ -607,7 +611,7 @@ tcRnHsBootDecls hsc_src decls } ; setGlobalTypeEnv gbl_env type_env2 - }} + }}} ; traceTc "boot" (ppr lie); return gbl_env } badBootDecl :: HscSource -> String -> Located decl -> TcM () diff --git a/compiler/typecheck/TcTypeable.hs b/compiler/typecheck/TcTypeable.hs index 86d1d1cb45..e7fe588f76 100644 --- a/compiler/typecheck/TcTypeable.hs +++ b/compiler/typecheck/TcTypeable.hs @@ -8,27 +8,39 @@ module TcTypeable(mkTypeableBinds) where -import BasicTypes ( SourceText(..) ) +import BasicTypes ( SourceText(..), Boxity(..), neverInlinePragma ) import TcBinds( addTypecheckedBinds ) import IfaceEnv( newGlobalBinder ) +import TyCoRep( Type(..), TyLit(..) ) import TcEnv +import TcEvidence ( mkWpTyApps ) import TcRnMonad +import TcMType ( zonkTcType ) +import HscTypes ( lookupId ) import PrelNames import TysPrim ( primTyCons ) +import TysWiredIn ( tupleTyCon, sumTyCon, runtimeRepTyCon + , vecCountTyCon, vecElemTyCon + , nilDataCon, consDataCon ) import Id import Type +import Kind ( isTYPEApp ) import TyCon import DataCon -import Name( getOccName ) +import Name ( getOccName ) import OccName import Module import HsSyn import DynFlags import Bag -import Fingerprint(Fingerprint(..), fingerprintString) +import Var ( TyVarBndr(..) ) +import VarEnv +import Constants +import Fingerprint(Fingerprint(..), fingerprintString, fingerprintFingerprints) import Outputable -import FastString ( FastString, mkFastString ) +import FastString ( FastString, mkFastString, fsLit ) +import Data.Maybe ( isJust ) import Data.Word( Word64 ) {- Note [Grand plan for Typeable] @@ -51,9 +63,22 @@ The overall plan is this: M.$tcT = TyCon ...fingerprint info... $trModule "T" + 0# + kind_rep + + Here 0# is the number of arguments expected by the tycon to fully determine + its kind. kind_rep is a value of type GHC.Types.KindRep, which gives a + recipe for computing the kind of an instantiation of the tycon (see + Note [Representing TyCon kinds] later in this file for details). + We define (in TyCon) - type TyConRepName = Name - to use for these M.$tcT "tycon rep names". + + type TyConRepName = Name + + to use for these M.$tcT "tycon rep names". Note that these must be + treated as "never exported" names by Backpack (see + Note [Handling never-exported TyThings under Backpack]). Consequently + they get slightly special treatment in RnModIface.rnIfaceDecl. 3. Record the TyConRepName in T's TyCon, including for promoted data and type constructors, and kinds like * and #. @@ -86,6 +111,25 @@ There are many wrinkles: representations for TyCon and Module. See GHC.Types Note [Runtime representation of modules and tycons] +* The KindReps can unfortunately get quite large. Moreover, the simplifier will + float out various pieces of them, resulting in numerous top-level bindings. + Consequently we mark the KindRep bindings as noinline, ensuring that the + float-outs don't make it into the interface file. This is important since + there is generally little benefit to inlining KindReps and they would + otherwise strongly affect compiler performance. + +* Even KindReps aren't inlined this scheme still has more of an effect on + compilation time than I'd like. This is especially true in the case of + families of type constructors (e.g. tuples and unboxed sums). The problem is + particularly bad in the case of sums, since each arity-N tycon brings with it + N promoted datacons, each with a KindRep whose size also scales with N. + Consequently we currently simply don't allow sums to be Typeable. + + In general we might consider moving some or all of this generation logic back + to the solver since the performance hit we take in doing this at + type-definition time is non-trivial and Typeable isn't very widely used. This + is discussed in #13261. + -} -- | Generate the Typeable bindings for a module. This is the only @@ -101,16 +145,24 @@ mkTypeableBinds ; tcg_env <- mkModIdBindings -- Now we can generate the TyCon representations... -- First we handle the primitive TyCons if we are compiling GHC.Types - ; tcg_env <- setGblEnv tcg_env mkPrimTypeableBinds + ; (tcg_env, prim_todos) <- setGblEnv tcg_env mkPrimTypeableTodos + -- Then we produce bindings for the user-defined types in this module. ; setGblEnv tcg_env $ - - do { let tycons = filter needs_typeable_binds (tcg_tcs tcg_env) + do { mod <- getModule + ; let tycons = filter needs_typeable_binds (tcg_tcs tcg_env) + mod_id = case tcg_tr_module tcg_env of -- Should be set by now + Just mod_id -> mod_id + Nothing -> pprPanic "tcMkTypeableBinds" (ppr tycons) ; traceTc "mkTypeableBinds" (ppr tycons) - ; mkTypeableTyConBinds tycons + ; this_mod_todos <- todoForTyCons mod mod_id tycons + ; mkTypeableTyConBinds (this_mod_todos : prim_todos) } } where - needs_typeable_binds tc = + needs_typeable_binds tc + | tc `elem` [runtimeRepTyCon, vecCountTyCon, vecElemTyCon] + = False + | otherwise = (not (isFamInstTyCon tc) && isAlgTyCon tc) || isDataFamilyTyCon tc || isClassTyCon tc @@ -140,8 +192,8 @@ mkModIdRHS mod = do { trModuleDataCon <- tcLookupDataCon trModuleDataConName ; trNameLit <- mkTrNameLit ; return $ nlHsDataCon trModuleDataCon - `nlHsApp` (nlHsPar $ trNameLit (unitIdFS (moduleUnitId mod))) - `nlHsApp` (nlHsPar $ trNameLit (moduleNameFS (moduleName mod))) + `nlHsApp` trNameLit (unitIdFS (moduleUnitId mod)) + `nlHsApp` trNameLit (moduleNameFS (moduleName mod)) } {- ********************************************************************* @@ -150,30 +202,93 @@ mkModIdRHS mod * * ********************************************************************* -} +-- | Information we need about a 'TyCon' to generate its representation. +data TypeableTyCon + = TypeableTyCon + { tycon :: !TyCon + , tycon_kind :: !Kind + , tycon_rep_id :: !Id + } + +-- | A group of 'TyCon's in need of type-rep bindings. +data TypeRepTodo + = TypeRepTodo + { mod_rep_expr :: LHsExpr Id -- ^ Module's typerep binding + , pkg_fingerprint :: !Fingerprint -- ^ Package name fingerprint + , mod_fingerprint :: !Fingerprint -- ^ Module name fingerprint + , todo_tycons :: [TypeableTyCon] + -- ^ The 'TyCon's in need of bindings and their zonked kinds + } + +todoForTyCons :: Module -> Id -> [TyCon] -> TcM TypeRepTodo +todoForTyCons mod mod_id tycons = do + trTyConTyCon <- tcLookupTyCon trTyConTyConName + let mkRepId :: TyConRepName -> Id + mkRepId rep_name = mkExportedVanillaId rep_name (mkTyConTy trTyConTyCon) + + tycons <- sequence + [ do kind <- zonkTcType $ tyConKind tc'' + return TypeableTyCon { tycon = tc'' + , tycon_kind = kind + , tycon_rep_id = mkRepId rep_name + } + | tc <- tycons + , tc' <- tc : tyConATs tc + -- If the tycon itself isn't typeable then we needn't look + -- at its promoted datacons as their kinds aren't Typeable + , Just _ <- pure $ tyConRepName_maybe tc' + -- We need type representations for any associated types + , let promoted = map promoteDataCon (tyConDataCons tc') + , tc'' <- tc' : promoted + , Just rep_name <- pure $ tyConRepName_maybe tc'' + ] + let typeable_tycons = filter is_typeable tycons + is_typeable (TypeableTyCon {..}) = + --pprTrace "todoForTycons" (ppr tycon $$ ppr bare_kind $$ ppr is_typeable) + (typeIsTypeable bare_kind) + where bare_kind = dropForAlls tycon_kind + return TypeRepTodo { mod_rep_expr = nlHsVar mod_id + , pkg_fingerprint = pkg_fpr + , mod_fingerprint = mod_fpr + , todo_tycons = typeable_tycons + } + where + mod_fpr = fingerprintString $ moduleNameString $ moduleName mod + pkg_fpr = fingerprintString $ unitIdString $ moduleUnitId mod + -- | Generate TyCon bindings for a set of type constructors -mkTypeableTyConBinds :: [TyCon] -> TcM TcGblEnv -mkTypeableTyConBinds tycons - = do { gbl_env <- getGblEnv - ; mod <- getModule - ; let 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 <- collect_stuff mod mod_expr - ; let all_tycons = [ tc' | tc <- tycons, tc' <- tc : tyConATs tc ] - -- We need type representations for any associated types - tc_binds = map (mk_typeable_binds stuff) all_tycons - tycon_rep_ids = foldr ((++) . collectHsBindsBinders) [] tc_binds - - ; gbl_env <- tcExtendGlobalValEnv tycon_rep_ids getGblEnv - ; return (gbl_env `addTypecheckedBinds` tc_binds) } - --- | Generate bindings for the type representation of a wired-in TyCon defined --- by the virtual "GHC.Prim" module. This is where we inject the representation --- bindings for primitive types into "GHC.Types" +mkTypeableTyConBinds :: [TypeRepTodo] -> TcM TcGblEnv +mkTypeableTyConBinds [] = getGblEnv +mkTypeableTyConBinds todos + = do { stuff <- collect_stuff + + -- First extend the type environment with all of the bindings which we + -- are going to produce since we may need to refer to them while + -- generating the kind representations of other types. + ; let tycon_rep_bndrs :: [Id] + tycon_rep_bndrs = [ tycon_rep_id + | todo <- todos + , TypeableTyCon {..} <- todo_tycons todo + ] + ; gbl_env <- tcExtendGlobalValEnv tycon_rep_bndrs getGblEnv + + ; setGblEnv gbl_env $ foldlM (mk_typeable_binds stuff) gbl_env todos } + +-- | Make bindings for the type representations of a 'TyCon' and its +-- promoted constructors. +mk_typeable_binds :: TypeableStuff -> TcGblEnv -> TypeRepTodo -> TcM TcGblEnv +mk_typeable_binds stuff gbl_env todo + = do pairs <- mapM (mkTyConRepBinds stuff todo) (todo_tycons todo) + gbl_env <- tcExtendGlobalValEnv (map fst pairs) (return gbl_env) + return $ gbl_env `addTypecheckedBinds` map snd pairs + +-- | Generate bindings for the type representation of a wired-in 'TyCon's +-- defined by the virtual "GHC.Prim" module. This is where we inject the +-- representation bindings for these primitive types into "GHC.Types" -- -- See Note [Grand plan for Typeable] in this module. -mkPrimTypeableBinds :: TcM TcGblEnv -mkPrimTypeableBinds +mkPrimTypeableTodos :: TcM (TcGblEnv, [TypeRepTodo]) +mkPrimTypeableTodos = do { mod <- getModule ; if mod == gHC_TYPES then do { trModuleTyCon <- tcLookupTyCon trModuleTyConName @@ -184,58 +299,66 @@ mkPrimTypeableBinds ; ghc_prim_module_bind <- mkVarBind ghc_prim_module_id <$> mkModIdRHS gHC_PRIM - ; stuff <- collect_stuff gHC_PRIM (nlHsVar ghc_prim_module_id) - ; let prim_binds :: LHsBinds Id - prim_binds = unitBag ghc_prim_module_bind - `unionBags` ghcPrimTypeableBinds stuff - - prim_rep_ids = collectHsBindsBinders prim_binds - ; gbl_env <- tcExtendGlobalValEnv prim_rep_ids getGblEnv - ; return (gbl_env `addTypecheckedBinds` [prim_binds]) + ; gbl_env <- tcExtendGlobalValEnv [ghc_prim_module_id] getGblEnv + ; let gbl_env' = gbl_env `addTypecheckedBinds` + [unitBag ghc_prim_module_bind] + ; todo <- todoForTyCons gHC_PRIM ghc_prim_module_id + ghcPrimTypeableTyCons + ; return (gbl_env', [todo]) } - else getGblEnv + else do gbl_env <- getGblEnv + return (gbl_env, []) } where --- | Generate bindings for the type representation of the wired-in TyCons defined --- by the virtual "GHC.Prim" module. This differs from the usual --- @mkTypeableBinds@ path in that here we need to lie to 'mk_typeable_binds' --- about the module we are compiling (since we are currently compiling --- "GHC.Types" yet are producing representations for types in "GHC.Prim"). +-- | This is the list of primitive 'TyCon's for which we must generate bindings +-- in "GHC.Types". This should include all types defined in "GHC.Prim". -- --- See Note [Grand plan for Typeable] in this module. -ghcPrimTypeableBinds :: TypeableStuff -> LHsBinds Id -ghcPrimTypeableBinds stuff - = unionManyBags (map mkBind all_prim_tys) - where - all_prim_tys :: [TyCon] - all_prim_tys = [ tc' | tc <- funTyCon : primTyCons - , tc' <- tc : tyConATs tc ] - - mkBind :: TyCon -> LHsBinds Id - mkBind = mk_typeable_binds stuff +-- The majority of the types we need here are contained in 'primTyCons'. +-- However, not all of them: in particular unboxed tuples are absent since we +-- don't want to include them in the original name cache. See +-- Note [Built-in syntax and the OrigNameCache] in IfaceEnv for more. +ghcPrimTypeableTyCons :: [TyCon] +ghcPrimTypeableTyCons = concat + [ [ runtimeRepTyCon, vecCountTyCon, vecElemTyCon + , funTyCon, tupleTyCon Unboxed 0] + , map (tupleTyCon Unboxed) [2..mAX_TUPLE_SIZE] + , map sumTyCon [2..mAX_SUM_SIZE] + , primTyCons + ] data TypeableStuff = Stuff { dflags :: DynFlags - , mod_rep :: LHsExpr Id -- ^ Of type GHC.Types.Module - , pkg_str :: String -- ^ Package name - , mod_str :: String -- ^ Module name - , trTyConTyCon :: TyCon -- ^ of @TyCon@ - , trTyConDataCon :: DataCon -- ^ of @TyCon@ + , trTyConDataCon :: DataCon -- ^ of @TyCon@ , trNameLit :: FastString -> LHsExpr Id - -- ^ To construct @TrName@s + -- ^ To construct @TrName@s + -- The various TyCon and DataCons of KindRep + , kindRepTyCon :: TyCon + , kindRepTyConAppDataCon :: DataCon + , kindRepVarDataCon :: DataCon + , kindRepAppDataCon :: DataCon + , kindRepFunDataCon :: DataCon + , kindRepTYPEDataCon :: DataCon + , kindRepTypeLitSDataCon :: DataCon + , typeLitSymbolDataCon :: DataCon + , typeLitNatDataCon :: DataCon } -- | Collect various tidbits which we'll need to generate TyCon representations. -collect_stuff :: Module -> LHsExpr Id -> TcM TypeableStuff -collect_stuff mod mod_rep = do +collect_stuff :: TcM TypeableStuff +collect_stuff = do dflags <- getDynFlags - let pkg_str = unitIdString (moduleUnitId mod) - mod_str = moduleNameString (moduleName mod) - - trTyConTyCon <- tcLookupTyCon trTyConTyConName - trTyConDataCon <- tcLookupDataCon trTyConDataConName - trNameLit <- mkTrNameLit + trTyConDataCon <- tcLookupDataCon trTyConDataConName + kindRepTyCon <- tcLookupTyCon kindRepTyConName + kindRepTyConAppDataCon <- tcLookupDataCon kindRepTyConAppDataConName + kindRepVarDataCon <- tcLookupDataCon kindRepVarDataConName + kindRepAppDataCon <- tcLookupDataCon kindRepAppDataConName + kindRepFunDataCon <- tcLookupDataCon kindRepFunDataConName + kindRepTYPEDataCon <- tcLookupDataCon kindRepTYPEDataConName + kindRepTypeLitSDataCon <- tcLookupDataCon kindRepTypeLitSDataConName + typeLitSymbolDataCon <- tcLookupDataCon typeLitSymbolDataConName + typeLitNatDataCon <- tcLookupDataCon typeLitNatDataConName + trNameLit <- mkTrNameLit return Stuff {..} -- | Lookup the necessary pieces to construct the @trNameLit@. We do this so we @@ -245,49 +368,207 @@ mkTrNameLit :: TcM (FastString -> LHsExpr Id) mkTrNameLit = do trNameSDataCon <- tcLookupDataCon trNameSDataConName let trNameLit :: FastString -> LHsExpr Id - trNameLit fs = nlHsDataCon trNameSDataCon + trNameLit fs = nlHsPar $ nlHsDataCon trNameSDataCon `nlHsApp` nlHsLit (mkHsStringPrimLit fs) return trNameLit --- | Make bindings for the type representations of a 'TyCon' and its --- promoted constructors. -mk_typeable_binds :: TypeableStuff -> TyCon -> LHsBinds Id -mk_typeable_binds stuff tycon - = mkTyConRepBinds stuff tycon - `unionBags` - unionManyBags (map (mkTyConRepBinds stuff . promoteDataCon) - (tyConDataCons tycon)) - -- | Make typeable bindings for the given 'TyCon'. -mkTyConRepBinds :: TypeableStuff -> TyCon -> LHsBinds Id -mkTyConRepBinds stuff@(Stuff {..}) tycon - = case tyConRepName_maybe tycon of - Just rep_name -> unitBag (mkVarBind rep_id rep_rhs) - where - rep_id = mkExportedVanillaId rep_name (mkTyConTy trTyConTyCon) - rep_rhs = mkTyConRepRHS stuff tycon - _ -> emptyBag +mkTyConRepBinds :: TypeableStuff -> TypeRepTodo + -> TypeableTyCon -> TcRn (Id, LHsBinds Id) +mkTyConRepBinds stuff@(Stuff {..}) todo (TypeableTyCon {..}) + = do -- Place a NOINLINE pragma on KindReps since they tend to be quite large + -- and bloat interface files. + kind_rep_id <- (`setInlinePragma` neverInlinePragma) + <$> newSysLocalId (fsLit "krep") (mkTyConTy kindRepTyCon) + kind_rep <- mkTyConKindRep stuff tycon tycon_kind + + tycon_rep_rhs <- mkTyConRepTyConRHS stuff todo tycon kind_rep_id + let tycon_rep_bind = mkVarBind tycon_rep_id tycon_rep_rhs + kind_rep_bind = mkVarBind kind_rep_id kind_rep + return (kind_rep_id, listToBag [tycon_rep_bind, kind_rep_bind]) + +-- | Here is where we define the set of Typeable types. These exclude type +-- families and polytypes. +tyConIsTypeable :: TyCon -> Bool +tyConIsTypeable tc = + isJust (tyConRepName_maybe tc) + && typeIsTypeable (dropForAlls $ tyConKind tc) + -- Ensure that the kind of the TyCon, with its initial foralls removed, + -- is representable (e.g. has no higher-rank polymorphism or type + -- synonyms). + +-- | Is a particular 'Type' representable by @Typeable@? Here we look for +-- polytypes and types containing casts (which may be, for instance, a type +-- family). +typeIsTypeable :: Type -> Bool +-- We handle types of the form (TYPE rep) specifically to avoid +-- looping on (tyConIsTypeable RuntimeRep) +typeIsTypeable ty + | Just ty' <- coreView ty = typeIsTypeable ty' +typeIsTypeable ty + | Just _ <- isTYPEApp ty = True +typeIsTypeable (TyVarTy _) = True +typeIsTypeable (AppTy a b) = typeIsTypeable a && typeIsTypeable b +typeIsTypeable (FunTy a b) = typeIsTypeable a && typeIsTypeable b +typeIsTypeable (TyConApp tc args) = tyConIsTypeable tc + && all typeIsTypeable args +typeIsTypeable (ForAllTy{}) = False +typeIsTypeable (LitTy _) = True +typeIsTypeable (CastTy{}) = False +typeIsTypeable (CoercionTy{}) = panic "typeIsTypeable(Coercion)" -- | Produce the right-hand-side of a @TyCon@ representation. -mkTyConRepRHS :: TypeableStuff -> TyCon -> LHsExpr Id -mkTyConRepRHS (Stuff {..}) tycon = rep_rhs +mkTyConRepTyConRHS :: TypeableStuff -> TypeRepTodo + -> TyCon -> Id + -> TcRn (LHsExpr Id) +mkTyConRepTyConRHS (Stuff {..}) todo tycon kind_rep_id + = do let rep_rhs = nlHsDataCon trTyConDataCon + `nlHsApp` nlHsLit (word64 dflags high) + `nlHsApp` nlHsLit (word64 dflags low) + `nlHsApp` mod_rep_expr todo + `nlHsApp` trNameLit (mkFastString tycon_str) + `nlHsApp` nlHsLit (int n_kind_vars) + `nlHsApp` nlHsVar kind_rep_id + return rep_rhs where - rep_rhs = nlHsDataCon trTyConDataCon - `nlHsApp` nlHsLit (word64 high) - `nlHsApp` nlHsLit (word64 low) - `nlHsApp` mod_rep - `nlHsApp` (nlHsPar $ trNameLit (mkFastString tycon_str)) - + n_kind_vars = length $ filter isNamedTyConBinder (tyConBinders tycon) tycon_str = add_tick (occNameString (getOccName tycon)) add_tick s | isPromotedDataCon tycon = '\'' : s | otherwise = s - hashThis :: String - hashThis = unwords [pkg_str, mod_str, tycon_str] + -- This must match the computation done in + -- Data.Typeable.Internal.mkTyConFingerprint. + Fingerprint high low = fingerprintFingerprints [ pkg_fingerprint todo + , mod_fingerprint todo + , fingerprintString tycon_str + ] + + int :: Int -> HsLit + int n = HsIntPrim (SourceText $ show n) (toInteger n) - Fingerprint high low = fingerprintString hashThis +word64 :: DynFlags -> Word64 -> HsLit +word64 dflags n + | wORD_SIZE dflags == 4 = HsWord64Prim NoSourceText (toInteger n) + | otherwise = HsWordPrim NoSourceText (toInteger n) - word64 :: Word64 -> HsLit - word64 - | wORD_SIZE dflags == 4 = \n -> HsWord64Prim NoSourceText (toInteger n) - | otherwise = \n -> HsWordPrim NoSourceText (toInteger n) +{- +Note [Representing TyCon kinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +One of the operations supported by Typeable is typeRepKind, + + typeRepKind :: TypeRep (a :: k) -> TypeRep k + +Implementing this is a bit tricky. To see why let's consider the TypeRep +encoding of `Proxy Int` where + + data Proxy (a :: k) :: Type + +which looks like, + + $tcProxy :: TyCon + $trInt :: TypeRep Int + $trType :: TypeRep Type + + $trProxyType :: TypeRep (Proxy :: Type -> Type) + $trProxyType = TrTyCon $tcProxy + [$trType] -- kind variable instantiation + + $trProxy :: TypeRep (Proxy Int) + $trProxy = TrApp $trProxyType $trInt + +Note how $trProxyType encodes only the kind variables of the TyCon +instantiation. To compute the kind (Proxy Int) we need to have a recipe to +compute the kind of a concrete instantiation of Proxy. We call this recipe a +KindRep and store it in the TyCon produced for Proxy, + + type KindBndr = Int -- de Bruijn index + + data KindRep = KindRepTyConApp TyCon [KindRep] + | KindRepVar !KindBndr + | KindRepApp KindRep KindRep + | KindRepFun KindRep KindRep + +The KindRep for Proxy would look like, + + $tkProxy :: KindRep + $tkProxy = KindRepFun (KindRepVar 0) (KindRepTyConApp $trType []) + + +data Maybe a = Nothing | Just a + +'Just :: a -> Maybe a + +F :: forall k. k -> forall k'. k' -> Type +-} + +-- | Produce a @KindRep@ expression for the kind of the given 'TyCon'. +mkTyConKindRep :: TypeableStuff -> TyCon -> Kind -> TcRn (LHsExpr Id) +mkTyConKindRep (Stuff {..}) tycon tycon_kind = do + let (bndrs, kind) = splitForAllTyVarBndrs tycon_kind + bndr_idxs = mkVarEnv $ (`zip` [0..]) $ map binderVar bndrs + traceTc "mkTyConKindRepBinds" + (ppr tycon $$ ppr tycon_kind $$ ppr kind $$ ppr bndr_idxs) + go bndr_idxs kind + where + -- Compute RHS + go :: VarEnv Int -> Kind -> TcRn (LHsExpr Id) + go bndrs ty + | Just ty' <- coreView ty + = go bndrs ty' + go bndrs (TyVarTy v) + | Just idx <- lookupVarEnv bndrs v + = return $ nlHsDataCon kindRepVarDataCon + `nlHsApp` nlHsIntLit (fromIntegral idx) + | otherwise + = pprPanic "mkTyConKindRepBinds.go(tyvar)" (ppr v $$ ppr bndrs) + go bndrs (AppTy t1 t2) + = do t1' <- go bndrs t1 + t2' <- go bndrs t2 + return $ nlHsDataCon kindRepAppDataCon + `nlHsApp` t1' `nlHsApp` t2' + go _ ty | Just rr <- isTYPEApp ty + = return $ nlHsDataCon kindRepTYPEDataCon `nlHsApp` nlHsDataCon rr + go bndrs (TyConApp tc tys) + | Just rep_name <- tyConRepName_maybe tc + = do rep_id <- lookupId rep_name + tys' <- mapM (go bndrs) tys + return $ nlHsDataCon kindRepTyConAppDataCon + `nlHsApp` nlHsVar rep_id + `nlHsApp` mkList (mkTyConTy kindRepTyCon) tys' + | otherwise + = pprPanic "mkTyConKindRepBinds(TyConApp)" + (ppr tc $$ ppr tycon_kind) + go _ (ForAllTy (TvBndr var _) ty) + -- = let bndrs' = extendVarEnv (mapVarEnv (+1) bndrs) var 0 in go bndrs' ty + = pprPanic "mkTyConKindRepBinds(ForAllTy)" (ppr var $$ ppr ty) + go bndrs (FunTy t1 t2) + = do t1' <- go bndrs t1 + t2' <- go bndrs t2 + return $ nlHsDataCon kindRepFunDataCon + `nlHsApp` t1' `nlHsApp` t2' + go _ (LitTy (NumTyLit n)) + = return $ nlHsDataCon kindRepTypeLitSDataCon + `nlHsApp` nlHsDataCon typeLitNatDataCon + `nlHsApp` nlHsLit (mkHsStringPrimLit $ mkFastString $ show n) + go _ (LitTy (StrTyLit s)) + = return $ nlHsDataCon kindRepTypeLitSDataCon + `nlHsApp` nlHsDataCon typeLitSymbolDataCon + `nlHsApp` nlHsLit (mkHsStringPrimLit $ mkFastString $ show s) + go _ (CastTy ty co) + = pprPanic "mkTyConKindRepBinds.go(cast)" (ppr ty $$ ppr co) + go _ (CoercionTy co) + = pprPanic "mkTyConKindRepBinds.go(coercion)" (ppr co) + + mkList :: Type -> [LHsExpr Id] -> LHsExpr Id + mkList ty = foldr consApp (nilExpr ty) + where + cons = consExpr ty + consApp :: LHsExpr Id -> LHsExpr Id -> LHsExpr Id + consApp x xs = cons `nlHsApp` x `nlHsApp` xs + + nilExpr :: Type -> LHsExpr Id + nilExpr ty = mkLHsWrap (mkWpTyApps [ty]) (nlHsDataCon nilDataCon) + + consExpr :: Type -> LHsExpr Id + consExpr ty = mkLHsWrap (mkWpTyApps [ty]) (nlHsDataCon consDataCon) diff --git a/compiler/types/Kind.hs b/compiler/types/Kind.hs index b67eec0874..5fd17f9ee2 100644 --- a/compiler/types/Kind.hs +++ b/compiler/types/Kind.hs @@ -8,6 +8,7 @@ module Kind ( -- ** Predicates on Kinds isLiftedTypeKind, isUnliftedTypeKind, isConstraintKind, + isTYPEApp, returnsTyCon, returnsConstraintKind, isConstraintKindCon, okArrowArgKind, okArrowResultKind, @@ -19,7 +20,9 @@ module Kind ( #include "HsVersions.h" -import {-# SOURCE #-} Type ( typeKind, coreViewOneStarKind ) +import {-# SOURCE #-} Type ( typeKind, coreViewOneStarKind + , splitTyConApp_maybe ) +import {-# SOURCE #-} DataCon ( DataCon ) import TyCoRep import TyCon @@ -68,6 +71,15 @@ isConstraintKindCon tc = tyConUnique tc == constraintKindTyConKey isConstraintKind (TyConApp tc _) = isConstraintKindCon tc isConstraintKind _ = False +isTYPEApp :: Kind -> Maybe DataCon +isTYPEApp (TyConApp tc args) + | tc `hasKey` tYPETyConKey + , [arg] <- args + , Just (tc, []) <- splitTyConApp_maybe arg + , Just dc <- isPromotedDataCon_maybe tc + = Just dc +isTYPEApp _ = Nothing + -- | Does the given type "end" in the given tycon? For example @k -> [a] -> *@ -- ends in @*@ and @Maybe a -> [a]@ ends in @[]@. returnsTyCon :: Unique -> Type -> Bool diff --git a/compiler/types/TyCon.hs b/compiler/types/TyCon.hs index 1b80d20ad4..71400099a6 100644 --- a/compiler/types/TyCon.hs +++ b/compiler/types/TyCon.hs @@ -898,6 +898,7 @@ data AlgTyConFlav -- | An unboxed type constructor. Note that this carries no TyConRepName -- as it is not representable. | UnboxedAlgTyCon + TyConRepName -- | Type constructors representing a class dictionary. -- See Note [ATyCon for classes] in TyCoRep @@ -951,7 +952,7 @@ instance Outputable AlgTyConFlav where -- name, if any okParent :: Name -> AlgTyConFlav -> Bool okParent _ (VanillaAlgTyCon {}) = True -okParent _ (UnboxedAlgTyCon) = True +okParent _ (UnboxedAlgTyCon {}) = True okParent tc_name (ClassTyCon cls _) = tc_name == tyConName (classTyCon cls) okParent _ (DataFamInstTyCon _ fam_tc tys) = tyConArity fam_tc == length tys @@ -1169,6 +1170,7 @@ tyConRepName_maybe (PrimTyCon { primRepName = mb_rep_nm }) tyConRepName_maybe (AlgTyCon { algTcParent = parent }) | VanillaAlgTyCon rep_nm <- parent = Just rep_nm | ClassTyCon _ rep_nm <- parent = Just rep_nm + | UnboxedAlgTyCon rep_nm <- parent = Just rep_nm tyConRepName_maybe (FamilyTyCon { famTcFlav = DataFamilyTyCon rep_nm }) = Just rep_nm tyConRepName_maybe (PromotedDataCon { tcRepName = rep_nm }) @@ -2057,7 +2059,7 @@ isTcTyCon _ = False -- Precondition: The fully-applied TyCon has kind (TYPE blah) isTcLevPoly :: TyCon -> Bool isTcLevPoly FunTyCon{} = False -isTcLevPoly (AlgTyCon { algTcParent = UnboxedAlgTyCon }) = True +isTcLevPoly (AlgTyCon { algTcParent = UnboxedAlgTyCon _ }) = True isTcLevPoly AlgTyCon{} = False isTcLevPoly SynonymTyCon{} = True isTcLevPoly FamilyTyCon{} = True diff --git a/compiler/types/Type.hs b/compiler/types/Type.hs index a50b76b2a3..460eb5e5e4 100644 --- a/compiler/types/Type.hs +++ b/compiler/types/Type.hs @@ -1055,13 +1055,13 @@ splitTyConApp ty = case splitTyConApp_maybe ty of -- | Attempts to tease a type apart into a type constructor and the application -- of a number of arguments to that constructor -splitTyConApp_maybe :: HasCallStack => Type -> Maybe (TyCon, [Type]) +splitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type]) splitTyConApp_maybe ty | Just ty' <- coreView ty = splitTyConApp_maybe ty' splitTyConApp_maybe ty = repSplitTyConApp_maybe ty -- | Like 'splitTyConApp_maybe', but doesn't look through synonyms. This -- assumes the synonyms have already been dealt with. -repSplitTyConApp_maybe :: HasCallStack => Type -> Maybe (TyCon, [Type]) +repSplitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type]) repSplitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys) repSplitTyConApp_maybe (FunTy arg res) | Just rep1 <- getRuntimeRep_maybe arg diff --git a/compiler/types/Type.hs-boot b/compiler/types/Type.hs-boot index 9436d195cc..560c251f1b 100644 --- a/compiler/types/Type.hs-boot +++ b/compiler/types/Type.hs-boot @@ -1,7 +1,10 @@ +{-# LANGUAGE FlexibleContexts #-} + module Type where import TyCon import Var ( TyVar ) import {-# SOURCE #-} TyCoRep( Type, Kind ) +import Util isPredTy :: Type -> Bool isCoercionTy :: Type -> Bool @@ -19,3 +22,5 @@ partitionInvisibles :: TyCon -> (a -> Type) -> [a] -> ([a], [a]) coreView :: Type -> Maybe Type tyCoVarsOfTypesWellScoped :: [Type] -> [TyVar] + +splitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type]) diff --git a/compiler/utils/Binary.hs b/compiler/utils/Binary.hs index ffd1eb25fa..b10ab1d5f2 100644 --- a/compiler/utils/Binary.hs +++ b/compiler/utils/Binary.hs @@ -1,5 +1,8 @@ {-# LANGUAGE CPP, MagicHash, UnboxedTuples #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE GADTs #-} {-# OPTIONS_GHC -O -funbox-strict-fields #-} -- We always optimise this, otherwise performance of a non-optimised @@ -73,7 +76,14 @@ import qualified Data.ByteString.Unsafe as BS import Data.IORef import Data.Char ( ord, chr ) import Data.Time +#if MIN_VERSION_base(4,10,0) +import Type.Reflection +import Type.Reflection.Unsafe +import Data.Kind (Type) +import GHC.Exts (RuntimeRep(..), VecCount(..), VecElem(..)) +#else import Data.Typeable +#endif import Control.Monad ( when ) import System.IO as IO import System.IO.Unsafe ( unsafeInterleaveIO ) @@ -597,17 +607,175 @@ instance Binary (Bin a) where -- ----------------------------------------------------------------------------- -- Instances for Data.Typeable stuff +#if MIN_VERSION_base(4,10,0) instance Binary TyCon where put_ bh tc = do put_ bh (tyConPackage tc) put_ bh (tyConModule tc) put_ bh (tyConName tc) + put_ bh (tyConKindArgs tc) + put_ bh (tyConKindRep tc) + get bh = + mkTyCon <$> get bh <*> get bh <*> get bh <*> get bh <*> get bh +#else +instance Binary TyCon where + put_ bh tc = do + put_ bh (tyConPackage tc) + put_ bh (tyConModule tc) + put_ bh (tyConName tc) + get bh = + mkTyCon3 <$> get bh <*> get bh <*> get bh +#endif + +#if MIN_VERSION_base(4,10,0) +instance Binary VecCount where + put_ bh = putByte bh . fromIntegral . fromEnum + get bh = toEnum . fromIntegral <$> getByte bh + +instance Binary VecElem where + put_ bh = putByte bh . fromIntegral . fromEnum + get bh = toEnum . fromIntegral <$> getByte bh + +instance Binary RuntimeRep where + put_ bh (VecRep a b) = putByte bh 0 >> put_ bh a >> put_ bh b + put_ bh (TupleRep reps) = putByte bh 1 >> put_ bh reps + put_ bh (SumRep reps) = putByte bh 2 >> put_ bh reps + put_ bh LiftedRep = putByte bh 3 + put_ bh UnliftedRep = putByte bh 4 + put_ bh IntRep = putByte bh 5 + put_ bh WordRep = putByte bh 6 + put_ bh Int64Rep = putByte bh 7 + put_ bh Word64Rep = putByte bh 8 + put_ bh AddrRep = putByte bh 9 + put_ bh FloatRep = putByte bh 10 + put_ bh DoubleRep = putByte bh 11 + get bh = do - p <- get bh - m <- get bh - n <- get bh - return (mkTyCon3 p m n) + tag <- getByte bh + case tag of + 0 -> VecRep <$> get bh <*> get bh + 1 -> TupleRep <$> get bh + 2 -> SumRep <$> get bh + 3 -> pure LiftedRep + 4 -> pure UnliftedRep + 5 -> pure IntRep + 6 -> pure WordRep + 7 -> pure Int64Rep + 8 -> pure Word64Rep + 9 -> pure AddrRep + 10 -> pure FloatRep + 11 -> pure DoubleRep + _ -> fail "Binary.putRuntimeRep: invalid tag" + +instance Binary KindRep where + put_ bh (KindRepTyConApp tc k) = putByte bh 0 >> put_ bh tc >> put_ bh k + put_ bh (KindRepVar bndr) = putByte bh 1 >> put_ bh bndr + put_ bh (KindRepApp a b) = putByte bh 2 >> put_ bh a >> put_ bh b + put_ bh (KindRepFun a b) = putByte bh 3 >> put_ bh a >> put_ bh b + put_ bh (KindRepTYPE r) = putByte bh 4 >> put_ bh r + put_ bh (KindRepTypeLit sort r) = putByte bh 5 >> put_ bh sort >> put_ bh r + put_ _ _ = fail "Binary.putKindRep: impossible" + get bh = do + tag <- getByte bh + case tag of + 0 -> KindRepTyConApp <$> get bh <*> get bh + 1 -> KindRepVar <$> get bh + 2 -> KindRepApp <$> get bh <*> get bh + 3 -> KindRepFun <$> get bh <*> get bh + 4 -> KindRepTYPE <$> get bh + 5 -> KindRepTypeLit <$> get bh <*> get bh + _ -> fail "Binary.putKindRep: invalid tag" + +instance Binary TypeLitSort where + put_ bh TypeLitSymbol = putByte bh 0 + put_ bh TypeLitNat = putByte bh 1 + get bh = do + tag <- getByte bh + case tag of + 0 -> pure TypeLitSymbol + 1 -> pure TypeLitNat + _ -> fail "Binary.putTypeLitSort: invalid tag" + +putTypeRep :: BinHandle -> TypeRep a -> IO () +-- Special handling for TYPE, (->), and RuntimeRep due to recursive kind +-- relations. +-- See Note [Mutually recursive representations of primitive types] +putTypeRep bh rep + | Just HRefl <- rep `eqTypeRep` (typeRep :: TypeRep Type) + = put_ bh (0 :: Word8) +putTypeRep bh (Con' con ks) = do + put_ bh (1 :: Word8) + put_ bh con + put_ bh ks +putTypeRep bh (App f x) = do + put_ bh (2 :: Word8) + putTypeRep bh f + putTypeRep bh x +putTypeRep bh (Fun arg res) = do + put_ bh (3 :: Word8) + putTypeRep bh arg + putTypeRep bh res +putTypeRep _ _ = fail "Binary.putTypeRep: Impossible" + +getSomeTypeRep :: BinHandle -> IO SomeTypeRep +getSomeTypeRep bh = do + tag <- get bh :: IO Word8 + case tag of + 0 -> return $ SomeTypeRep (typeRep :: TypeRep Type) + 1 -> do con <- get bh :: IO TyCon + ks <- get bh :: IO [SomeTypeRep] + return $ SomeTypeRep $ mkTrCon con ks + + 2 -> do SomeTypeRep f <- getSomeTypeRep bh + SomeTypeRep x <- getSomeTypeRep bh + case typeRepKind f of + Fun arg res -> + case arg `eqTypeRep` typeRepKind x of + Just HRefl -> + case typeRepKind res `eqTypeRep` (typeRep :: TypeRep Type) of + Just HRefl -> return $ SomeTypeRep $ mkTrApp f x + _ -> failure "Kind mismatch in type application" [] + _ -> failure "Kind mismatch in type application" + [ " Found argument of kind: " ++ show (typeRepKind x) + , " Where the constructor: " ++ show f + , " Expects kind: " ++ show arg + ] + _ -> failure "Applied non-arrow" + [ " Applied type: " ++ show f + , " To argument: " ++ show x + ] + 3 -> do SomeTypeRep arg <- getSomeTypeRep bh + SomeTypeRep res <- getSomeTypeRep bh + case typeRepKind arg `eqTypeRep` (typeRep :: TypeRep Type) of + Just HRefl -> + case typeRepKind res `eqTypeRep` (typeRep :: TypeRep Type) of + Just HRefl -> return $ SomeTypeRep $ Fun arg res + Nothing -> failure "Kind mismatch" [] + _ -> failure "Kind mismatch" [] + _ -> failure "Invalid SomeTypeRep" [] + where + failure description info = + fail $ unlines $ [ "Binary.getSomeTypeRep: "++description ] + ++ map (" "++) info + +instance Typeable a => Binary (TypeRep (a :: k)) where + put_ = putTypeRep + get bh = do + SomeTypeRep rep <- getSomeTypeRep bh + case rep `eqTypeRep` expected of + Just HRefl -> pure rep + Nothing -> fail $ unlines + [ "Binary: Type mismatch" + , " Deserialized type: " ++ show rep + , " Expected type: " ++ show expected + ] + where expected = typeRep :: TypeRep a + +instance Binary SomeTypeRep where + put_ bh (SomeTypeRep rep) = putTypeRep bh rep + get = getSomeTypeRep +#else instance Binary TypeRep where put_ bh type_rep = do let (ty_con, child_type_reps) = splitTyConApp type_rep @@ -617,6 +785,7 @@ instance Binary TypeRep where ty_con <- get bh child_type_reps <- get bh return (mkTyConApp ty_con child_type_reps) +#endif -- ----------------------------------------------------------------------------- -- Lazy reading/writing diff --git a/compiler/utils/Fingerprint.hsc b/compiler/utils/Fingerprint.hsc index f797654e0c..d4cee0e10b 100644 --- a/compiler/utils/Fingerprint.hsc +++ b/compiler/utils/Fingerprint.hsc @@ -15,6 +15,7 @@ module Fingerprint ( fingerprintByteString, -- * Re-exported from GHC.Fingerprint Fingerprint(..), fingerprint0, + fingerprintFingerprints, fingerprintData, fingerprintString, getFileHash diff --git a/libraries/base/Data/Dynamic.hs b/libraries/base/Data/Dynamic.hs index 218bdc1f1e..5a4f3f9a08 100644 --- a/libraries/base/Data/Dynamic.hs +++ b/libraries/base/Data/Dynamic.hs @@ -1,51 +1,55 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Dynamic -- Copyright : (c) The University of Glasgow 2001 -- License : BSD-style (see the file libraries/base/LICENSE) --- +-- -- Maintainer : libraries@haskell.org -- Stability : experimental -- Portability : portable -- -- The Dynamic interface provides basic support for dynamic types. --- +-- -- Operations for injecting values of arbitrary type into -- a dynamically typed value, Dynamic, are provided, together -- with operations for converting dynamic values into a concrete -- (monomorphic) type. --- +-- ----------------------------------------------------------------------------- module Data.Dynamic ( - -- * Module Data.Typeable re-exported for convenience - module Data.Typeable, - -- * The @Dynamic@ type - Dynamic, -- abstract, instance of: Show, Typeable + Dynamic(..), -- * Converting to and from @Dynamic@ toDyn, fromDyn, fromDynamic, - + -- * Applying functions of dynamic type dynApply, dynApp, - dynTypeRep + dynTypeRep, + + -- * Convenience re-exports + Typeable ) where -import Data.Typeable +import Data.Type.Equality +import Type.Reflection import Data.Maybe -import Unsafe.Coerce import GHC.Base import GHC.Show @@ -67,30 +71,30 @@ import GHC.Exception 'Show'ing a value of type 'Dynamic' returns a pretty-printed representation of the object\'s type; useful for debugging. -} -data Dynamic = Dynamic TypeRep Obj +data Dynamic where + Dynamic :: forall a. TypeRep a -> a -> Dynamic -- | @since 2.01 instance Show Dynamic where -- the instance just prints the type representation. - showsPrec _ (Dynamic t _) = - showString "<<" . - showsPrec 0 t . + showsPrec _ (Dynamic t _) = + showString "<<" . + showsPrec 0 t . showString ">>" -- here so that it isn't an orphan: -- | @since 4.0.0.0 instance Exception Dynamic -type Obj = Any -- Use GHC's primitive 'Any' type to hold the dynamically typed value. -- -- In GHC's new eval/apply execution model this type must not look - -- like a data type. If it did, GHC would use the constructor convention - -- when evaluating it, and this will go wrong if the object is really a + -- like a data type. If it did, GHC would use the constructor convention + -- when evaluating it, and this will go wrong if the object is really a -- function. Using Any forces GHC to use -- a fallback convention for evaluating it that works for all types. --- | Converts an arbitrary value into an object of type 'Dynamic'. +-- | Converts an arbitrary value into an object of type 'Dynamic'. -- -- The type of the object must be an instance of 'Typeable', which -- ensures that only monomorphically-typed objects may be converted to @@ -100,47 +104,48 @@ type Obj = Any -- > toDyn (id :: Int -> Int) -- toDyn :: Typeable a => a -> Dynamic -toDyn v = Dynamic (typeOf v) (unsafeCoerce v) +toDyn v = Dynamic typeRep v -- | Converts a 'Dynamic' object back into an ordinary Haskell value of -- the correct type. See also 'fromDynamic'. fromDyn :: Typeable a => Dynamic -- ^ the dynamically-typed object - -> a -- ^ a default value + -> a -- ^ a default value -> a -- ^ returns: the value of the first argument, if -- it has the correct type, otherwise the value of -- the second argument. fromDyn (Dynamic t v) def - | typeOf def == t = unsafeCoerce v - | otherwise = def + | Just HRefl <- t `eqTypeRep` typeOf def = v + | otherwise = def -- | Converts a 'Dynamic' object back into an ordinary Haskell value of -- the correct type. See also 'fromDyn'. fromDynamic - :: Typeable a + :: forall a. Typeable a => Dynamic -- ^ the dynamically-typed object -> Maybe a -- ^ returns: @'Just' a@, if the dynamically-typed - -- object has the correct type (and @a@ is its value), + -- object has the correct type (and @a@ is its value), -- or 'Nothing' otherwise. -fromDynamic (Dynamic t v) = - case unsafeCoerce v of - r | t == typeOf r -> Just r - | otherwise -> Nothing +fromDynamic (Dynamic t v) + | Just HRefl <- t `eqTypeRep` rep = Just v + | otherwise = Nothing + where rep = typeRep :: TypeRep a -- (f::(a->b)) `dynApply` (x::a) = (f a)::b dynApply :: Dynamic -> Dynamic -> Maybe Dynamic -dynApply (Dynamic t1 f) (Dynamic t2 x) = - case funResultTy t1 t2 of - Just t3 -> Just (Dynamic t3 ((unsafeCoerce f) x)) - Nothing -> Nothing +dynApply (Dynamic (Fun ta tr) f) (Dynamic ta' x) + | Just HRefl <- ta `eqTypeRep` ta' + , Just HRefl <- typeRep @Type `eqTypeRep` typeRepKind tr + = Just (Dynamic tr (f x)) +dynApply _ _ + = Nothing dynApp :: Dynamic -> Dynamic -> Dynamic -dynApp f x = case dynApply f x of +dynApp f x = case dynApply f x of Just r -> r Nothing -> errorWithoutStackTrace ("Type error in dynamic application.\n" ++ "Can't apply function " ++ show f ++ " to argument " ++ show x) -dynTypeRep :: Dynamic -> TypeRep -dynTypeRep (Dynamic tr _) = tr - +dynTypeRep :: Dynamic -> SomeTypeRep +dynTypeRep (Dynamic tr _) = SomeTypeRep tr diff --git a/libraries/base/Data/Type/Equality.hs b/libraries/base/Data/Type/Equality.hs index 233020081b..73f8407cb0 100644 --- a/libraries/base/Data/Type/Equality.hs +++ b/libraries/base/Data/Type/Equality.hs @@ -34,6 +34,7 @@ module Data.Type.Equality ( -- * The equality types (:~:)(..), type (~~), + (:~~:)(..), -- * Working with equality sym, trans, castWith, gcastWith, apply, inner, outer, @@ -137,6 +138,13 @@ instance a ~ b => Enum (a :~: b) where -- | @since 4.7.0.0 deriving instance a ~ b => Bounded (a :~: b) +-- | Kind heterogeneous propositional equality. Like '(:~:)', @a :~~: b@ is +-- inhabited by a terminating value if and only if @a@ is the same type as @b@. +-- +-- @since 4.10.0.0 +data (a :: k1) :~~: (b :: k2) where + HRefl :: a :~~: a + -- | This class contains types where you can learn the equality of two types -- from information contained in /terms/. Typically, only singleton types should -- inhabit this class. diff --git a/libraries/base/Data/Typeable.hs b/libraries/base/Data/Typeable.hs index d7225196de..8a6422ec14 100644 --- a/libraries/base/Data/Typeable.hs +++ b/libraries/base/Data/Typeable.hs @@ -3,6 +3,8 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE TypeOperators #-} ----------------------------------------------------------------------------- @@ -10,7 +12,7 @@ -- Module : Data.Typeable -- Copyright : (c) The University of Glasgow, CWI 2001--2004 -- License : BSD-style (see the file libraries/base/LICENSE) --- +-- -- Maintainer : libraries@haskell.org -- Stability : experimental -- Portability : portable @@ -26,6 +28,11 @@ -- -- == Compatibility Notes -- +-- Since GHC 8.2, GHC has supported type-indexed type representations. +-- "Data.Typeable" provides type representations which are qualified over this +-- index, providing an interface very similar to the "Typeable" notion seen in +-- previous releases. For the type-indexed interface, see "Data.Reflection". +-- -- Since GHC 7.8, 'Typeable' is poly-kinded. The changes required for this might -- break some old programs involving 'Typeable'. More details on this, including -- how to fix your code, can be found on the @@ -34,85 +41,99 @@ ----------------------------------------------------------------------------- module Data.Typeable - ( - -- * The Typeable class - Typeable, - typeRep, - - -- * Propositional equality - (:~:)(Refl), - - -- * For backwards compatibility - typeOf, typeOf1, typeOf2, typeOf3, typeOf4, typeOf5, typeOf6, typeOf7, - Typeable1, Typeable2, Typeable3, Typeable4, Typeable5, Typeable6, - Typeable7, - - -- * Type-safe cast - cast, - eqT, - gcast, -- a generalisation of cast - - -- * Generalized casts for higher-order kinds - gcast1, -- :: ... => c (t a) -> Maybe (c (t' a)) - gcast2, -- :: ... => c (t a b) -> Maybe (c (t' a b)) - - -- * A canonical proxy type - Proxy (..), - - -- * Type representations - TypeRep, -- abstract, instance of: Eq, Show, Typeable - typeRepFingerprint, - rnfTypeRep, - showsTypeRep, - - TyCon, -- abstract, instance of: Eq, Show, Typeable - -- For now don't export Module, to avoid name clashes - tyConFingerprint, - tyConPackage, - tyConModule, - tyConName, - rnfTyCon, - - -- * Construction of type representations - -- mkTyCon, -- :: String -> TyCon - mkTyCon3, -- :: String -> String -> String -> TyCon - mkTyConApp, -- :: TyCon -> [TypeRep] -> TypeRep - mkAppTy, -- :: TypeRep -> TypeRep -> TypeRep - mkFunTy, -- :: TypeRep -> TypeRep -> TypeRep - - -- * Observation of type representations - splitTyConApp, -- :: TypeRep -> (TyCon, [TypeRep]) - funResultTy, -- :: TypeRep -> TypeRep -> Maybe TypeRep - typeRepTyCon, -- :: TypeRep -> TyCon - typeRepArgs, -- :: TypeRep -> [TypeRep] - ) where - -import Data.Typeable.Internal + ( -- * The Typeable class + Typeable + , typeOf + , typeRep + , I.withTypeable + + -- * Propositional equality + , (:~:)(Refl) + , (:~~:)(HRefl) + + -- * Type-safe cast + , cast + , eqT + , gcast -- a generalisation of cast + + -- * Generalized casts for higher-order kinds + , gcast1 -- :: ... => c (t a) -> Maybe (c (t' a)) + , gcast2 -- :: ... => c (t a b) -> Maybe (c (t' a b)) + + -- * A canonical proxy type + , Proxy (..) + + -- * Type representations + , TypeRep + , typeRepTyCon + , rnfTypeRep + , showsTypeRep + , mkFunTy + + -- * Observing type representations + , funResultTy + , I.typeRepFingerprint + + -- * Type constructors + , I.TyCon -- abstract, instance of: Eq, Show, Typeable + -- For now don't export Module to avoid name clashes + , I.tyConPackage + , I.tyConModule + , I.tyConName + , I.rnfTyCon + + -- * For backwards compatibility + , typeOf1, typeOf2, typeOf3, typeOf4, typeOf5, typeOf6, typeOf7 + , Typeable1, Typeable2, Typeable3, Typeable4 + , Typeable5, Typeable6, Typeable7 + ) where + +import qualified Data.Typeable.Internal as I +import Data.Typeable.Internal (Typeable) import Data.Type.Equality -import Unsafe.Coerce import Data.Maybe +import Data.Proxy +import GHC.Show import GHC.Base -------------------------------------------------------------- --- --- Type-safe cast +-- | A quantified type representation. +type TypeRep = I.SomeTypeRep + +-- | Observe a type representation for the type of a value. +typeOf :: forall a. Typeable a => a -> TypeRep +typeOf _ = I.typeRepX (Proxy :: Proxy a) + +-- | Takes a value of type @a@ and returns a concrete representation +-- of that type. -- -------------------------------------------------------------- +-- @since 4.7.0.0 +typeRep :: forall proxy a. Typeable a => proxy a -> TypeRep +typeRep = I.typeRepX + +-- | Show a type representation +showsTypeRep :: I.SomeTypeRep -> ShowS +showsTypeRep = shows -- | The type-safe cast operation cast :: forall a b. (Typeable a, Typeable b) => a -> Maybe b -cast x = if typeRep (Proxy :: Proxy a) == typeRep (Proxy :: Proxy b) - then Just $ unsafeCoerce x - else Nothing +cast x + | Just HRefl <- ta `I.eqTypeRep` tb = Just x + | otherwise = Nothing + where + ta = I.typeRep :: I.TypeRep a + tb = I.typeRep :: I.TypeRep b -- | Extract a witness of equality of two types -- -- @since 4.7.0.0 eqT :: forall a b. (Typeable a, Typeable b) => Maybe (a :~: b) -eqT = if typeRep (Proxy :: Proxy a) == typeRep (Proxy :: Proxy b) - then Just $ unsafeCoerce Refl - else Nothing +eqT + | Just HRefl <- ta `I.eqTypeRep` tb = Just Refl + | otherwise = Nothing + where + ta = I.typeRep :: I.TypeRep a + tb = I.typeRep :: I.TypeRep b -- | A flexible variation parameterised in a type constructor gcast :: forall a b c. (Typeable a, Typeable b) => c a -> Maybe (c b) @@ -120,11 +141,86 @@ gcast x = fmap (\Refl -> x) (eqT :: Maybe (a :~: b)) -- | Cast over @k1 -> k2@ gcast1 :: forall c t t' a. (Typeable t, Typeable t') - => c (t a) -> Maybe (c (t' a)) + => c (t a) -> Maybe (c (t' a)) gcast1 x = fmap (\Refl -> x) (eqT :: Maybe (t :~: t')) -- | Cast over @k1 -> k2 -> k3@ gcast2 :: forall c t t' a b. (Typeable t, Typeable t') - => c (t a b) -> Maybe (c (t' a b)) + => c (t a b) -> Maybe (c (t' a b)) gcast2 x = fmap (\Refl -> x) (eqT :: Maybe (t :~: t')) +-- | Observe the type constructor of a quantified type representation. +typeRepTyCon :: TypeRep -> TyCon +typeRepTyCon = I.typeRepXTyCon + +-- | Applies a type to a function type. Returns: @Just u@ if the first argument +-- represents a function of type @t -> u@ and the second argument represents a +-- function of type @t@. Otherwise, returns @Nothing@. +funResultTy :: TypeRep -> TypeRep -> Maybe TypeRep +funResultTy (I.SomeTypeRep f) (I.SomeTypeRep x) + | Just HRefl <- (I.typeRep :: I.TypeRep Type) `I.eqTypeRep` I.typeRepKind f + , I.Fun arg res <- f + , Just HRefl <- arg `I.eqTypeRep` x + = Just (I.SomeTypeRep res) + | otherwise = Nothing + +-- | Build a function type. +mkFunTy :: TypeRep -> TypeRep -> TypeRep +mkFunTy (I.SomeTypeRep arg) (I.SomeTypeRep res) + | Just HRefl <- I.typeRepKind arg `I.eqTypeRep` liftedTy + , Just HRefl <- I.typeRepKind res `I.eqTypeRep` liftedTy + = I.SomeTypeRep (I.Fun arg res) + | otherwise + = error $ "mkFunTy: Attempted to construct function type from non-lifted "++ + "type: arg="++show arg++", res="++show res + where liftedTy = I.typeRep :: I.TypeRep * + -- TODO: We should be able to support this but the kind of (->) must be + -- generalized + +-- | Force a 'TypeRep' to normal form. +rnfTypeRep :: TypeRep -> () +rnfTypeRep = I.rnfSomeTypeRep + + +-- Keeping backwards-compatibility +typeOf1 :: forall t (a :: *). Typeable t => t a -> TypeRep +typeOf1 _ = I.typeRepX (Proxy :: Proxy t) + +typeOf2 :: forall t (a :: *) (b :: *). Typeable t => t a b -> TypeRep +typeOf2 _ = I.typeRepX (Proxy :: Proxy t) + +typeOf3 :: forall t (a :: *) (b :: *) (c :: *). Typeable t + => t a b c -> TypeRep +typeOf3 _ = I.typeRepX (Proxy :: Proxy t) + +typeOf4 :: forall t (a :: *) (b :: *) (c :: *) (d :: *). Typeable t + => t a b c d -> TypeRep +typeOf4 _ = I.typeRepX (Proxy :: Proxy t) + +typeOf5 :: forall t (a :: *) (b :: *) (c :: *) (d :: *) (e :: *). Typeable t + => t a b c d e -> TypeRep +typeOf5 _ = I.typeRepX (Proxy :: Proxy t) + +typeOf6 :: forall t (a :: *) (b :: *) (c :: *) (d :: *) (e :: *) (f :: *). + Typeable t => t a b c d e f -> TypeRep +typeOf6 _ = I.typeRepX (Proxy :: Proxy t) + +typeOf7 :: forall t (a :: *) (b :: *) (c :: *) (d :: *) (e :: *) (f :: *) + (g :: *). Typeable t => t a b c d e f g -> TypeRep +typeOf7 _ = I.typeRepX (Proxy :: Proxy t) + +type Typeable1 (a :: * -> *) = Typeable a +type Typeable2 (a :: * -> * -> *) = Typeable a +type Typeable3 (a :: * -> * -> * -> *) = Typeable a +type Typeable4 (a :: * -> * -> * -> * -> *) = Typeable a +type Typeable5 (a :: * -> * -> * -> * -> * -> *) = Typeable a +type Typeable6 (a :: * -> * -> * -> * -> * -> * -> *) = Typeable a +type Typeable7 (a :: * -> * -> * -> * -> * -> * -> * -> *) = Typeable a + +{-# DEPRECATED Typeable1 "renamed to 'Typeable'" #-} -- deprecated in 7.8 +{-# DEPRECATED Typeable2 "renamed to 'Typeable'" #-} -- deprecated in 7.8 +{-# DEPRECATED Typeable3 "renamed to 'Typeable'" #-} -- deprecated in 7.8 +{-# DEPRECATED Typeable4 "renamed to 'Typeable'" #-} -- deprecated in 7.8 +{-# DEPRECATED Typeable5 "renamed to 'Typeable'" #-} -- deprecated in 7.8 +{-# DEPRECATED Typeable6 "renamed to 'Typeable'" #-} -- deprecated in 7.8 +{-# DEPRECATED Typeable7 "renamed to 'Typeable'" #-} -- deprecated in 7.8 diff --git a/libraries/base/Data/Typeable/Internal.hs b/libraries/base/Data/Typeable/Internal.hs index 7746bfbe6c..800dc2a66f 100644 --- a/libraries/base/Data/Typeable/Internal.hs +++ b/libraries/base/Data/Typeable/Internal.hs @@ -1,9 +1,16 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE PolyKinds #-} @@ -25,12 +32,11 @@ ----------------------------------------------------------------------------- module Data.Typeable.Internal ( - Proxy (..), Fingerprint(..), -- * Typeable class - typeOf, typeOf1, typeOf2, typeOf3, typeOf4, typeOf5, typeOf6, typeOf7, - Typeable1, Typeable2, Typeable3, Typeable4, Typeable5, Typeable6, Typeable7, + Typeable(..), + withTypeable, -- * Module Module, -- Abstract @@ -38,37 +44,45 @@ module Data.Typeable.Internal ( -- * TyCon TyCon, -- Abstract - tyConPackage, tyConModule, tyConName, tyConFingerprint, - mkTyCon3, mkTyCon3#, + tyConPackage, tyConModule, tyConName, tyConKindArgs, tyConKindRep, + KindRep(.., KindRepTypeLit), TypeLitSort(..), rnfTyCon, -- * TypeRep - TypeRep(..), KindRep, + TypeRep, + pattern App, pattern Con, pattern Con', pattern Fun, typeRep, - mkTyConApp, - mkPolyTyConApp, - mkAppTy, + typeOf, typeRepTyCon, - Typeable(..), - mkFunTy, - splitTyConApp, - splitPolyTyConApp, - funResultTy, - typeRepArgs, typeRepFingerprint, rnfTypeRep, - showsTypeRep, - typeRepKinds, - typeSymbolTypeRep, typeNatTypeRep + eqTypeRep, + typeRepKind, + + -- * SomeTypeRep + SomeTypeRep(..), + typeRepX, + typeRepXTyCon, + typeRepXFingerprint, + rnfSomeTypeRep, + + -- * Construction + -- | These are for internal use only + mkTrCon, mkTrApp, mkTrFun, + mkTyCon, mkTyCon#, + typeSymbolTypeRep, typeNatTypeRep, ) where import GHC.Base -import GHC.Types (TYPE) +import qualified GHC.Arr as A +import GHC.Types ( TYPE ) +import Data.Type.Equality +import GHC.List ( splitAt, foldl ) import GHC.Word import GHC.Show -import Data.Proxy import GHC.TypeLits ( KnownSymbol, symbolVal' ) import GHC.TypeNats ( KnownNat, natVal' ) +import Unsafe.Coerce ( unsafeCoerce ) import GHC.Fingerprint.Type import {-# SOURCE #-} GHC.Fingerprint @@ -92,52 +106,27 @@ moduleName :: Module -> String moduleName (Module _ m) = trNameString m tyConPackage :: TyCon -> String -tyConPackage (TyCon _ _ m _) = modulePackage m +tyConPackage (TyCon _ _ m _ _ _) = modulePackage m tyConModule :: TyCon -> String -tyConModule (TyCon _ _ m _) = moduleName m +tyConModule (TyCon _ _ m _ _ _) = moduleName m tyConName :: TyCon -> String -tyConName (TyCon _ _ _ n) = trNameString n +tyConName (TyCon _ _ _ n _ _) = trNameString n trNameString :: TrName -> String trNameString (TrNameS s) = unpackCString# s trNameString (TrNameD s) = s tyConFingerprint :: TyCon -> Fingerprint -tyConFingerprint (TyCon hi lo _ _) +tyConFingerprint (TyCon hi lo _ _ _ _) = Fingerprint (W64# hi) (W64# lo) -mkTyCon3# :: Addr# -- ^ package name - -> Addr# -- ^ module name - -> Addr# -- ^ the name of the type constructor - -> TyCon -- ^ A unique 'TyCon' object -mkTyCon3# pkg modl name - | Fingerprint (W64# hi) (W64# lo) <- fingerprint - = TyCon hi lo (Module (TrNameS pkg) (TrNameS modl)) (TrNameS name) - where - fingerprint :: Fingerprint - fingerprint = fingerprintString (unpackCString# pkg - ++ (' ': unpackCString# modl) - ++ (' ' : unpackCString# name)) - -mkTyCon3 :: String -- ^ package name - -> String -- ^ module name - -> String -- ^ the name of the type constructor - -> TyCon -- ^ A unique 'TyCon' object --- Used when the strings are dynamically allocated, --- eg from binary deserialisation -mkTyCon3 pkg modl name - | Fingerprint (W64# hi) (W64# lo) <- fingerprint - = TyCon hi lo (Module (TrNameD pkg) (TrNameD modl)) (TrNameD name) - where - fingerprint :: Fingerprint - fingerprint = fingerprintString (pkg ++ (' ':modl) ++ (' ':name)) +tyConKindArgs :: TyCon -> Int +tyConKindArgs (TyCon _ _ _ _ n _) = I# n -isTupleTyCon :: TyCon -> Bool -isTupleTyCon tc - | ('(':',':_) <- tyConName tc = True - | otherwise = False +tyConKindRep :: TyCon -> KindRep +tyConKindRep (TyCon _ _ _ _ _ k) = k -- | Helper to fully evaluate 'TyCon' for use as @NFData(rnf)@ implementation -- @@ -149,12 +138,28 @@ rnfTrName :: TrName -> () rnfTrName (TrNameS _) = () rnfTrName (TrNameD n) = rnfString n -rnfTyCon :: TyCon -> () -rnfTyCon (TyCon _ _ m n) = rnfModule m `seq` rnfTrName n +rnfKindRep :: KindRep -> () +rnfKindRep (KindRepTyConApp tc args) = rnfTyCon tc `seq` rnfList rnfKindRep args +rnfKindRep (KindRepVar _) = () +rnfKindRep (KindRepApp a b) = rnfKindRep a `seq` rnfKindRep b +rnfKindRep (KindRepFun a b) = rnfKindRep a `seq` rnfKindRep b +rnfKindRep (KindRepTYPE rr) = rnfRuntimeRep rr +rnfKindRep (KindRepTypeLitS _ _) = () +rnfKindRep (KindRepTypeLitD _ t) = rnfString t + +rnfRuntimeRep :: RuntimeRep -> () +rnfRuntimeRep (VecRep !_ !_) = () +rnfRuntimeRep !_ = () + +rnfList :: (a -> ()) -> [a] -> () +rnfList _ [] = () +rnfList force (x:xs) = force x `seq` rnfList force xs rnfString :: [Char] -> () -rnfString [] = () -rnfString (c:cs) = c `seq` rnfString cs +rnfString = rnfList (`seq` ()) + +rnfTyCon :: TyCon -> () +rnfTyCon (TyCon _ _ m n _ k) = rnfModule m `seq` rnfTrName n `seq` rnfKindRep k {- ********************************************************************* @@ -165,118 +170,279 @@ rnfString (c:cs) = c `seq` rnfString cs -- | A concrete representation of a (monomorphic) type. -- 'TypeRep' supports reasonably efficient equality. -data TypeRep = TypeRep {-# UNPACK #-} !Fingerprint TyCon [KindRep] [TypeRep] - -- NB: For now I've made this lazy so that it's easy to - -- optimise code that constructs and deconstructs TypeReps - -- perf/should_run/T9203 is a good example - -- Also note that mkAppTy does discards the fingerprint, - -- so it's a waste to compute it - -type KindRep = TypeRep +data TypeRep (a :: k) where + TrTyCon :: {-# UNPACK #-} !Fingerprint -> !TyCon -> [SomeTypeRep] + -> TypeRep (a :: k) + TrApp :: forall k1 k2 (a :: k1 -> k2) (b :: k1). + {-# UNPACK #-} !Fingerprint + -> TypeRep (a :: k1 -> k2) + -> TypeRep (b :: k1) + -> TypeRep (a b) + TrFun :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep) + (a :: TYPE r1) (b :: TYPE r2). + {-# UNPACK #-} !Fingerprint + -> TypeRep a + -> TypeRep b + -> TypeRep (a -> b) + +on :: (a -> a -> r) -> (b -> a) -> (b -> b -> r) +on f g = \ x y -> g x `f` g y -- Compare keys for equality + -- | @since 2.01 -instance Eq TypeRep where - TypeRep x _ _ _ == TypeRep y _ _ _ = x == y +instance Eq (TypeRep a) where + _ == _ = True + {-# INLINABLE (==) #-} + +instance TestEquality TypeRep where + a `testEquality` b + | Just HRefl <- eqTypeRep a b + = Just Refl + | otherwise + = Nothing + {-# INLINEABLE testEquality #-} -- | @since 4.4.0.0 -instance Ord TypeRep where - TypeRep x _ _ _ <= TypeRep y _ _ _ = x <= y +instance Ord (TypeRep a) where + compare = compare `on` typeRepFingerprint + +-- | A non-indexed type representation. +data SomeTypeRep where + SomeTypeRep :: forall k (a :: k). TypeRep a -> SomeTypeRep + +instance Eq SomeTypeRep where + SomeTypeRep a == SomeTypeRep b = + case a `eqTypeRep` b of + Just _ -> True + Nothing -> False + +instance Ord SomeTypeRep where + SomeTypeRep a `compare` SomeTypeRep b = + typeRepFingerprint a `compare` typeRepFingerprint b + +pattern Fun :: forall k (fun :: k). () + => forall (r1 :: RuntimeRep) (r2 :: RuntimeRep) + (arg :: TYPE r1) (res :: TYPE r2). + (k ~ Type, fun ~~ (arg -> res)) + => TypeRep arg + -> TypeRep res + -> TypeRep fun +pattern Fun arg res <- TrFun _ arg res + where Fun arg res = mkTrFun arg res -- | Observe the 'Fingerprint' of a type representation -- -- @since 4.8.0.0 -typeRepFingerprint :: TypeRep -> Fingerprint -typeRepFingerprint (TypeRep fpr _ _ _) = fpr - --- | Applies a kind-polymorphic type constructor to a sequence of kinds and --- types -mkPolyTyConApp :: TyCon -> [KindRep] -> [TypeRep] -> TypeRep -{-# INLINE mkPolyTyConApp #-} -mkPolyTyConApp tc kinds types - = TypeRep (fingerprintFingerprints sub_fps) tc kinds types +typeRepFingerprint :: TypeRep a -> Fingerprint +typeRepFingerprint (TrTyCon fpr _ _) = fpr +typeRepFingerprint (TrApp fpr _ _) = fpr +typeRepFingerprint (TrFun fpr _ _) = fpr + +-- | Construct a representation for a type constructor +-- applied at a monomorphic kind. +-- +-- Note that this is unsafe as it allows you to construct +-- ill-kinded types. +mkTrCon :: forall k (a :: k). TyCon -> [SomeTypeRep] -> TypeRep a +mkTrCon tc kind_vars = TrTyCon fpr tc kind_vars where - !kt_fps = typeRepFingerprints kinds types - sub_fps = tyConFingerprint tc : kt_fps + fpr_tc = tyConFingerprint tc + fpr_kvs = map typeRepXFingerprint kind_vars + fpr = fingerprintFingerprints (fpr_tc:fpr_kvs) -typeRepFingerprints :: [KindRep] -> [TypeRep] -> [Fingerprint] --- Builds no thunks -typeRepFingerprints kinds types - = go1 [] kinds +-- | Construct a representation for a type application. +-- +-- Note that this is known-key to the compiler, which uses it in desugar +-- 'Typeable' evidence. +mkTrApp :: forall k1 k2 (a :: k1 -> k2) (b :: k1). + TypeRep (a :: k1 -> k2) + -> TypeRep (b :: k1) + -> TypeRep (a b) +mkTrApp a b = TrApp fpr a b where - go1 acc [] = go2 acc types - go1 acc (k:ks) = let !fp = typeRepFingerprint k - in go1 (fp:acc) ks - go2 acc [] = acc - go2 acc (t:ts) = let !fp = typeRepFingerprint t - in go2 (fp:acc) ts - --- | Applies a kind-monomorphic type constructor to a sequence of types -mkTyConApp :: TyCon -> [TypeRep] -> TypeRep -mkTyConApp tc = mkPolyTyConApp tc [] - --- | A special case of 'mkTyConApp', which applies the function --- type constructor to a pair of types. -mkFunTy :: TypeRep -> TypeRep -> TypeRep -mkFunTy f a = mkTyConApp tcFun [f,a] - --- | Splits a type constructor application. --- Note that if the type constructor is polymorphic, this will --- not return the kinds that were used. --- See 'splitPolyTyConApp' if you need all parts. -splitTyConApp :: TypeRep -> (TyCon,[TypeRep]) -splitTyConApp (TypeRep _ tc _ trs) = (tc,trs) - --- | Split a type constructor application -splitPolyTyConApp :: TypeRep -> (TyCon,[KindRep],[TypeRep]) -splitPolyTyConApp (TypeRep _ tc ks trs) = (tc,ks,trs) - --- | Applies a type to a function type. Returns: @'Just' u@ if the --- first argument represents a function of type @t -> u@ and the --- second argument represents a function of type @t@. Otherwise, --- returns 'Nothing'. -funResultTy :: TypeRep -> TypeRep -> Maybe TypeRep -funResultTy trFun trArg - = case splitTyConApp trFun of - (tc, [t1,t2]) | tc == tcFun && t1 == trArg -> Just t2 - _ -> Nothing - -tyConOf :: Typeable a => Proxy a -> TyCon -tyConOf = typeRepTyCon . typeRep - -tcFun :: TyCon -tcFun = tyConOf (Proxy :: Proxy (Int -> Int)) - --- | Adds a TypeRep argument to a TypeRep. -mkAppTy :: TypeRep -> TypeRep -> TypeRep -{-# INLINE mkAppTy #-} -mkAppTy (TypeRep _ tc ks trs) arg_tr = mkPolyTyConApp tc ks (trs ++ [arg_tr]) - -- Notice that we call mkTyConApp to construct the fingerprint from tc and - -- the arg fingerprints. Simply combining the current fingerprint with - -- the new one won't give the same answer, but of course we want to - -- ensure that a TypeRep of the same shape has the same fingerprint! - -- See Trac #5962 + fpr_a = typeRepFingerprint a + fpr_b = typeRepFingerprint b + fpr = fingerprintFingerprints [fpr_a, fpr_b] + +-- | Pattern match on a type application +pattern App :: forall k2 (t :: k2). () + => forall k1 (a :: k1 -> k2) (b :: k1). (t ~ a b) + => TypeRep a -> TypeRep b -> TypeRep t +pattern App f x <- TrApp _ f x + where App f x = mkTrApp f x + +-- | Use a 'TypeRep' as 'Typeable' evidence. +withTypeable :: forall a r. TypeRep a -> (Typeable a => r) -> r +withTypeable rep k = unsafeCoerce k' rep + where k' :: Gift a r + k' = Gift k + +-- | A helper to satisfy the type checker in 'withTypeable'. +newtype Gift a r = Gift (Typeable a => r) + +-- | Pattern match on a type constructor +pattern Con :: forall k (a :: k). TyCon -> TypeRep a +pattern Con con <- TrTyCon _ con _ + +-- | Pattern match on a type constructor including its instantiated kind +-- variables. +pattern Con' :: forall k (a :: k). TyCon -> [SomeTypeRep] -> TypeRep a +pattern Con' con ks <- TrTyCon _ con ks ----------------- Observation --------------------- +-- | Observe the type constructor of a quantified type representation. +typeRepXTyCon :: SomeTypeRep -> TyCon +typeRepXTyCon (SomeTypeRep t) = typeRepTyCon t + -- | Observe the type constructor of a type representation -typeRepTyCon :: TypeRep -> TyCon -typeRepTyCon (TypeRep _ tc _ _) = tc +typeRepTyCon :: TypeRep a -> TyCon +typeRepTyCon (TrTyCon _ tc _) = tc +typeRepTyCon (TrApp _ a _) = typeRepTyCon a +typeRepTyCon (TrFun _ _ _) = error "typeRepTyCon: FunTy" -- TODO --- | Observe the argument types of a type representation -typeRepArgs :: TypeRep -> [TypeRep] -typeRepArgs (TypeRep _ _ _ tys) = tys +-- | Type equality +-- +-- @since TODO +eqTypeRep :: forall k1 k2 (a :: k1) (b :: k2). + TypeRep a -> TypeRep b -> Maybe (a :~~: b) +eqTypeRep a b + | typeRepFingerprint a == typeRepFingerprint b = Just (unsafeCoerce# HRefl) + | otherwise = Nothing --- | Observe the argument kinds of a type representation -typeRepKinds :: TypeRep -> [KindRep] -typeRepKinds (TypeRep _ _ ks _) = ks +------------------------------------------------------------- +-- +-- Computing kinds +-- +------------------------------------------------------------- -{- ********************************************************************* -* * - The Typeable class -* * -********************************************************************* -} +-- | Observe the kind of a type. +typeRepKind :: TypeRep (a :: k) -> TypeRep k +typeRepKind (TrTyCon _ tc args) + = unsafeCoerceRep $ tyConKind tc args +typeRepKind (TrApp _ f _) + | Fun _ res <- typeRepKind f + = res + | otherwise + = error ("Ill-kinded type application: " ++ show (typeRepKind f)) +typeRepKind (TrFun _ _ _) = typeRep @Type + +tyConKind :: TyCon -> [SomeTypeRep] -> SomeTypeRep +tyConKind (TyCon _ _ _ _ nKindVars# kindRep) kindVars = + let kindVarsArr :: A.Array KindBndr SomeTypeRep + kindVarsArr = A.listArray (0, I# (nKindVars# -# 1#)) kindVars + in instantiateKindRep kindVarsArr kindRep + +instantiateKindRep :: A.Array KindBndr SomeTypeRep -> KindRep -> SomeTypeRep +instantiateKindRep vars = go + where + go :: KindRep -> SomeTypeRep + go (KindRepTyConApp tc args) + = let n_kind_args = tyConKindArgs tc + (kind_args, ty_args) = splitAt n_kind_args args + -- First instantiate tycon kind arguments + tycon_app = SomeTypeRep $ mkTrCon tc (map go kind_args) + -- Then apply remaining type arguments + applyTy :: SomeTypeRep -> KindRep -> SomeTypeRep + applyTy (SomeTypeRep acc) ty + | SomeTypeRep ty' <- go ty + = SomeTypeRep $ mkTrApp (unsafeCoerce acc) (unsafeCoerce ty') + in foldl applyTy tycon_app ty_args + go (KindRepVar var) + = vars A.! var + go (KindRepApp f a) + = SomeTypeRep $ App (unsafeCoerceRep $ go f) (unsafeCoerceRep $ go a) + go (KindRepFun a b) + = SomeTypeRep $ Fun (unsafeCoerceRep $ go a) (unsafeCoerceRep $ go b) + go (KindRepTYPE r) = unkindedTypeRep $ tYPE `kApp` runtimeRepTypeRep r + go (KindRepTypeLitS sort s) + = mkTypeLitFromString sort (unpackCString# s) + go (KindRepTypeLitD sort s) + = mkTypeLitFromString sort s + + tYPE = kindedTypeRep @(RuntimeRep -> Type) @TYPE + +unsafeCoerceRep :: SomeTypeRep -> TypeRep a +unsafeCoerceRep (SomeTypeRep r) = unsafeCoerce r + +unkindedTypeRep :: SomeKindedTypeRep k -> SomeTypeRep +unkindedTypeRep (SomeKindedTypeRep x) = SomeTypeRep x + +data SomeKindedTypeRep k where + SomeKindedTypeRep :: forall (a :: k). TypeRep a + -> SomeKindedTypeRep k + +kApp :: SomeKindedTypeRep (k -> k') + -> SomeKindedTypeRep k + -> SomeKindedTypeRep k' +kApp (SomeKindedTypeRep f) (SomeKindedTypeRep a) = + SomeKindedTypeRep (App f a) + +kindedTypeRep :: forall (a :: k). Typeable a => SomeKindedTypeRep k +kindedTypeRep = SomeKindedTypeRep (typeRep @a) + +buildList :: forall k. Typeable k + => [SomeKindedTypeRep k] + -> SomeKindedTypeRep [k] +buildList = foldr cons nil + where + nil = kindedTypeRep @[k] @'[] + cons x rest = SomeKindedTypeRep (typeRep @'(:)) `kApp` x `kApp` rest + +runtimeRepTypeRep :: RuntimeRep -> SomeKindedTypeRep RuntimeRep +runtimeRepTypeRep r = + case r of + LiftedRep -> rep @'LiftedRep + UnliftedRep -> rep @'UnliftedRep + VecRep c e -> kindedTypeRep @_ @'VecRep + `kApp` vecCountTypeRep c + `kApp` vecElemTypeRep e + TupleRep rs -> kindedTypeRep @_ @'TupleRep + `kApp` buildList (map runtimeRepTypeRep rs) + SumRep rs -> kindedTypeRep @_ @'SumRep + `kApp` buildList (map runtimeRepTypeRep rs) + IntRep -> rep @'IntRep + WordRep -> rep @'WordRep + Int64Rep -> rep @'Int64Rep + Word64Rep -> rep @'Word64Rep + AddrRep -> rep @'AddrRep + FloatRep -> rep @'FloatRep + DoubleRep -> rep @'DoubleRep + where + rep :: forall (a :: RuntimeRep). Typeable a => SomeKindedTypeRep RuntimeRep + rep = kindedTypeRep @RuntimeRep @a + +vecCountTypeRep :: VecCount -> SomeKindedTypeRep VecCount +vecCountTypeRep c = + case c of + Vec2 -> rep @'Vec2 + Vec4 -> rep @'Vec4 + Vec8 -> rep @'Vec8 + Vec16 -> rep @'Vec16 + Vec32 -> rep @'Vec32 + Vec64 -> rep @'Vec64 + where + rep :: forall (a :: VecCount). Typeable a => SomeKindedTypeRep VecCount + rep = kindedTypeRep @VecCount @a + +vecElemTypeRep :: VecElem -> SomeKindedTypeRep VecElem +vecElemTypeRep e = + case e of + Int8ElemRep -> rep @'Int8ElemRep + Int16ElemRep -> rep @'Int16ElemRep + Int32ElemRep -> rep @'Int32ElemRep + Int64ElemRep -> rep @'Int64ElemRep + Word8ElemRep -> rep @'Word8ElemRep + Word16ElemRep -> rep @'Word16ElemRep + Word32ElemRep -> rep @'Word32ElemRep + Word64ElemRep -> rep @'Word64ElemRep + FloatElemRep -> rep @'FloatElemRep + DoubleElemRep -> rep @'DoubleElemRep + where + rep :: forall (a :: VecElem). Typeable a => SomeKindedTypeRep VecElem + rep = kindedTypeRep @VecElem @a ------------------------------------------------------------- -- @@ -286,115 +452,103 @@ typeRepKinds (TypeRep _ _ ks _) = ks -- | The class 'Typeable' allows a concrete representation of a type to -- be calculated. -class Typeable a where - typeRep# :: Proxy# a -> TypeRep +class Typeable (a :: k) where + typeRep# :: TypeRep a + +typeRep :: Typeable a => TypeRep a +typeRep = typeRep# + +typeOf :: Typeable a => a -> TypeRep a +typeOf _ = typeRep -- | Takes a value of type @a@ and returns a concrete representation -- of that type. -- -- @since 4.7.0.0 -typeRep :: forall proxy a. Typeable a => proxy a -> TypeRep -typeRep _ = typeRep# (proxy# :: Proxy# a) +typeRepX :: forall proxy a. Typeable a => proxy a -> SomeTypeRep +typeRepX _ = SomeTypeRep (typeRep :: TypeRep a) {-# INLINE typeRep #-} --- Keeping backwards-compatibility -typeOf :: forall a. Typeable a => a -> TypeRep -typeOf _ = typeRep (Proxy :: Proxy a) - -typeOf1 :: forall t (a :: *). Typeable t => t a -> TypeRep -typeOf1 _ = typeRep (Proxy :: Proxy t) - -typeOf2 :: forall t (a :: *) (b :: *). Typeable t => t a b -> TypeRep -typeOf2 _ = typeRep (Proxy :: Proxy t) - -typeOf3 :: forall t (a :: *) (b :: *) (c :: *). Typeable t - => t a b c -> TypeRep -typeOf3 _ = typeRep (Proxy :: Proxy t) - -typeOf4 :: forall t (a :: *) (b :: *) (c :: *) (d :: *). Typeable t - => t a b c d -> TypeRep -typeOf4 _ = typeRep (Proxy :: Proxy t) - -typeOf5 :: forall t (a :: *) (b :: *) (c :: *) (d :: *) (e :: *). Typeable t - => t a b c d e -> TypeRep -typeOf5 _ = typeRep (Proxy :: Proxy t) - -typeOf6 :: forall t (a :: *) (b :: *) (c :: *) (d :: *) (e :: *) (f :: *). - Typeable t => t a b c d e f -> TypeRep -typeOf6 _ = typeRep (Proxy :: Proxy t) - -typeOf7 :: forall t (a :: *) (b :: *) (c :: *) (d :: *) (e :: *) (f :: *) - (g :: *). Typeable t => t a b c d e f g -> TypeRep -typeOf7 _ = typeRep (Proxy :: Proxy t) - -type Typeable1 (a :: * -> *) = Typeable a -type Typeable2 (a :: * -> * -> *) = Typeable a -type Typeable3 (a :: * -> * -> * -> *) = Typeable a -type Typeable4 (a :: * -> * -> * -> * -> *) = Typeable a -type Typeable5 (a :: * -> * -> * -> * -> * -> *) = Typeable a -type Typeable6 (a :: * -> * -> * -> * -> * -> * -> *) = Typeable a -type Typeable7 (a :: * -> * -> * -> * -> * -> * -> * -> *) = Typeable a - -{-# DEPRECATED Typeable1 "renamed to 'Typeable'" #-} -- deprecated in 7.8 -{-# DEPRECATED Typeable2 "renamed to 'Typeable'" #-} -- deprecated in 7.8 -{-# DEPRECATED Typeable3 "renamed to 'Typeable'" #-} -- deprecated in 7.8 -{-# DEPRECATED Typeable4 "renamed to 'Typeable'" #-} -- deprecated in 7.8 -{-# DEPRECATED Typeable5 "renamed to 'Typeable'" #-} -- deprecated in 7.8 -{-# DEPRECATED Typeable6 "renamed to 'Typeable'" #-} -- deprecated in 7.8 -{-# DEPRECATED Typeable7 "renamed to 'Typeable'" #-} -- deprecated in 7.8 - +typeRepXFingerprint :: SomeTypeRep -> Fingerprint +typeRepXFingerprint (SomeTypeRep t) = typeRepFingerprint t ----------------- Showing TypeReps -------------------- --- | @since 2.01 -instance Show TypeRep where - showsPrec p (TypeRep _ tycon kinds tys) = - case tys of - [] -> showsPrec p tycon - [x] - | tycon == tcList -> showChar '[' . shows x . showChar ']' - where - tcList = tyConOf @[] Proxy - [TypeRep _ ptrRepCon _ []] - | tycon == tcTYPE && ptrRepCon == tc'LiftedRep - -> showChar '*' - where - tcTYPE = tyConOf @TYPE Proxy - tc'LiftedRep = tyConOf @'LiftedRep Proxy - [a,r] | tycon == tcFun -> showParen (p > 8) $ - showsPrec 9 a . - showString " -> " . - showsPrec 8 r - xs | isTupleTyCon tycon -> showTuple xs - | otherwise -> - showParen (p > 9) $ - showsPrec p tycon . - showChar ' ' . - showArgs (showChar ' ') (kinds ++ tys) - -showsTypeRep :: TypeRep -> ShowS -showsTypeRep = shows - --- | Helper to fully evaluate 'TypeRep' for use as @NFData(rnf)@ implementation --- --- @since 4.8.0.0 -rnfTypeRep :: TypeRep -> () -rnfTypeRep (TypeRep _ tyc krs tyrs) = rnfTyCon tyc `seq` go krs `seq` go tyrs +-- This follows roughly the precedence structure described in Note [Precedence +-- in types]. +instance Show (TypeRep (a :: k)) where + showsPrec = showTypeable + + +showTypeable :: Int -> TypeRep (a :: k) -> ShowS +showTypeable _ rep + | Just HRefl <- rep `eqTypeRep` (typeRep :: TypeRep Type) = + showChar '*' + | isListTyCon tc, [ty] <- tys = + showChar '[' . shows ty . showChar ']' + | isTupleTyCon tc = + showChar '(' . showArgs (showChar ',') tys . showChar ')' + where (tc, tys) = splitApps rep +showTypeable p (TrTyCon _ tycon []) + = showsPrec p tycon +showTypeable p (TrTyCon _ tycon args) + = showParen (p > 9) $ + showsPrec p tycon . + showChar ' ' . + showArgs (showChar ' ') args +showTypeable p (TrFun _ x r) + = showParen (p > 8) $ + showsPrec 9 x . showString " -> " . showsPrec 8 r +showTypeable p (TrApp _ f x) + = showParen (p > 9) $ + showsPrec 8 f . + showChar ' ' . + showsPrec 10 x + +-- | @since 4.10.0.0 +instance Show SomeTypeRep where + showsPrec p (SomeTypeRep ty) = showsPrec p ty + +splitApps :: TypeRep a -> (TyCon, [SomeTypeRep]) +splitApps = go [] where - go [] = () - go (x:xs) = rnfTypeRep x `seq` go xs + go :: [SomeTypeRep] -> TypeRep a -> (TyCon, [SomeTypeRep]) + go xs (TrTyCon _ tc _) = (tc, xs) + go xs (TrApp _ f x) = go (SomeTypeRep x : xs) f + go [] (TrFun _ a b) = (funTyCon, [SomeTypeRep a, SomeTypeRep b]) + go _ (TrFun _ _ _) = + error "Data.Typeable.Internal.splitApps: Impossible" + +funTyCon :: TyCon +funTyCon = typeRepTyCon (typeRep @(->)) + +isListTyCon :: TyCon -> Bool +isListTyCon tc = tc == typeRepTyCon (typeRep :: TypeRep [Int]) --- Some (Show.TypeRep) helpers: +isTupleTyCon :: TyCon -> Bool +isTupleTyCon tc + | ('(':',':_) <- tyConName tc = True + | otherwise = False showArgs :: Show a => ShowS -> [a] -> ShowS showArgs _ [] = id showArgs _ [a] = showsPrec 10 a showArgs sep (a:as) = showsPrec 10 a . sep . showArgs sep as -showTuple :: [TypeRep] -> ShowS -showTuple args = showChar '(' - . showArgs (showChar ',') args - . showChar ')' +-- | Helper to fully evaluate 'TypeRep' for use as @NFData(rnf)@ implementation +-- +-- @since 4.8.0.0 +rnfTypeRep :: TypeRep a -> () +rnfTypeRep (TrTyCon _ tyc _) = rnfTyCon tyc +rnfTypeRep (TrApp _ f x) = rnfTypeRep f `seq` rnfTypeRep x +rnfTypeRep (TrFun _ x y) = rnfTypeRep x `seq` rnfTypeRep y + +-- | Helper to fully evaluate 'SomeTypeRep' for use as @NFData(rnf)@ +-- implementation +-- +-- @since 4.10.0.0 +rnfSomeTypeRep :: SomeTypeRep -> () +rnfSomeTypeRep (SomeTypeRep r) = rnfTypeRep r {- ********************************************************* * * @@ -403,18 +557,102 @@ showTuple args = showChar '(' * * ********************************************************* -} - -mkTypeLitTyCon :: String -> TyCon -mkTypeLitTyCon name = mkTyCon3 "base" "GHC.TypeLits" name +pattern KindRepTypeLit :: TypeLitSort -> String -> KindRep +pattern KindRepTypeLit sort t <- (getKindRepTypeLit -> Just (sort, t)) + where + KindRepTypeLit sort t = KindRepTypeLitD sort t + +{-# COMPLETE KindRepTyConApp, KindRepVar, KindRepApp, KindRepFun, + KindRepTYPE, KindRepTypeLit #-} + +getKindRepTypeLit :: KindRep -> Maybe (TypeLitSort, String) +getKindRepTypeLit (KindRepTypeLitS sort t) = Just (sort, unpackCString# t) +getKindRepTypeLit (KindRepTypeLitD sort t) = Just (sort, t) +getKindRepTypeLit _ = Nothing + +-- | Exquisitely unsafe. +mkTyCon# :: Addr# -- ^ package name + -> Addr# -- ^ module name + -> Addr# -- ^ the name of the type constructor + -> Int# -- ^ number of kind variables + -> KindRep -- ^ kind representation + -> TyCon -- ^ A unique 'TyCon' object +mkTyCon# pkg modl name n_kinds kind_rep + | Fingerprint (W64# hi) (W64# lo) <- fingerprint + = TyCon hi lo mod (TrNameS name) n_kinds kind_rep + where + mod = Module (TrNameS pkg) (TrNameS modl) + fingerprint :: Fingerprint + fingerprint = mkTyConFingerprint (unpackCString# pkg) + (unpackCString# modl) + (unpackCString# name) + +-- it is extremely important that this fingerprint computation +-- remains in sync with that in TcTypeable to ensure that type +-- equality is correct. + +-- | Exquisitely unsafe. +mkTyCon :: String -- ^ package name + -> String -- ^ module name + -> String -- ^ the name of the type constructor + -> Int -- ^ number of kind variables + -> KindRep -- ^ kind representation + -> TyCon -- ^ A unique 'TyCon' object +-- Used when the strings are dynamically allocated, +-- eg from binary deserialisation +mkTyCon pkg modl name (I# n_kinds) kind_rep + | Fingerprint (W64# hi) (W64# lo) <- fingerprint + = TyCon hi lo mod (TrNameD name) n_kinds kind_rep + where + mod = Module (TrNameD pkg) (TrNameD modl) + fingerprint :: Fingerprint + fingerprint = mkTyConFingerprint pkg modl name + +-- This must match the computation done in TcTypeable.mkTyConRepTyConRHS. +mkTyConFingerprint :: String -- ^ package name + -> String -- ^ module name + -> String -- ^ tycon name + -> Fingerprint +mkTyConFingerprint pkg_name mod_name tycon_name = + fingerprintFingerprints + [ fingerprintString pkg_name + , fingerprintString mod_name + , fingerprintString tycon_name + ] + +mkTypeLitTyCon :: String -> TyCon -> TyCon +mkTypeLitTyCon name kind_tycon + = mkTyCon "base" "GHC.TypeLits" name 0 kind + where kind = KindRepTyConApp kind_tycon [] -- | Used to make `'Typeable' instance for things of kind Nat -typeNatTypeRep :: KnownNat a => Proxy# a -> TypeRep -typeNatTypeRep p = typeLitTypeRep (show (natVal' p)) +typeNatTypeRep :: KnownNat a => Proxy# a -> TypeRep a +typeNatTypeRep p = typeLitTypeRep (show (natVal' p)) tcNat -- | Used to make `'Typeable' instance for things of kind Symbol -typeSymbolTypeRep :: KnownSymbol a => Proxy# a -> TypeRep -typeSymbolTypeRep p = typeLitTypeRep (show (symbolVal' p)) +typeSymbolTypeRep :: KnownSymbol a => Proxy# a -> TypeRep a +typeSymbolTypeRep p = typeLitTypeRep (show (symbolVal' p)) tcSymbol + +mkTypeLitFromString :: TypeLitSort -> String -> SomeTypeRep +mkTypeLitFromString TypeLitSymbol s = + SomeTypeRep $ (typeLitTypeRep s tcSymbol :: TypeRep Symbol) +mkTypeLitFromString TypeLitNat s = + SomeTypeRep $ (typeLitTypeRep s tcSymbol :: TypeRep Nat) + +tcSymbol :: TyCon +tcSymbol = typeRepTyCon (typeRep @Symbol) + +tcNat :: TyCon +tcNat = typeRepTyCon (typeRep @Nat) -- | An internal function, to make representations for type literals. -typeLitTypeRep :: String -> TypeRep -typeLitTypeRep nm = mkTyConApp (mkTypeLitTyCon nm) [] +typeLitTypeRep :: forall (a :: k). (Typeable k) => String -> TyCon -> TypeRep a +typeLitTypeRep nm kind_tycon = mkTrCon (mkTypeLitTyCon nm kind_tycon) [] + +-- | For compiler use. +mkTrFun :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep) + (a :: TYPE r1) (b :: TYPE r2). + TypeRep a -> TypeRep b -> TypeRep ((a -> b) :: Type) +mkTrFun arg res = TrFun fpr arg res + where fpr = fingerprintFingerprints [ typeRepFingerprint arg + , typeRepFingerprint res] diff --git a/libraries/base/GHC/Conc/Sync.hs b/libraries/base/GHC/Conc/Sync.hs index a9629c41bb..e8823e55f0 100644 --- a/libraries/base/GHC/Conc/Sync.hs +++ b/libraries/base/GHC/Conc/Sync.hs @@ -99,11 +99,7 @@ module GHC.Conc.Sync import Foreign import Foreign.C -#ifndef mingw32_HOST_OS -import Data.Dynamic -#else import Data.Typeable -#endif import Data.Maybe import GHC.Base diff --git a/libraries/base/GHC/Show.hs b/libraries/base/GHC/Show.hs index 46fc8fe307..510c655a11 100644 --- a/libraries/base/GHC/Show.hs +++ b/libraries/base/GHC/Show.hs @@ -1,6 +1,6 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE CPP, NoImplicitPrelude, BangPatterns, StandaloneDeriving, - MagicHash, UnboxedTuples #-} + MagicHash, UnboxedTuples, PolyKinds #-} {-# OPTIONS_HADDOCK hide #-} #include "MachDeps.h" @@ -201,7 +201,7 @@ deriving instance Show a => Show (Maybe a) -- | @since 2.01 instance Show TyCon where - showsPrec p (TyCon _ _ _ tc_name) = showsPrec p tc_name + showsPrec p (TyCon _ _ _ tc_name _ _) = showsPrec p tc_name -- | @since 4.9.0.0 instance Show TrName where diff --git a/libraries/base/Type/Reflection.hs b/libraries/base/Type/Reflection.hs new file mode 100644 index 0000000000..37efcba489 --- /dev/null +++ b/libraries/base/Type/Reflection.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE PatternSynonyms #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Type.Reflection +-- Copyright : (c) The University of Glasgow, CWI 2001--2017 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable (requires GADTs and compiler support) +-- +-- This provides a type-indexed type representation mechanism, similar to that +-- described by, +-- +-- * Simon Peyton-Jones, Stephanie Weirich, Richard Eisenberg, +-- Dimitrios Vytiniotis. "A reflection on types." /Proc. Philip Wadler's 60th +-- birthday Festschrift/, Edinburgh (April 2016). +-- +-- The interface provides 'TypeRep', a type representation which can +-- be safely decomposed and composed. See "Data.Dynamic" for an example of this. +-- +-- @since 4.10.0.0 +-- +----------------------------------------------------------------------------- +module Type.Reflection + ( -- * The Typeable class + I.Typeable + , I.typeRep + , I.withTypeable + + -- * Propositional equality + , (:~:)(Refl) + , (:~~:)(HRefl) + + -- * Type representations + -- ** Type-Indexed + , I.TypeRep + , I.typeOf + , pattern I.App, pattern I.Con, pattern I.Con', pattern I.Fun + , I.typeRepFingerprint + , I.typeRepTyCon + , I.rnfTypeRep + , I.eqTypeRep + , I.typeRepKind + + -- ** Quantified + -- + -- "Data.Typeable" exports a variant of this interface (named differently + -- for backwards compatibility). + , I.SomeTypeRep(..) + , I.typeRepXTyCon + , I.rnfSomeTypeRep + + -- * Type constructors + , I.TyCon -- abstract, instance of: Eq, Show, Typeable + -- For now don't export Module, to avoid name clashes + , I.tyConPackage + , I.tyConModule + , I.tyConName + , I.rnfTyCon + ) where + +import qualified Data.Typeable.Internal as I +import Data.Type.Equality diff --git a/libraries/base/Type/Reflection/Unsafe.hs b/libraries/base/Type/Reflection/Unsafe.hs new file mode 100644 index 0000000000..4e367f5722 --- /dev/null +++ b/libraries/base/Type/Reflection/Unsafe.hs @@ -0,0 +1,22 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Type.Reflection.Unsafe +-- Copyright : (c) The University of Glasgow, CWI 2001--2015 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- The representations of the types TyCon and TypeRep, and the +-- function mkTyCon which is used by derived instances of Typeable to +-- construct a TyCon. +-- +-- Be warned, these functions can be used to construct ill-typed +-- type representations. +-- +----------------------------------------------------------------------------- + +module Type.Reflection.Unsafe ( + tyConKindRep, tyConKindArgs, + KindRep(..), TypeLitSort(..), + mkTrCon, mkTrApp, mkTyCon + ) where + +import Data.Typeable.Internal diff --git a/libraries/base/base.cabal b/libraries/base/base.cabal index 49e23e5c97..2649173a41 100644 --- a/libraries/base/base.cabal +++ b/libraries/base/base.cabal @@ -174,7 +174,6 @@ Library Data.Type.Coercion Data.Type.Equality Data.Typeable - Data.Typeable.Internal Data.Unique Data.Version Data.Void @@ -306,6 +305,8 @@ Library Text.Read.Lex Text.Show Text.Show.Functions + Type.Reflection + Type.Reflection.Unsafe Unsafe.Coerce other-modules: @@ -313,6 +314,7 @@ Library Control.Monad.ST.Lazy.Imp Data.Functor.Utils Data.OldList + Data.Typeable.Internal Foreign.ForeignPtr.Imp GHC.StaticPtr.Internal System.Environment.ExecutablePath diff --git a/libraries/base/changelog.md b/libraries/base/changelog.md index aa7302db0b..fd8f188628 100644 --- a/libraries/base/changelog.md +++ b/libraries/base/changelog.md @@ -56,6 +56,15 @@ imported from `Control.Applicative`. It is likely to be added to the `Prelude` in the future. (#13191) + * A new module exposing GHC's new type-indexed type representation + mechanism, `Type.Reflection`, is now provided. + + * `Data.Dynamic` now exports the `Dyn` data constructor, enabled by the new + type-indexed type representation mechanism. + + * `Data.Type.Equality` now provides a kind heterogeneous type equality type, + `(:~~:)`. + ## 4.9.0.0 *May 2016* * Bundled with GHC 8.0 diff --git a/libraries/base/tests/T11334a.stdout b/libraries/base/tests/T11334a.stdout index caeb85bf44..c2d860d653 100644 --- a/libraries/base/tests/T11334a.stdout +++ b/libraries/base/tests/T11334a.stdout @@ -1,3 +1,3 @@ -Proxy (* -> Maybe *) 'Just +Proxy (* -> Maybe *) ('Just *) Proxy * * Proxy * (TYPE 'UnliftedRep) diff --git a/libraries/base/tests/all.T b/libraries/base/tests/all.T index 8e5125fc3b..7125b636f8 100644 --- a/libraries/base/tests/all.T +++ b/libraries/base/tests/all.T @@ -119,7 +119,7 @@ test('T2528', normal, compile_and_run, ['']) test('T4006', normal, compile_and_run, ['']) test('T5943', normal, compile_and_run, ['']) -test('T5962', expect_broken(10343), compile_and_run, ['']) +test('T5962', normal, compile_and_run, ['']) test('T7034', normal, compile_and_run, ['']) test('qsem001', normal, compile_and_run, ['']) diff --git a/libraries/base/tests/dynamic002.hs b/libraries/base/tests/dynamic002.hs index 6d53d2ed1e..3904b45cb7 100644 --- a/libraries/base/tests/dynamic002.hs +++ b/libraries/base/tests/dynamic002.hs @@ -1,7 +1,12 @@ +{-# LANGUAGE CPP #-} + -- !!! Testing Typeable instances module Main(main) where import Data.Dynamic +#if MIN_VERSION_base(4,10,0) +import Data.Typeable (TyCon, TypeRep, typeOf) +#endif import Data.Array import Data.Array.MArray import Data.Array.ST diff --git a/libraries/base/tests/dynamic002.stdout b/libraries/base/tests/dynamic002.stdout index 8b55566ada..24266824fb 100644 --- a/libraries/base/tests/dynamic002.stdout +++ b/libraries/base/tests/dynamic002.stdout @@ -28,7 +28,7 @@ ST () () StableName () StablePtr () TyCon -TypeRep +SomeTypeRep Word8 Word16 Word32 diff --git a/libraries/base/tests/dynamic004.hs b/libraries/base/tests/dynamic004.hs index e6b7a82bfd..2091646736 100644 --- a/libraries/base/tests/dynamic004.hs +++ b/libraries/base/tests/dynamic004.hs @@ -1,7 +1,6 @@ module Main where import Data.Typeable -import Data.Typeable.Internal import GHC.Fingerprint import Text.Printf diff --git a/libraries/ghc-boot/GHC/Serialized.hs b/libraries/ghc-boot/GHC/Serialized.hs index fbb96849fb..42a9604c08 100644 --- a/libraries/ghc-boot/GHC/Serialized.hs +++ b/libraries/ghc-boot/GHC/Serialized.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes, ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} @@ -26,15 +28,24 @@ import Data.Data data Serialized = Serialized TypeRep [Word8] -- | Put a Typeable value that we are able to actually turn into bytes into a 'Serialized' value ready for deserialization later -toSerialized :: Typeable a => (a -> [Word8]) -> a -> Serialized -toSerialized serialize what = Serialized (typeOf what) (serialize what) +toSerialized :: forall a. Typeable a => (a -> [Word8]) -> a -> Serialized +toSerialized serialize what = Serialized rep (serialize what) + where + rep = typeOf what -- | If the 'Serialized' value contains something of the given type, then use the specified deserializer to return @Just@ that. -- Otherwise return @Nothing@. fromSerialized :: forall a. Typeable a => ([Word8] -> a) -> Serialized -> Maybe a +#if MIN_VERSION_base(4,10,0) +fromSerialized deserialize (Serialized the_type bytes) + | the_type == rep = Just (deserialize bytes) + | otherwise = Nothing + where rep = typeRep (Proxy :: Proxy a) +#else fromSerialized deserialize (Serialized the_type bytes) | the_type == typeOf (undefined :: a) = Just (deserialize bytes) | otherwise = Nothing +#endif -- | Use a 'Data' instance to implement a serialization scheme dual to that of 'deserializeWithData' serializeWithData :: Data a => a -> [Word8] diff --git a/libraries/ghc-prim/GHC/Classes.hs b/libraries/ghc-prim/GHC/Classes.hs index 5fa118a7f6..3fd4bc06b0 100644 --- a/libraries/ghc-prim/GHC/Classes.hs +++ b/libraries/ghc-prim/GHC/Classes.hs @@ -226,10 +226,10 @@ eqInt, neInt :: Int -> Int -> Bool #if WORD_SIZE_IN_BITS < 64 instance Eq TyCon where - (==) (TyCon hi1 lo1 _ _) (TyCon hi2 lo2 _ _) + (==) (TyCon hi1 lo1 _ _ _ _) (TyCon hi2 lo2 _ _ _ _) = isTrue# (hi1 `eqWord64#` hi2) && isTrue# (lo1 `eqWord64#` lo2) instance Ord TyCon where - compare (TyCon hi1 lo1 _ _) (TyCon hi2 lo2 _ _) + compare (TyCon hi1 lo1 _ _ _ _) (TyCon hi2 lo2 _ _ _ _) | isTrue# (hi1 `gtWord64#` hi2) = GT | isTrue# (hi1 `ltWord64#` hi2) = LT | isTrue# (lo1 `gtWord64#` lo2) = GT @@ -237,10 +237,10 @@ instance Ord TyCon where | True = EQ #else instance Eq TyCon where - (==) (TyCon hi1 lo1 _ _) (TyCon hi2 lo2 _ _) + (==) (TyCon hi1 lo1 _ _ _ _) (TyCon hi2 lo2 _ _ _ _) = isTrue# (hi1 `eqWord#` hi2) && isTrue# (lo1 `eqWord#` lo2) instance Ord TyCon where - compare (TyCon hi1 lo1 _ _) (TyCon hi2 lo2 _ _) + compare (TyCon hi1 lo1 _ _ _ _) (TyCon hi2 lo2 _ _ _ _) | isTrue# (hi1 `gtWord#` hi2) = GT | isTrue# (hi1 `ltWord#` hi2) = LT | isTrue# (lo1 `gtWord#` lo2) = GT diff --git a/libraries/ghc-prim/GHC/Types.hs b/libraries/ghc-prim/GHC/Types.hs index c913af6fdb..a4b7a91b59 100644 --- a/libraries/ghc-prim/GHC/Types.hs +++ b/libraries/ghc-prim/GHC/Types.hs @@ -39,17 +39,14 @@ module GHC.Types ( VecCount(..), VecElem(..), -- * Runtime type representation - Module(..), TrName(..), TyCon(..) + Module(..), TrName(..), TyCon(..), TypeLitSort(..), + KindRep(..), KindBndr ) where import GHC.Prim infixr 5 : --- Take note: All types defined here must have associated type representations --- defined in Data.Typeable.Internal. --- See Note [Representation of types defined in GHC.Types] below. - {- ********************************************************************* * * Kinds @@ -443,14 +440,31 @@ data TrName = TrNameS Addr# -- Static | TrNameD [Char] -- Dynamic +-- | A de Bruijn index for a binder within a 'KindRep'. +type KindBndr = Int + #if WORD_SIZE_IN_BITS < 64 -data TyCon = TyCon - Word64# Word64# -- Fingerprint - Module -- Module in which this is defined - TrName -- Type constructor name +#define WORD64_TY Word64# #else -data TyCon = TyCon - Word# Word# - Module - TrName +#define WORD64_TY Word# #endif + +-- | The representation produced by GHC for conjuring up the kind of a +-- 'TypeRep'. +data KindRep = KindRepTyConApp TyCon [KindRep] + | KindRepVar !KindBndr + | KindRepApp KindRep KindRep + | KindRepFun KindRep KindRep + | KindRepTYPE !RuntimeRep + | KindRepTypeLitS TypeLitSort Addr# + | KindRepTypeLitD TypeLitSort [Char] + +data TypeLitSort = TypeLitSymbol + | TypeLitNat + +-- Show instance for TyCon found in GHC.Show +data TyCon = TyCon WORD64_TY WORD64_TY -- Fingerprint + Module -- Module in which this is defined + TrName -- Type constructor name + Int# -- How many kind variables do we accept? + KindRep -- A representation of the type's kind diff --git a/libraries/ghci/GHCi/Message.hs b/libraries/ghci/GHCi/Message.hs index 71da2287bb..80a495f9f4 100644 --- a/libraries/ghci/GHCi/Message.hs +++ b/libraries/ghci/GHCi/Message.hs @@ -40,6 +40,10 @@ import Data.ByteString (ByteString) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as LB import Data.Dynamic +#if MIN_VERSION_base(4,10,0) +-- Previously this was re-exported by Data.Dynamic +import Data.Typeable (TypeRep) +#endif import Data.IORef import Data.Map (Map) import GHC.Generics @@ -380,7 +384,7 @@ fromSerializableException (EOtherException str) = toException (ErrorCall str) -- as the minimum instance Binary ExitCode where put ExitSuccess = putWord8 0 - put (ExitFailure ec) = putWord8 1 `mappend` put ec + put (ExitFailure ec) = putWord8 1 >> put ec get = do w <- getWord8 case w of diff --git a/libraries/ghci/GHCi/TH/Binary.hs b/libraries/ghci/GHCi/TH/Binary.hs index e93095662e..fcff168a9c 100644 --- a/libraries/ghci/GHCi/TH/Binary.hs +++ b/libraries/ghci/GHCi/TH/Binary.hs @@ -1,10 +1,23 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE GADTs #-} + -- This module is full of orphans, unfortunately module GHCi.TH.Binary () where import Data.Binary import qualified Data.ByteString as B +#if MIN_VERSION_base(4,10,0) +import Type.Reflection +import Type.Reflection.Unsafe +import Data.Kind (Type) +import GHC.Exts (RuntimeRep(..), VecCount, VecElem) +#else import Data.Typeable +#endif import GHC.Serialized import qualified Language.Haskell.TH as TH import qualified Language.Haskell.TH.Syntax as TH @@ -66,6 +79,163 @@ instance Binary TH.PatSynArgs -- We need Binary TypeRep for serializing annotations +#if MIN_VERSION_base(4,10,0) +instance Binary VecCount where + put = putWord8 . fromIntegral . fromEnum + get = toEnum . fromIntegral <$> getWord8 + +instance Binary VecElem where + put = putWord8 . fromIntegral . fromEnum + get = toEnum . fromIntegral <$> getWord8 + +instance Binary RuntimeRep where + put (VecRep a b) = putWord8 0 >> put a >> put b + put (TupleRep reps) = putWord8 1 >> put reps + put (SumRep reps) = putWord8 2 >> put reps + put LiftedRep = putWord8 3 + put UnliftedRep = putWord8 4 + put IntRep = putWord8 5 + put WordRep = putWord8 6 + put Int64Rep = putWord8 7 + put Word64Rep = putWord8 8 + put AddrRep = putWord8 9 + put FloatRep = putWord8 10 + put DoubleRep = putWord8 11 + + get = do + tag <- getWord8 + case tag of + 0 -> VecRep <$> get <*> get + 1 -> TupleRep <$> get + 2 -> SumRep <$> get + 3 -> pure LiftedRep + 4 -> pure UnliftedRep + 5 -> pure IntRep + 6 -> pure WordRep + 7 -> pure Int64Rep + 8 -> pure Word64Rep + 9 -> pure AddrRep + 10 -> pure FloatRep + 11 -> pure DoubleRep + _ -> fail "GHCi.TH.Binary.putRuntimeRep: invalid tag" + +instance Binary TyCon where + put tc = do + put (tyConPackage tc) + put (tyConModule tc) + put (tyConName tc) + put (tyConKindArgs tc) + put (tyConKindRep tc) + get = mkTyCon <$> get <*> get <*> get <*> get <*> get + +instance Binary KindRep where + put (KindRepTyConApp tc k) = putWord8 0 >> put tc >> put k + put (KindRepVar bndr) = putWord8 1 >> put bndr + put (KindRepApp a b) = putWord8 2 >> put a >> put b + put (KindRepFun a b) = putWord8 3 >> put a >> put b + put (KindRepTYPE r) = putWord8 4 >> put r + put (KindRepTypeLit sort r) = putWord8 5 >> put sort >> put r + put _ = fail "GHCi.TH.Binary.putKindRep: Impossible" + + get = do + tag <- getWord8 + case tag of + 0 -> KindRepTyConApp <$> get <*> get + 1 -> KindRepVar <$> get + 2 -> KindRepApp <$> get <*> get + 3 -> KindRepFun <$> get <*> get + 4 -> KindRepTYPE <$> get + 5 -> KindRepTypeLit <$> get <*> get + _ -> fail "GHCi.TH.Binary.putKindRep: invalid tag" + +instance Binary TypeLitSort where + put TypeLitSymbol = putWord8 0 + put TypeLitNat = putWord8 1 + get = do + tag <- getWord8 + case tag of + 0 -> pure TypeLitSymbol + 1 -> pure TypeLitNat + _ -> fail "GHCi.TH.Binary.putTypeLitSort: invalid tag" + +putTypeRep :: TypeRep a -> Put +-- Special handling for TYPE, (->), and RuntimeRep due to recursive kind +-- relations. +-- See Note [Mutually recursive representations of primitive types] +putTypeRep rep -- Handle Type specially since it's so common + | Just HRefl <- rep `eqTypeRep` (typeRep :: TypeRep Type) + = put (0 :: Word8) +putTypeRep (Con' con ks) = do + put (1 :: Word8) + put con + put ks +putTypeRep (App f x) = do + put (2 :: Word8) + putTypeRep f + putTypeRep x +putTypeRep (Fun arg res) = do + put (3 :: Word8) + putTypeRep arg + putTypeRep res +putTypeRep _ = fail "GHCi.TH.Binary.putTypeRep: Impossible" + +getSomeTypeRep :: Get SomeTypeRep +getSomeTypeRep = do + tag <- get :: Get Word8 + case tag of + 0 -> return $ SomeTypeRep (typeRep :: TypeRep Type) + 1 -> do con <- get :: Get TyCon + ks <- get :: Get [SomeTypeRep] + return $ SomeTypeRep $ mkTrCon con ks + 2 -> do SomeTypeRep f <- getSomeTypeRep + SomeTypeRep x <- getSomeTypeRep + case typeRepKind f of + Fun arg res -> + case arg `eqTypeRep` typeRepKind x of + Just HRefl -> do + case typeRepKind res `eqTypeRep` (typeRep :: TypeRep Type) of + Just HRefl -> return $ SomeTypeRep $ mkTrApp f x + _ -> failure "Kind mismatch" [] + _ -> failure "Kind mismatch" + [ "Found argument of kind: " ++ show (typeRepKind x) + , "Where the constructor: " ++ show f + , "Expects an argument of kind: " ++ show arg + ] + _ -> failure "Applied non-arrow type" + [ "Applied type: " ++ show f + , "To argument: " ++ show x + ] + 3 -> do SomeTypeRep arg <- getSomeTypeRep + SomeTypeRep res <- getSomeTypeRep + case typeRepKind arg `eqTypeRep` (typeRep :: TypeRep Type) of + Just HRefl -> + case typeRepKind res `eqTypeRep` (typeRep :: TypeRep Type) of + Just HRefl -> return $ SomeTypeRep $ Fun arg res + Nothing -> failure "Kind mismatch" [] + Nothing -> failure "Kind mismatch" [] + _ -> failure "Invalid SomeTypeRep" [] + where + failure description info = + fail $ unlines $ [ "GHCi.TH.Binary.getSomeTypeRep: "++description ] + ++ map (" "++) info + +instance Typeable a => Binary (TypeRep (a :: k)) where + put = putTypeRep + get = do + SomeTypeRep rep <- getSomeTypeRep + case rep `eqTypeRep` expected of + Just HRefl -> pure rep + Nothing -> fail $ unlines + [ "GHCi.TH.Binary: Type mismatch" + , " Deserialized type: " ++ show rep + , " Expected type: " ++ show expected + ] + where expected = typeRep :: TypeRep a + +instance Binary SomeTypeRep where + put (SomeTypeRep rep) = putTypeRep rep + get = getSomeTypeRep +#else instance Binary TyCon where put tc = put (tyConPackage tc) >> put (tyConModule tc) >> put (tyConName tc) get = mkTyCon3 <$> get <*> get <*> get @@ -75,6 +245,7 @@ instance Binary TypeRep where get = do (ty_con, child_type_reps) <- get return (mkTyConApp ty_con child_type_reps) +#endif instance Binary Serialized where put (Serialized tyrep wds) = put tyrep >> put (B.pack wds) diff --git a/testsuite/tests/deSugar/should_compile/T2431.stderr b/testsuite/tests/deSugar/should_compile/T2431.stderr index 83826408cf..d601d5d48f 100644 --- a/testsuite/tests/deSugar/should_compile/T2431.stderr +++ b/testsuite/tests/deSugar/should_compile/T2431.stderr @@ -1,7 +1,7 @@ ==================== Tidy Core ==================== Result size of Tidy Core - = {terms: 44, types: 34, coercions: 1, joins: 0/0} + = {terms: 83, types: 49, coercions: 1, joins: 0/0} -- RHS size: {terms: 2, types: 4, coercions: 1, joins: 0/0} T2431.$WRefl [InlPrag=INLINE] :: forall a. a :~: a @@ -47,25 +47,30 @@ T2431.$trModule :: GHC.Types.Module [GblId, Caf=NoCafRefs] T2431.$trModule = GHC.Types.Module $trModule2 $trModule4 --- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} -$tc'Refl1 :: GHC.Prim.Addr# +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +krep :: GHC.Types.KindRep [GblId, Caf=NoCafRefs] -$tc'Refl1 = "'Refl"# +krep = GHC.Types.KindRepTYPE GHC.Types.LiftedRep -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} -$tc'Refl2 :: GHC.Types.TrName +krep1 :: GHC.Types.KindRep [GblId, Caf=NoCafRefs] -$tc'Refl2 = GHC.Types.TrNameS $tc'Refl1 +krep1 = GHC.Types.KindRepTYPE GHC.Types.LiftedRep --- RHS size: {terms: 5, types: 0, coercions: 0, joins: 0/0} -T2431.$tc'Refl :: GHC.Types.TyCon +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +krep2 :: GHC.Types.KindRep [GblId, Caf=NoCafRefs] -T2431.$tc'Refl = - GHC.Types.TyCon - 15026191172322750497## - 3898273167927206410## - T2431.$trModule - $tc'Refl2 +krep2 = GHC.Types.KindRepTYPE GHC.Types.LiftedRep + +-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} +krep3 :: GHC.Types.KindRep +[GblId, Caf=NoCafRefs] +krep3 = GHC.Types.KindRepFun krep1 krep2 + +-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} +krep4 :: GHC.Types.KindRep +[GblId, Caf=NoCafRefs] +krep4 = GHC.Types.KindRepFun krep krep3 -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} $tc:~:1 :: GHC.Prim.Addr# @@ -77,15 +82,66 @@ $tc:~:2 :: GHC.Types.TrName [GblId, Caf=NoCafRefs] $tc:~:2 = GHC.Types.TrNameS $tc:~:1 --- RHS size: {terms: 5, types: 0, coercions: 0, joins: 0/0} +-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0} T2431.$tc:~: :: GHC.Types.TyCon [GblId, Caf=NoCafRefs] T2431.$tc:~: = GHC.Types.TyCon - 9759653149176674453## - 12942818337407067047## + 4608886815921030019## + 6030312177285011233## T2431.$trModule $tc:~:2 + 0# + krep4 + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +krep5 :: GHC.Types.KindRep +[GblId, Caf=NoCafRefs] +krep5 = GHC.Types.KindRepVar 0# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +krep6 :: GHC.Types.KindRep +[GblId, Caf=NoCafRefs] +krep6 = GHC.Types.KindRepVar 0# + +-- RHS size: {terms: 3, types: 2, coercions: 0, joins: 0/0} +krep7 :: [GHC.Types.KindRep] +[GblId, Caf=NoCafRefs] +krep7 = + GHC.Types.: + @ GHC.Types.KindRep krep6 (GHC.Types.[] @ GHC.Types.KindRep) + +-- RHS size: {terms: 3, types: 1, coercions: 0, joins: 0/0} +krep8 :: [GHC.Types.KindRep] +[GblId, Caf=NoCafRefs] +krep8 = GHC.Types.: @ GHC.Types.KindRep krep5 krep7 + +-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} +krep9 :: GHC.Types.KindRep +[GblId, Caf=NoCafRefs] +krep9 = GHC.Types.KindRepTyConApp T2431.$tc:~: krep8 + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +$tc'Refl1 :: GHC.Prim.Addr# +[GblId, Caf=NoCafRefs] +$tc'Refl1 = "'Refl"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +$tc'Refl2 :: GHC.Types.TrName +[GblId, Caf=NoCafRefs] +$tc'Refl2 = GHC.Types.TrNameS $tc'Refl1 + +-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0} +T2431.$tc'Refl :: GHC.Types.TyCon +[GblId, Caf=NoCafRefs] +T2431.$tc'Refl = + GHC.Types.TyCon + 2478588351447975921## + 2684375695874497811## + T2431.$trModule + $tc'Refl2 + 1# + krep9 diff --git a/testsuite/tests/dependent/should_compile/RaeJobTalk.hs b/testsuite/tests/dependent/should_compile/RaeJobTalk.hs index e5c2002e0c..480db090c3 100644 --- a/testsuite/tests/dependent/should_compile/RaeJobTalk.hs +++ b/testsuite/tests/dependent/should_compile/RaeJobTalk.hs @@ -11,7 +11,7 @@ module RaeJobTalk where import Data.Type.Bool -import Data.Type.Equality +import Data.Type.Equality hiding ((:~~:)(..)) import GHC.TypeLits import Data.Proxy import GHC.Exts @@ -129,60 +129,60 @@ instance Read TyConX where readsPrec _ "List" = [(TyConX List, "")] readsPrec _ _ = [] --- This variant of TypeRepX allows you to specify an arbitrary +-- This variant of SomeTypeRep allows you to specify an arbitrary -- constraint on the inner TypeRep -data TypeRepX :: (forall k. k -> Constraint) -> Type where - TypeRepX :: forall k (c :: forall k'. k' -> Constraint) (a :: k). - c a => TypeRep a -> TypeRepX c +data SomeTypeRep :: (forall k. k -> Constraint) -> Type where + SomeTypeRep :: forall k (c :: forall k'. k' -> Constraint) (a :: k). + c a => TypeRep a -> SomeTypeRep c -- This constraint is always satisfied class ConstTrue (a :: k) -- needs the :: k to make it a specified tyvar instance ConstTrue a -instance Show (TypeRepX ConstTrue) where - show (TypeRepX tr) = show tr +instance Show (SomeTypeRep ConstTrue) where + show (SomeTypeRep tr) = show tr --- can't write Show (TypeRepX c) because c's kind mentions a forall, +-- can't write Show (SomeTypeRep c) because c's kind mentions a forall, -- and the impredicativity check gets nervous. See #11519 -instance Show (TypeRepX IsType) where - show (TypeRepX tr) = show tr +instance Show (SomeTypeRep IsType) where + show (SomeTypeRep tr) = show tr -- Just enough functionality to get through example. No parentheses -- or other niceties. -instance Read (TypeRepX ConstTrue) where +instance Read (SomeTypeRep ConstTrue) where readsPrec p s = do let tokens = words s tyreps <- mapM read_token tokens return (foldl1 mk_app tyreps, "") where - read_token :: String -> [TypeRepX ConstTrue] - read_token "String" = return (TypeRepX $ typeRep @String) + read_token :: String -> [SomeTypeRep ConstTrue] + read_token "String" = return (SomeTypeRep $ typeRep @String) read_token other = do (TyConX tc, _) <- readsPrec p other - return (TypeRepX (TyCon tc)) + return (SomeTypeRep (TyCon tc)) - mk_app :: TypeRepX ConstTrue -> TypeRepX ConstTrue -> TypeRepX ConstTrue - mk_app (TypeRepX f) (TypeRepX a) = case kindRep f of + mk_app :: SomeTypeRep ConstTrue -> SomeTypeRep ConstTrue -> SomeTypeRep ConstTrue + mk_app (SomeTypeRep f) (SomeTypeRep a) = case kindRep f of TyCon Arrow `TyApp` k1 `TyApp` _ - | Just HRefl <- k1 `eqT` kindRep a -> TypeRepX (TyApp f a) + | Just HRefl <- k1 `eqT` kindRep a -> SomeTypeRep (TyApp f a) _ -> error "ill-kinded type" --- instance Read (TypeRepX ((~~) Type)) RAE: need (~~) :: forall k1. k1 -> forall k2. k2 -> Constraint +-- instance Read (SomeTypeRep ((~~) Type)) RAE: need (~~) :: forall k1. k1 -> forall k2. k2 -> Constraint -- RAE: need kind signatures on classes --- TypeRepX ((~~) Type) +-- SomeTypeRep ((~~) Type) -- (~~) :: forall k1 k2. k1 -> k2 -> Constraint -- I need: (~~) :: forall k1. k1 -> forall k2. k2 -> Constraint class k ~~ Type => IsType (x :: k) instance k ~~ Type => IsType (x :: k) -instance Read (TypeRepX IsType) where - readsPrec p s = case readsPrec @(TypeRepX ConstTrue) p s of - [(TypeRepX tr, "")] +instance Read (SomeTypeRep IsType) where + readsPrec p s = case readsPrec @(SomeTypeRep ConstTrue) p s of + [(SomeTypeRep tr, "")] | Just HRefl <- eqT (kindRep tr) (typeRep @Type) - -> [(TypeRepX tr, "")] + -> [(SomeTypeRep tr, "")] _ -> error "wrong kind" ----------------------------- @@ -371,7 +371,7 @@ readRows sch lst = (row : tail) tail = readRows sch strTail -- Read in one line of a .schema file. Note that the type read must have kind * -readCol :: String -> (String, TypeRepX IsType) +readCol :: String -> (String, SomeTypeRep IsType) readCol str = case break isSpace str of (name, ' ' : ty) -> (name, read ty) _ -> schemaError $ "Bad parse of " ++ str @@ -386,11 +386,11 @@ withSchema filename thing_inside = do cols = map readCol schEntries go cols thing_inside where - go :: [(String, TypeRepX IsType)] + go :: [(String, SomeTypeRep IsType)] -> (forall (s :: TSchema). Schema s -> IO a) -> IO a go [] thing = thing Nil - go ((name, TypeRepX tr) : cols) thing + go ((name, SomeTypeRep tr) : cols) thing = go cols $ \schema -> case someSymbolVal name of SomeSymbol (_ :: Proxy name) -> diff --git a/testsuite/tests/dependent/should_compile/T11711.hs b/testsuite/tests/dependent/should_compile/T11711.hs index 633ae35e64..0cd4dceb42 100644 --- a/testsuite/tests/dependent/should_compile/T11711.hs +++ b/testsuite/tests/dependent/should_compile/T11711.hs @@ -26,8 +26,8 @@ data TypeRep (a :: k) where class Typeable (a :: k) where typeRep :: TypeRep a -data TypeRepX where - TypeRepX :: forall k (a :: k). TypeRep a -> TypeRepX +data SomeTypeRep where + SomeTypeRep :: forall k (a :: k). TypeRep a -> SomeTypeRep eqTypeRep :: TypeRep a -> TypeRep b -> Maybe (a :~~: b) eqTypeRep = undefined @@ -38,12 +38,12 @@ typeRepKind = undefined instance Typeable Type where typeRep = TrTyCon "Type" typeRep -funResultTy :: TypeRepX -> TypeRepX -> Maybe TypeRepX -funResultTy (TypeRepX f) (TypeRepX x) +funResultTy :: SomeTypeRep -> SomeTypeRep -> Maybe SomeTypeRep +funResultTy (SomeTypeRep f) (SomeTypeRep x) | Just HRefl <- (typeRep :: TypeRep Type) `eqTypeRep` typeRepKind f , TRFun arg res <- f , Just HRefl <- arg `eqTypeRep` x - = Just (TypeRepX res) + = Just (SomeTypeRep res) | otherwise = Nothing diff --git a/testsuite/tests/dependent/should_compile/dynamic-paper.hs b/testsuite/tests/dependent/should_compile/dynamic-paper.hs index 0d55bba93a..1aa4ee54d9 100644 --- a/testsuite/tests/dependent/should_compile/dynamic-paper.hs +++ b/testsuite/tests/dependent/should_compile/dynamic-paper.hs @@ -89,7 +89,7 @@ instance Typeable Int instance (Typeable a, Typeable b) => Typeable (a b) instance Typeable (,) -instance Eq TypeRepX +instance Eq SomeTypeRep data Dynamic where Dyn :: TypeRep a -> a -> Dynamic @@ -196,19 +196,19 @@ castR ta tb = withTypeable ta (withTypeable tb castDance) cmpT = undefined compareTypeRep = undefined -data TypeRepX where - TypeRepX :: TypeRep a -> TypeRepX +data SomeTypeRep where + SomeTypeRep :: TypeRep a -> SomeTypeRep -type TyMapLessTyped = Map TypeRepX Dynamic +type TyMapLessTyped = Map SomeTypeRep Dynamic insertLessTyped :: forall a. Typeable a => a -> TyMapLessTyped -> TyMapLessTyped -insertLessTyped x = Map.insert (TypeRepX (typeRep :: TypeRep a)) (toDynamic x) +insertLessTyped x = Map.insert (SomeTypeRep (typeRep :: TypeRep a)) (toDynamic x) lookupLessTyped :: forall a. Typeable a => TyMapLessTyped -> Maybe a -lookupLessTyped = fromDynamic <=< Map.lookup (TypeRepX (typeRep :: TypeRep a)) +lookupLessTyped = fromDynamic <=< Map.lookup (SomeTypeRep (typeRep :: TypeRep a)) -instance Ord TypeRepX where - compare (TypeRepX tr1) (TypeRepX tr2) = compareTypeRep tr1 tr2 +instance Ord SomeTypeRep where + compare (SomeTypeRep tr1) (SomeTypeRep tr2) = compareTypeRep tr1 tr2 compareTypeRep :: TypeRep a -> TypeRep b -> Ordering -- primitive diff --git a/testsuite/tests/deriving/perf/all.T b/testsuite/tests/deriving/perf/all.T index 4c4bb97101..8dee98961b 100644 --- a/testsuite/tests/deriving/perf/all.T +++ b/testsuite/tests/deriving/perf/all.T @@ -1,8 +1,9 @@ test('T10858', [compiler_stats_num_field('bytes allocated', - [ (wordsize(64), 247768192, 8) ]), - # Initial: 222312440 + [ (wordsize(64), 304094944, 8) ]), + # Initial: 476296112 # 2016-12-19 247768192 Join points (#19288) + # 2016-02-12 304094944 Type-indexed Typeable only_ways(['normal'])], compile, ['-O']) diff --git a/testsuite/tests/ghci.debugger/scripts/print019.stderr b/testsuite/tests/ghci.debugger/scripts/print019.stderr index cc62fa16e6..c266bc8d1a 100644 --- a/testsuite/tests/ghci.debugger/scripts/print019.stderr +++ b/testsuite/tests/ghci.debugger/scripts/print019.stderr @@ -5,10 +5,10 @@ Use :print or :force to determine these types Relevant bindings include it :: a1 (bound at <interactive>:10:1) These potential instances exist: - instance Show TypeRep -- Defined in ‘Data.Typeable.Internal’ instance Show Ordering -- Defined in ‘GHC.Show’ instance Show TyCon -- Defined in ‘GHC.Show’ - ...plus 30 others - ...plus 10 instances involving out-of-scope types + instance Show Integer -- Defined in ‘GHC.Show’ + ...plus 29 others + ...plus 12 instances involving out-of-scope types (use -fprint-potential-instances to see them all) • In a stmt of an interactive GHCi command: print it diff --git a/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr b/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr index fe7b8bf42c..c7db52a5df 100644 --- a/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr +++ b/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr @@ -13,32 +13,55 @@ ({ <no location info> } (HsApp ({ <no location info> } - (HsConLikeOut - ({abstract:ConLike}))) + (HsApp + ({ <no location info> } + (HsApp + ({ <no location info> } + (HsConLikeOut + ({abstract:ConLike}))) + ({ <no location info> } + (HsLit + (HsWordPrim + (NoSourceText) + (14073232900889011755)))))) + ({ <no location info> } + (HsLit + (HsWordPrim + (NoSourceText) + (2739668351064589274)))))) ({ <no location info> } - (HsLit - (HsWordPrim - (NoSourceText) - (8575021419490388262)))))) + (HsVar + ({ <no location info> }{Var: (main:DumpTypecheckedAst.$trModule{v} [lidx] :: ghc-prim:GHC.Types.Module{tc})}))))) ({ <no location info> } - (HsLit - (HsWordPrim - (NoSourceText) - (11015472196725198936)))))) + (HsPar + ({ <no location info> } + (HsApp + ({ <no location info> } + (HsConLikeOut + ({abstract:ConLike}))) + ({ <no location info> } + (HsLit + (HsStringPrim + (NoSourceText) "Peano"))))))))) ({ <no location info> } - (HsVar - ({ <no location info> }{Var: (main:DumpTypecheckedAst.$trModule{v} [lidx] :: ghc-prim:GHC.Types.Module{tc})}))))) + (HsLit + (HsIntPrim + (SourceText "0") + (0)))))) ({ <no location info> } - (HsPar - ({ <no location info> } - (HsApp - ({ <no location info> } - (HsConLikeOut - ({abstract:ConLike}))) - ({ <no location info> } - (HsLit - (HsStringPrim - (NoSourceText) "Peano"))))))))) + (HsVar + ({ <no location info> }{Var: (krep{v} [lid] :: ghc-prim:GHC.Types.KindRep{tc})}))))) + (False))), + ({ <no location info> } + (VarBind {Var: (krep{v} [lid] :: ghc-prim:GHC.Types.KindRep{tc})} + ({ <no location info> } + (HsApp + ({ <no location info> } + (HsConLikeOut + ({abstract:ConLike}))) + ({ <no location info> } + (HsConLikeOut + ({abstract:ConLike}))))) (False))), ({ <no location info> } (VarBind {Var: (main:DumpTypecheckedAst.$tc'Zero{v} [lidx] :: ghc-prim:GHC.Types.TyCon{tc})} @@ -51,32 +74,65 @@ ({ <no location info> } (HsApp ({ <no location info> } - (HsConLikeOut - ({abstract:ConLike}))) + (HsApp + ({ <no location info> } + (HsApp + ({ <no location info> } + (HsConLikeOut + ({abstract:ConLike}))) + ({ <no location info> } + (HsLit + (HsWordPrim + (NoSourceText) + (13760111476013868540)))))) + ({ <no location info> } + (HsLit + (HsWordPrim + (NoSourceText) + (12314848029315386153)))))) ({ <no location info> } - (HsLit - (HsWordPrim - (NoSourceText) - (2837710233032485839)))))) + (HsVar + ({ <no location info> }{Var: (main:DumpTypecheckedAst.$trModule{v} [lidx] :: ghc-prim:GHC.Types.Module{tc})}))))) ({ <no location info> } - (HsLit - (HsWordPrim - (NoSourceText) - (4722402035995040741)))))) + (HsPar + ({ <no location info> } + (HsApp + ({ <no location info> } + (HsConLikeOut + ({abstract:ConLike}))) + ({ <no location info> } + (HsLit + (HsStringPrim + (NoSourceText) "'Zero"))))))))) ({ <no location info> } - (HsVar - ({ <no location info> }{Var: (main:DumpTypecheckedAst.$trModule{v} [lidx] :: ghc-prim:GHC.Types.Module{tc})}))))) + (HsLit + (HsIntPrim + (SourceText "0") + (0)))))) ({ <no location info> } - (HsPar + (HsVar + ({ <no location info> }{Var: (krep{v} [lid] :: ghc-prim:GHC.Types.KindRep{tc})}))))) + (False))), + ({ <no location info> } + (VarBind {Var: (krep{v} [lid] :: ghc-prim:GHC.Types.KindRep{tc})} + ({ <no location info> } + (HsApp + ({ <no location info> } + (HsApp ({ <no location info> } - (HsApp - ({ <no location info> } - (HsConLikeOut - ({abstract:ConLike}))) - ({ <no location info> } - (HsLit - (HsStringPrim - (NoSourceText) "'Zero"))))))))) + (HsConLikeOut + ({abstract:ConLike}))) + ({ <no location info> } + (HsVar + ({ <no location info> }{Var: (main:DumpTypecheckedAst.$tcPeano{v} [lidx] :: ghc-prim:GHC.Types.TyCon{tc})}))))) + ({ <no location info> } + (HsWrap + (WpTyApp + (TyConApp + ({abstract:TyCon}) + [])) + (HsConLikeOut + ({abstract:ConLike})))))) (False))), ({ <no location info> } (VarBind {Var: (main:DumpTypecheckedAst.$tc'Succ{v} [lidx] :: ghc-prim:GHC.Types.TyCon{tc})} @@ -89,32 +145,94 @@ ({ <no location info> } (HsApp ({ <no location info> } - (HsConLikeOut - ({abstract:ConLike}))) + (HsApp + ({ <no location info> } + (HsApp + ({ <no location info> } + (HsConLikeOut + ({abstract:ConLike}))) + ({ <no location info> } + (HsLit + (HsWordPrim + (NoSourceText) + (1143980031331647856)))))) + ({ <no location info> } + (HsLit + (HsWordPrim + (NoSourceText) + (14802086722010293686)))))) ({ <no location info> } - (HsLit - (HsWordPrim - (NoSourceText) - (16648669567626715052)))))) + (HsVar + ({ <no location info> }{Var: (main:DumpTypecheckedAst.$trModule{v} [lidx] :: ghc-prim:GHC.Types.Module{tc})}))))) ({ <no location info> } - (HsLit - (HsWordPrim - (NoSourceText) - (1296291977643060110)))))) + (HsPar + ({ <no location info> } + (HsApp + ({ <no location info> } + (HsConLikeOut + ({abstract:ConLike}))) + ({ <no location info> } + (HsLit + (HsStringPrim + (NoSourceText) "'Succ"))))))))) ({ <no location info> } - (HsVar - ({ <no location info> }{Var: (main:DumpTypecheckedAst.$trModule{v} [lidx] :: ghc-prim:GHC.Types.Module{tc})}))))) + (HsLit + (HsIntPrim + (SourceText "0") + (0)))))) + ({ <no location info> } + (HsVar + ({ <no location info> }{Var: (krep{v} [lid] :: ghc-prim:GHC.Types.KindRep{tc})}))))) + (False))), + ({ <no location info> } + (VarBind {Var: (krep{v} [lid] :: ghc-prim:GHC.Types.KindRep{tc})} + ({ <no location info> } + (HsApp + ({ <no location info> } + (HsApp + ({ <no location info> } + (HsConLikeOut + ({abstract:ConLike}))) + ({ <no location info> } + (HsPar + ({ <no location info> } + (HsApp + ({ <no location info> } + (HsApp + ({ <no location info> } + (HsConLikeOut + ({abstract:ConLike}))) + ({ <no location info> } + (HsVar + ({ <no location info> }{Var: (main:DumpTypecheckedAst.$tcPeano{v} [lidx] :: ghc-prim:GHC.Types.TyCon{tc})}))))) + ({ <no location info> } + (HsWrap + (WpTyApp + (TyConApp + ({abstract:TyCon}) + [])) + (HsConLikeOut + ({abstract:ConLike})))))))))) ({ <no location info> } (HsPar ({ <no location info> } (HsApp ({ <no location info> } - (HsConLikeOut - ({abstract:ConLike}))) + (HsApp + ({ <no location info> } + (HsConLikeOut + ({abstract:ConLike}))) + ({ <no location info> } + (HsVar + ({ <no location info> }{Var: (main:DumpTypecheckedAst.$tcPeano{v} [lidx] :: ghc-prim:GHC.Types.TyCon{tc})}))))) ({ <no location info> } - (HsLit - (HsStringPrim - (NoSourceText) "'Succ"))))))))) + (HsWrap + (WpTyApp + (TyConApp + ({abstract:TyCon}) + [])) + (HsConLikeOut + ({abstract:ConLike})))))))))) (False))), ({ <no location info> } (VarBind {Var: (main:DumpTypecheckedAst.$trModule{v} [lidx] :: ghc-prim:GHC.Types.Module{tc})} diff --git a/testsuite/tests/patsyn/should_compile/T12698.hs b/testsuite/tests/patsyn/should_compile/T12698.hs index 6ba45e4e85..27d54d8eba 100644 --- a/testsuite/tests/patsyn/should_compile/T12698.hs +++ b/testsuite/tests/patsyn/should_compile/T12698.hs @@ -6,7 +6,7 @@ module T12698 where import GHC.Types import Prelude hiding ( fromInteger ) -import Data.Type.Equality +import Data.Type.Equality hiding ((:~~:)(..)) import Data.Kind import qualified Prelude diff --git a/testsuite/tests/perf/compiler/all.T b/testsuite/tests/perf/compiler/all.T index 5f898fbbee..24b03d0326 100644 --- a/testsuite/tests/perf/compiler/all.T +++ b/testsuite/tests/perf/compiler/all.T @@ -39,7 +39,7 @@ test('T1969', # 2013-11-13 17 (x86/Windows, 64bit machine) # 2015-07-11 21 (x86/Linux, 64bit machine) use +RTS -G1 # 2016-04-06 30 (x86/Linux, 64bit machine) - (wordsize(64), 68, 20)]), + (wordsize(64), 83, 20)]), # 28 (amd64/Linux) # 34 (amd64/Linux) # 2012-09-20 23 (amd64/Linux) @@ -53,6 +53,7 @@ test('T1969', # 2015-10-28 55, (amd64/Linux) emit Typeable at definition site # 2016-10-20 68, (amd64/Linux) allow top-level string literals # See the comment 16 on #8472. + # 2017-02-17 83 (amd64/Linux) Type-indexed Typeable compiler_stats_num_field('max_bytes_used', [(platform('i386-unknown-mingw32'), 5719436, 20), # 2010-05-17 5717704 (x86/Windows) @@ -96,27 +97,28 @@ test('T1969', # 2014-06-29 303300692 (x86/Linux) # 2015-07-11 288699104 (x86/Linux, 64-bit machine) use +RTS -G1 # 2016-04-06 344730660 (x86/Linux, 64-bit machine) - (wordsize(64), 756138176, 5)]), - # 17/11/2009 434845560 (amd64/Linux) - # 08/12/2009 459776680 (amd64/Linux) - # 17/05/2010 519377728 (amd64/Linux) - # 05/08/2011 561382568 (amd64/OS X) - # 16/07/2012 589168872 (amd64/Linux) - # 20/07/2012 595936240 (amd64/Linux) - # 23/08/2012 606230880 (amd64/Linux) - # 29/08/2012 633334184 (amd64/Linux) new codegen - # 18/09/2012 641959976 (amd64/Linux) - # 19/10/2012 661832592 (amd64/Linux) -fPIC turned on - # 23/10/2012 642594312 (amd64/Linux) -fPIC turned off again - # 12/11/2012 658786936 (amd64/Linux) UNKNOWN REASON - # 17/1/13: 667160192 (x86_64/Linux) new demand analyser - # 18/10/2013 698612512 (x86_64/Linux) fix for #8456 - # 10/02/2014 660922376 (x86_64/Linux) call arity analysis - # 17/07/2014 651626680 (x86_64/Linux) roundabout update - # 10/09/2014 630299456 (x86_64/Linux) post-AMP-cleanup - # 03/06/2015 581460896 (x86_64/Linux) use +RTS -G1 - # 28/10/2015 695430728 (x86_64/Linux) emit Typeable at definition site - # 28/10/2015 756138176 (x86_64/Linux) inst-decl defaults go via typechecker (#12220) + (wordsize(64), 831733376, 5)]), + # 2009-11-17 434845560 (amd64/Linux) + # 2009-12-08 459776680 (amd64/Linux) + # 2010-05-17 519377728 (amd64/Linux) + # 2011-08-05 561382568 (amd64/OS X) + # 2012-07-16 589168872 (amd64/Linux) + # 2012-07-20 595936240 (amd64/Linux) + # 2012-08-23 606230880 (amd64/Linux) + # 2012-08-29 633334184 (amd64/Linux) new codegen + # 2012-09-18 641959976 (amd64/Linux) + # 2012-10-19 661832592 (amd64/Linux) -fPIC turned on + # 2012-10-23 642594312 (amd64/Linux) -fPIC turned off again + # 2012-11-12 658786936 (amd64/Linux) UNKNOWN REASON + # 2013-91-17 667160192 (x86_64/Linux) new demand analyser + # 2013-10-18 698612512 (x86_64/Linux) fix for #8456 + # 2014-02-10 660922376 (x86_64/Linux) call arity analysis + # 2014-07-17 651626680 (x86_64/Linux) roundabout update + # 2014-09-10 630299456 (x86_64/Linux) post-AMP-cleanup + # 2015-06-03 581460896 (x86_64/Linux) use +RTS -G1 + # 2015-10-28 695430728 (x86_64/Linux) emit Typeable at definition site + # 2015-10-28 756138176 (x86_64/Linux) inst-decl defaults go via typechecker (#12220) + # 2017-02-17 831733376 (x86_64/Linux) Type-indexed Typeable only_ways(['normal']), extra_hc_opts('-dcore-lint -static'), @@ -155,7 +157,7 @@ test('T3294', # 2015-07-11 43196344 (x86/Linux, 64-bit machine) use +RTS -G1 # 2016-04-06 28686588 (x86/Linux, 64-bit machine) - (wordsize(64), 52992688, 20)]), + (wordsize(64), 63131248, 20)]), # prev: 25753192 (amd64/Linux) # 29/08/2012: 37724352 (amd64/Linux) # (increase due to new codegen, see #7198) @@ -173,6 +175,7 @@ test('T3294', # D757: emit Typeable instances at site of type definition # 2016-07-11: 54609256 (Windows) before fix for #12227 # 2016-07-11: 52992688 (Windows) after fix for #12227 + # 2017-02-17: 63131248 (amd64/Linux) Type indexed Typeable compiler_stats_num_field('bytes allocated', [(wordsize(32), 1377050640, 5), @@ -182,7 +185,7 @@ test('T3294', # 2013-11-13: 1478325844 (x86/Windows, 64bit machine) # 2014-01-12: 1565185140 (x86/Linux) # 2013-04-04: 1377050640 (x86/Windows, 64bit machine) - (wordsize(64), 2739731144, 5)]), + (wordsize(64), 2758641264, 5)]), # old: 1357587088 (amd64/Linux) # 29/08/2012: 2961778696 (amd64/Linux) # (^ increase due to new codegen, see #7198) @@ -195,6 +198,7 @@ test('T3294', # 2014-09-10: 2709595808 (amd64/Linux) post-AMP cleanup # 2016-07-11: 2664479936 (Windows) before fix for #12227 # 2016-07-11: 2739731144 (Windows) after fix for #12227 (ignoring) + # 2016-02-17: 2758641264 (amd64/Linux) (Type indexed Typeable) conf_3294, # Use `+RTS -G1` for more stable residency measurements. Note [residency]. @@ -419,7 +423,7 @@ test('T5631', # 2014-04-04: 346389856 (x86 Windows, 64 bit machine) # 2014-12-01: 390199244 (Windows laptop) # 2016-04-06: 570137436 (amd64/Linux) many reasons - (wordsize(64), 1077429456, 5)]), + (wordsize(64), 1517484488, 5)]), # expected value: 774595008 (amd64/Linux): # expected value: 735486328 (amd64/Linux) 2012/12/12: # expected value: 690742040 (amd64/Linux) Call Arity improvements @@ -431,7 +435,7 @@ test('T5631', # 2015-03-18: 1124068664 (Mac) optimize Unify & zonking # 2016-10-19: 1024926024 (amd64/Linux) Refactor traceRn interface (#12617) # 2016-11-10: 1077429456 (amd64/Linux) Stop -dno-debug-output suppressing -ddump-tc-trace - + # 2017-02-17: 1517484488 (amd64/Linux) Type-indexed Typeable only_ways(['normal']) ], compile, @@ -655,18 +659,19 @@ test('T6048', # 2014-12-01: 49987836 (x86 Windows) # 2016-04-06: 55701280 (x86/Linux, 64-bit machine) - (wordsize(64), 94327392, 10)]) - # 18/09/2012 97247032 amd64/Linux - # 16/01/2014 108578664 amd64/Linux (unknown, likely foldl-via-foldr) - # 18/01/2014 95960720 amd64/Linux Call Arity improvements - # 28/02/2014 105556793 amd64/Linux (unknown, tweak in base/4d9e7c9e3 resulted in change) - # 05/03/2014 110646312 amd64/Linux Call Arity became more elaborate - # 14/07/2014 125431448 amd64/Linux unknown reason. Even worse in GHC-7.8.3. *shurg* - # 29/08/2014 108354472 amd64/Linux w/w for INLINABLE things - # 14/09/2014 88186056 amd64/Linux BPP part1 change (more NoImplicitPreludes in base) - # 08/01/2014 95946688 amd64/Linux Mostly 4c834fd. Occasional spikes to 103822120! - # 11/03/2016 108225624 amd64/Linux unknown reason sadly; likely gradual creep. - # 25/11/2016 94327392 amd64/Linux Back down again hooray; still not sure why + (wordsize(64), 115714216, 10)]) + # 2012-09-18 97247032 amd64/Linux + # 2014-01-16 108578664 amd64/Linux (unknown, likely foldl-via-foldr) + # 2014-01-18 95960720 amd64/Linux Call Arity improvements + # 2014-02-28 105556793 amd64/Linux (unknown, tweak in base/4d9e7c9e3 resulted in change) + # 2014-03-05 110646312 amd64/Linux Call Arity became more elaborate + # 2014-07-14 125431448 amd64/Linux unknown reason. Even worse in GHC-7.8.3. *shurg* + # 2014-08-29 108354472 amd64/Linux w/w for INLINABLE things + # 2014-09-14 88186056 amd64/Linux BPP part1 change (more NoImplicitPreludes in base) + # 2014-01-08 95946688 amd64/Linux Mostly 4c834fd. Occasional spikes to 103822120! + # 2016-03-11 108225624 amd64/Linux unknown reason sadly; likely gradual creep. + # 2016-11-25 94327392 amd64/Linux Back down again hooray; still not sure why + # 2017-02-17 115715592 amd64/Linux Type-indexed Typeable ], compile,['']) @@ -721,9 +726,10 @@ test('T9675', # 2015-07-11 56 (x86/Linux, 64-bit machine) use +RTS -G1 ]), compiler_stats_num_field('bytes allocated', - [(wordsize(64), 608284152, 10) + [(wordsize(64), 731171072, 10) # 2014-10-13 544489040 # 2015-10-28 608284152 emit Typeable at definition site + # 2017-02-17 731171072 Type-indexed Typeable ,(wordsize(32), 279480696, 10) # 2015-07-11 279480696 (x86/Linux, 64-bit machine) use +RTS -G1 ]), @@ -737,14 +743,14 @@ test('T9675', test('T9872a', [ only_ways(['normal']), compiler_stats_num_field('bytes allocated', - [(wordsize(64), 3304620816, 5), + [(wordsize(64), 3298422648, 5), # 2014-12-10 5521332656 Initally created # 2014-12-16 5848657456 Flattener parameterized over roles # 2014-12-18 2680733672 Reduce type families even more eagerly # 2015-12-11 3581500440 TypeInType (see #11196) # 2016-04-07 3352882080 CSE improvements # 2016-10-19 3134866040 Refactor traceRn interface (#12617) - # 2017-02-01 3304620816 + # 2017-02-17 3298422648 Type-indexed Typeable (wordsize(32), 1740903516, 5) # was 1325592896 # 2016-04-06 1740903516 x86/Linux @@ -792,7 +798,7 @@ test('T9872c', test('T9872d', [ only_ways(['normal']), compiler_stats_num_field('bytes allocated', - [(wordsize(64), 478169352, 5), + [(wordsize(64), 535565128, 5), # 2014-12-18 796071864 Initally created # 2014-12-18 739189056 Reduce type families even more eagerly # 2015-01-07 687562440 TrieMap leaf compression @@ -802,6 +808,7 @@ test('T9872d', # 2016-03-18 506691240 optimize Unify & zonking # 2016-12-05 478169352 using tyConIsTyFamFree, I think, but only # a 1% improvement 482 -> 478 + # 2017-02-17 535565128 Type-indexed Typeable (wordsize(32), 264566040, 5) # some date 328810212 # 2015-07-11 350369584 @@ -835,7 +842,7 @@ test('T9961', test('T9233', [ only_ways(['normal']), compiler_stats_num_field('bytes allocated', - [(wordsize(64), 884436192, 5), + [(wordsize(64), 974530192, 5), # 2015-08-04 999826288 initial value # 2016-04-14 1066246248 Final demand analyzer run # 2016-06-18 984268712 shuffling around of Data.Functor.Identity @@ -845,6 +852,7 @@ test('T9233', # 2017-01-23 861862608 worker/wrapper evald-ness flags; another 5% improvement! # 2017-02-01 894486272 Join points # 2017-02-07 884436192 Another improvement to SetLevels + # 2017-02-17 974530192 Type-indexed Typeable (wordsize(32), 515672240, 5) # Put in your value here if you hit this # 2016-04-06 515672240 (x86/Linux) initial value @@ -857,7 +865,7 @@ test('T9233', test('T10370', [ only_ways(['optasm']), compiler_stats_num_field('max_bytes_used', # Note [residency] - [(wordsize(64), 38221184, 15), + [(wordsize(64), 51126304, 15), # 2015-10-22 19548720 # 2016-02-24 22823976 Changing Levity to RuntimeRep; not sure why this regresses though, even after some analysis # 2016-04-14 28256896 final demand analyzer run @@ -870,15 +878,17 @@ test('T10370', # were identical, so I think it's just GC noise. # 2016-10-20 38221184 Allow top-level string literals. # See the comment 16 on #8472. + # 2017-02-17 51126304 Type-indexed Typeawble (wordsize(32), 11371496, 15), # 2015-10-22 11371496 ]), compiler_stats_num_field('peak_megabytes_allocated', # Note [residency] - [(wordsize(64), 146, 15), + [(wordsize(64), 187, 15), # 2015-10-22 76 # 2016-04-14 101 final demand analyzer run # 2016-08-08 121 see above # 2017-01-18 146 Allow top-level string literals in Core + # 2017-02-17 187 Type-indexed Typeawble (wordsize(32), 39, 15), # 2015-10-22 39 ]), @@ -916,9 +926,10 @@ test('T12227', test('T12425', [ only_ways(['optasm']), compiler_stats_num_field('bytes allocated', - [(wordsize(64), 133380960, 5), + [(wordsize(64), 173257664, 5), # initial: 125831400 # 2017-01-18: 133380960 Allow top-level string literals in Core + # 2017-02-17: 173257664 Type-indexed Typeable ]), ], compile, @@ -929,11 +940,12 @@ test('T12234', compiler_stats_num_field('bytes allocated', [(platform('x86_64-unknown-mingw32'), 77949232, 5), # initial: 77949232 - (wordsize(64), 74374440, 5), + (wordsize(64), 86525344, 5), # initial: 72958288 # 2016-01-17: 76848856 (x86-64, Linux. drift?) # 2017-02-01: 80882208 (Use superclass instances when solving) # 2017-02-05: 74374440 (Probably OccAnal fixes) + # 2017-02-17: 86525344 (Type-indexed Typeable) ]), ], compile, @@ -942,10 +954,11 @@ test('T12234', test('T13035', [ only_ways(['normal']), compiler_stats_num_field('bytes allocated', - [(wordsize(64), 88806416, 5), - # 2017-01-05 90595208 initial - # 2017-01-19 95269000 Allow top-level string literals in Core - # 2017-02-05 88806416 Probably OccAnal fixes + [(wordsize(64), 103890200, 5), + # 2017-01-05 90595208 initial + # 2017-01-19 95269000 Allow top-level string literals in Core + # 2017-02-05 88806416 Probably OccAnal fixes + # 2017-02-17 103890200 Type-indexed Typeable ]), ], compile, diff --git a/testsuite/tests/perf/haddock/all.T b/testsuite/tests/perf/haddock/all.T index 4c641d5828..a148b712d2 100644 --- a/testsuite/tests/perf/haddock/all.T +++ b/testsuite/tests/perf/haddock/all.T @@ -5,7 +5,7 @@ test('haddock.base', [unless(in_tree_compiler(), skip), req_haddock ,stats_num_field('bytes allocated', - [(wordsize(64), 38425793776, 5) + [(wordsize(64), 25592972912, 5) # 2012-08-14: 5920822352 (amd64/Linux) # 2012-09-20: 5829972376 (amd64/Linux) # 2012-10-08: 5902601224 (amd64/Linux) @@ -34,6 +34,7 @@ test('haddock.base', # 2017-02-11: 34819979936 (x86_64/Linux) - OccurAnal / One-Shot (#13227) # 2017-02-16: 32695562088 Better Lint for join points # 2017-02-17: 38425793776 (x86_64/Linux) - Generalize kind of (->) + # 2017-02-12: 25592972912 (x86_64/Linux) - Type-indexed Typeable ,(platform('i386-unknown-mingw32'), 4434804940, 5) # 2013-02-10: 3358693084 (x86/Windows) @@ -56,7 +57,7 @@ test('haddock.base', test('haddock.Cabal', [unless(in_tree_compiler(), skip), req_haddock ,stats_num_field('bytes allocated', - [(wordsize(64), 27784875792, 5) + [(wordsize(64), 18865432648, 5) # 2012-08-14: 3255435248 (amd64/Linux) # 2012-08-29: 3324606664 (amd64/Linux, new codegen) # 2012-10-08: 3373401360 (amd64/Linux) @@ -100,6 +101,7 @@ test('haddock.Cabal', # 2017-02-11: 25533642168 (amd64/Linux) - OccurAnal / One-Shot (#13227) # 2017-02-16: 23867276992 Better Lint for join points # 2017-02-17: 27784875792 (amd64/Linux) - Generalize kind of (->) + # 2017-02-12: 18865432648 (amd64/Linux) - Type-indexed Typeable ,(platform('i386-unknown-mingw32'), 3293415576, 5) # 2012-10-30: 1733638168 (x86/Windows) diff --git a/testsuite/tests/perf/should_run/all.T b/testsuite/tests/perf/should_run/all.T index 4bd75f70de..27d8df87b8 100644 --- a/testsuite/tests/perf/should_run/all.T +++ b/testsuite/tests/perf/should_run/all.T @@ -73,7 +73,7 @@ test('lazy-bs-alloc', [stats_num_field('peak_megabytes_allocated', (2, 1)), # expected value: 2 (amd64/Linux) stats_num_field('bytes allocated', - [(wordsize(64), 444720, 5), + [(wordsize(64), 421792, 5), # 489776 (amd64/Linux) # 2013-02-07: 429744 (amd64/Linux) # 2013-12-12: 425400 (amd64/Linux) @@ -81,6 +81,7 @@ test('lazy-bs-alloc', # 2015-08-15: 431500 (Windows not good enough. avg of Windows&Linux) # 2015-12-15: 444720 (amd64/Linux, D1616) # 2015-12-17: 444720 (widen 3->5%, Windows is at 462688) + # 2017-01-30: 421792 (amd64/Linux, strangely Type-indexed Typeable) (wordsize(32), 429760, 2)]), # 2013-02-10: 421296 (x86/Windows) # 2013-02-10: 414180 (x86/OSX) diff --git a/testsuite/tests/perf/space_leaks/all.T b/testsuite/tests/perf/space_leaks/all.T index a58ae2c97b..76ad7a7606 100644 --- a/testsuite/tests/perf/space_leaks/all.T +++ b/testsuite/tests/perf/space_leaks/all.T @@ -58,13 +58,14 @@ test('T4018', test('T4029', [stats_num_field('peak_megabytes_allocated', - [(wordsize(64), 71, 10)]), + [(wordsize(64), 80, 10)]), # 2016-02-26: 66 (amd64/Linux) INITIAL # 2016-05-23: 82 (amd64/Linux) Use -G1 # 2016-07-13: 92 (amd64/Linux) Changes to tidyType # 2016-09-01: 71 (amd64/Linux) Restore w/w limit (#11565) + # 2017-02-12: 80 (amd64/Linux) Type-indexed Typeable stats_num_field('max_bytes_used', - [(wordsize(64), 22770352, 5)]), + [(wordsize(64), 24151096, 5)]), # 2016-02-26: 24071720 (amd64/Linux) INITIAL # 2016-04-21: 25542832 (amd64/Linux) # 2016-05-23: 25247216 (amd64/Linux) Use -G1 @@ -75,6 +76,7 @@ test('T4029', # 2016-11-14: 21387048 (amd64/Linux) Creep back upwards :( # 2017-01-18: 21670448 (amd64/Linux) Float string literals to toplevel # 2017-02-07: 22770352 (amd64/Linux) It is unclear + # 2017-02-12: 24151096 (amd64/Linux) Type-indexed Typeable extra_hc_opts('+RTS -G1 -RTS' ), ], ghci_script, diff --git a/testsuite/tests/polykinds/T8132.hs b/testsuite/tests/polykinds/T8132.hs index 337e2882f1..cdbfd7f0b9 100644 --- a/testsuite/tests/polykinds/T8132.hs +++ b/testsuite/tests/polykinds/T8132.hs @@ -1,6 +1,7 @@ {-# LANGUAGE MagicHash #-} -import Data.Typeable.Internal +import Data.Typeable data K = K -instance Typeable K where typeRep# _ = undefined +-- This used to have a RHS but now we hide typeRep# +instance Typeable K -- where typeRep# _ = undefined diff --git a/testsuite/tests/polykinds/T8132.stderr b/testsuite/tests/polykinds/T8132.stderr index c5f56f9fbe..a1aaa1319a 100644 --- a/testsuite/tests/polykinds/T8132.stderr +++ b/testsuite/tests/polykinds/T8132.stderr @@ -1,4 +1,4 @@ -T8132.hs:6:1: error: +T8132.hs:7:1: error: • Class ‘Typeable’ does not support user-specified instances • In the instance declaration for ‘Typeable K’ diff --git a/testsuite/tests/roles/should_compile/Roles1.stderr b/testsuite/tests/roles/should_compile/Roles1.stderr index bb67a8cf26..a81e7c0187 100644 --- a/testsuite/tests/roles/should_compile/Roles1.stderr +++ b/testsuite/tests/roles/should_compile/Roles1.stderr @@ -27,88 +27,188 @@ Dependent packages: [base-4.10.0.0, ghc-prim-0.5.0.0, ==================== Typechecker ==================== Roles1.$tcT7 = GHC.Types.TyCon - 12795488517584970699## - 6852268802866176810## + 178606230775360129## + 14564382578551945561## Roles1.$trModule (GHC.Types.TrNameS "T7"#) + 1 + krep +krep [InlPrag=[~]] + = GHC.Types.KindRepFun + (GHC.Types.KindRepVar 0) + (GHC.Types.KindRepFun + (GHC.Types.KindRepTYPE GHC.Types.LiftedRep) + (GHC.Types.KindRepTYPE GHC.Types.LiftedRep)) Roles1.$tc'K7 = GHC.Types.TyCon - 12022030613939361326## - 11727141136040515167## + 15901479081375327280## + 4842873210599704617## Roles1.$trModule (GHC.Types.TrNameS "'K7"#) + 3 + krep +krep [InlPrag=[~]] + = GHC.Types.KindRepFun + (GHC.Types.KindRepVar 2) + (GHC.Types.KindRepTyConApp + Roles1.$tcT7 + ((:) + (GHC.Types.KindRepVar 0) + ((:) (GHC.Types.KindRepVar 1) ((:) (GHC.Types.KindRepVar 2) [])))) Roles1.$tcT6 = GHC.Types.TyCon - 1052116432298682626## - 4782516991847719023## + 7244893995195634045## + 6882827069359931041## Roles1.$trModule (GHC.Types.TrNameS "T6"#) + 1 + krep +krep [InlPrag=[~]] + = GHC.Types.KindRepFun + (GHC.Types.KindRepVar 0) + (GHC.Types.KindRepTYPE GHC.Types.LiftedRep) Roles1.$tc'K6 = GHC.Types.TyCon - 14383224451764499060## - 13586832700239872984## + 13928703131159360198## + 9274401506945696896## Roles1.$trModule (GHC.Types.TrNameS "'K6"#) + 2 + krep +krep [InlPrag=[~]] + = GHC.Types.KindRepTyConApp + Roles1.$tcT6 + ((:) (GHC.Types.KindRepVar 0) ((:) (GHC.Types.KindRepVar 1) [])) Roles1.$tcT5 = GHC.Types.TyCon - 10855726709479635304## - 5574528370049939204## + 12033401645911719002## + 6369139038321702301## Roles1.$trModule (GHC.Types.TrNameS "T5"#) + 0 + krep +krep [InlPrag=[~]] + = GHC.Types.KindRepFun + (GHC.Types.KindRepTYPE GHC.Types.LiftedRep) + (GHC.Types.KindRepTYPE GHC.Types.LiftedRep) Roles1.$tc'K5 = GHC.Types.TyCon - 17986294396600628264## - 15784122741796850983## + 5548842497263642061## + 18349261927117571882## Roles1.$trModule (GHC.Types.TrNameS "'K5"#) + 1 + krep +krep [InlPrag=[~]] + = GHC.Types.KindRepFun + (GHC.Types.KindRepVar 0) + (GHC.Types.KindRepTyConApp + Roles1.$tcT5 ((:) (GHC.Types.KindRepVar 0) [])) Roles1.$tcT4 = GHC.Types.TyCon - 5809060867006837344## - 8795972313583150301## + 15834077582937152787## + 17059037094835388922## Roles1.$trModule (GHC.Types.TrNameS "T4"#) + 0 + krep +krep [InlPrag=[~]] + = GHC.Types.KindRepFun + (GHC.Types.KindRepFun + (GHC.Types.KindRepTYPE GHC.Types.LiftedRep) + (GHC.Types.KindRepTYPE GHC.Types.LiftedRep)) + (GHC.Types.KindRepFun + (GHC.Types.KindRepTYPE GHC.Types.LiftedRep) + (GHC.Types.KindRepTYPE GHC.Types.LiftedRep)) Roles1.$tc'K4 = GHC.Types.TyCon - 6498964159768283182## - 956453098475971212## + 10188453925450404995## + 4762093850599364042## Roles1.$trModule (GHC.Types.TrNameS "'K4"#) + 2 + krep +krep [InlPrag=[~]] + = GHC.Types.KindRepFun + (GHC.Types.KindRepApp + (GHC.Types.KindRepVar 0) (GHC.Types.KindRepVar 1)) + (GHC.Types.KindRepTyConApp + Roles1.$tcT4 + ((:) (GHC.Types.KindRepVar 0) ((:) (GHC.Types.KindRepVar 1) []))) Roles1.$tcT3 = GHC.Types.TyCon - 17827258502042208248## - 10404219359416482652## + 13341737262627465733## + 14527452670364737316## Roles1.$trModule (GHC.Types.TrNameS "T3"#) + 1 + krep +krep [InlPrag=[~]] + = GHC.Types.KindRepFun + (GHC.Types.KindRepVar 0) + (GHC.Types.KindRepTYPE GHC.Types.LiftedRep) Roles1.$tc'K3 = GHC.Types.TyCon - 18386915834109553575## - 773967725306507064## + 14534968069054730342## + 6860808298964464185## Roles1.$trModule (GHC.Types.TrNameS "'K3"#) + 2 + krep +krep [InlPrag=[~]] + = GHC.Types.KindRepTyConApp + Roles1.$tcT3 + ((:) (GHC.Types.KindRepVar 0) ((:) (GHC.Types.KindRepVar 1) [])) Roles1.$tcT2 = GHC.Types.TyCon - 14324923875690440398## - 17626224477681351106## + 12900773996789723956## + 9313087549503346504## Roles1.$trModule (GHC.Types.TrNameS "T2"#) + 0 + krep +krep [InlPrag=[~]] + = GHC.Types.KindRepFun + (GHC.Types.KindRepTYPE GHC.Types.LiftedRep) + (GHC.Types.KindRepTYPE GHC.Types.LiftedRep) Roles1.$tc'K2 = GHC.Types.TyCon - 17795591238510508397## - 10155757471958311507## + 11054915488163123841## + 10799789256744079155## Roles1.$trModule (GHC.Types.TrNameS "'K2"#) + 1 + krep +krep [InlPrag=[~]] + = GHC.Types.KindRepFun + (GHC.Types.KindRepVar 0) + (GHC.Types.KindRepTyConApp + Roles1.$tcT2 ((:) (GHC.Types.KindRepVar 0) [])) Roles1.$tcT1 = GHC.Types.TyCon - 12633763300352597178## - 11103726621424210926## + 13228660854624297872## + 14494320157476678712## Roles1.$trModule (GHC.Types.TrNameS "T1"#) + 0 + krep +krep [InlPrag=[~]] + = GHC.Types.KindRepFun + (GHC.Types.KindRepTYPE GHC.Types.LiftedRep) + (GHC.Types.KindRepTYPE GHC.Types.LiftedRep) Roles1.$tc'K1 = GHC.Types.TyCon - 1949157551035372857## - 3576433963139282451## + 1265606750138351672## + 7033043930969109074## Roles1.$trModule (GHC.Types.TrNameS "'K1"#) + 1 + krep +krep [InlPrag=[~]] + = GHC.Types.KindRepFun + (GHC.Types.KindRepVar 0) + (GHC.Types.KindRepTyConApp + Roles1.$tcT1 ((:) (GHC.Types.KindRepVar 0) [])) Roles1.$trModule = GHC.Types.Module (GHC.Types.TrNameS "main"#) (GHC.Types.TrNameS "Roles1"#) diff --git a/testsuite/tests/roles/should_compile/Roles13.stderr b/testsuite/tests/roles/should_compile/Roles13.stderr index 7e510d442e..f336a69be1 100644 --- a/testsuite/tests/roles/should_compile/Roles13.stderr +++ b/testsuite/tests/roles/should_compile/Roles13.stderr @@ -1,7 +1,7 @@ ==================== Tidy Core ==================== Result size of Tidy Core - = {terms: 63, types: 26, coercions: 5, joins: 0/0} + = {terms: 114, types: 43, coercions: 5, joins: 0/0} -- RHS size: {terms: 2, types: 2, coercions: 0, joins: 0/0} convert1 :: Wrap Age -> Wrap Age @@ -41,25 +41,10 @@ Roles13.$trModule :: GHC.Types.Module [GblId, Caf=NoCafRefs] Roles13.$trModule = GHC.Types.Module $trModule2 $trModule4 --- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} -$tc'MkAge1 :: GHC.Prim.Addr# -[GblId, Caf=NoCafRefs] -$tc'MkAge1 = "'MkAge"# - -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} -$tc'MkAge2 :: GHC.Types.TrName +krep :: GHC.Types.KindRep [GblId, Caf=NoCafRefs] -$tc'MkAge2 = GHC.Types.TrNameS $tc'MkAge1 - --- RHS size: {terms: 5, types: 0, coercions: 0, joins: 0/0} -Roles13.$tc'MkAge :: GHC.Types.TyCon -[GblId, Caf=NoCafRefs] -Roles13.$tc'MkAge = - GHC.Types.TyCon - 1226019810264079099## - 12180888342844277416## - Roles13.$trModule - $tc'MkAge2 +krep = GHC.Types.KindRepTYPE GHC.Types.LiftedRep -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} $tcAge1 :: GHC.Prim.Addr# @@ -71,35 +56,73 @@ $tcAge2 :: GHC.Types.TrName [GblId, Caf=NoCafRefs] $tcAge2 = GHC.Types.TrNameS $tcAge1 --- RHS size: {terms: 5, types: 0, coercions: 0, joins: 0/0} +-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0} Roles13.$tcAge :: GHC.Types.TyCon [GblId, Caf=NoCafRefs] Roles13.$tcAge = GHC.Types.TyCon - 18304088376370610314## - 1954648846714895105## + 3456257068627873222## + 14056710845110756026## Roles13.$trModule $tcAge2 + 0# + krep + +-- RHS size: {terms: 3, types: 1, coercions: 0, joins: 0/0} +krep1 :: GHC.Types.KindRep +[GblId] +krep1 = + GHC.Types.KindRepTyConApp + GHC.Types.$tcInt (GHC.Types.[] @ GHC.Types.KindRep) + +-- RHS size: {terms: 3, types: 1, coercions: 0, joins: 0/0} +krep2 :: GHC.Types.KindRep +[GblId, Caf=NoCafRefs] +krep2 = + GHC.Types.KindRepTyConApp + Roles13.$tcAge (GHC.Types.[] @ GHC.Types.KindRep) + +-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} +krep3 :: GHC.Types.KindRep +[GblId] +krep3 = GHC.Types.KindRepFun krep1 krep2 -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} -$tc'MkWrap1 :: GHC.Prim.Addr# +$tc'MkAge1 :: GHC.Prim.Addr# [GblId, Caf=NoCafRefs] -$tc'MkWrap1 = "'MkWrap"# +$tc'MkAge1 = "'MkAge"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} -$tc'MkWrap2 :: GHC.Types.TrName +$tc'MkAge2 :: GHC.Types.TrName [GblId, Caf=NoCafRefs] -$tc'MkWrap2 = GHC.Types.TrNameS $tc'MkWrap1 +$tc'MkAge2 = GHC.Types.TrNameS $tc'MkAge1 --- RHS size: {terms: 5, types: 0, coercions: 0, joins: 0/0} -Roles13.$tc'MkWrap :: GHC.Types.TyCon -[GblId, Caf=NoCafRefs] -Roles13.$tc'MkWrap = +-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0} +Roles13.$tc'MkAge :: GHC.Types.TyCon +[GblId] +Roles13.$tc'MkAge = GHC.Types.TyCon - 12402878715225676312## - 13345418993613492500## + 18264039750958872441## + 1870189534242358050## Roles13.$trModule - $tc'MkWrap2 + $tc'MkAge2 + 0# + krep3 + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +krep4 :: GHC.Types.KindRep +[GblId, Caf=NoCafRefs] +krep4 = GHC.Types.KindRepTYPE GHC.Types.LiftedRep + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +krep5 :: GHC.Types.KindRep +[GblId, Caf=NoCafRefs] +krep5 = GHC.Types.KindRepTYPE GHC.Types.LiftedRep + +-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} +krep6 :: GHC.Types.KindRep +[GblId, Caf=NoCafRefs] +krep6 = GHC.Types.KindRepFun krep4 krep5 -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} $tcWrap1 :: GHC.Prim.Addr# @@ -111,15 +134,66 @@ $tcWrap2 :: GHC.Types.TrName [GblId, Caf=NoCafRefs] $tcWrap2 = GHC.Types.TrNameS $tcWrap1 --- RHS size: {terms: 5, types: 0, coercions: 0, joins: 0/0} +-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0} Roles13.$tcWrap :: GHC.Types.TyCon [GblId, Caf=NoCafRefs] Roles13.$tcWrap = GHC.Types.TyCon - 5278920226786541118## - 14554440859491798587## + 13773534096961634492## + 15591525585626702988## Roles13.$trModule $tcWrap2 + 0# + krep6 + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +krep7 :: GHC.Types.KindRep +[GblId, Caf=NoCafRefs] +krep7 = GHC.Types.KindRepVar 0# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +krep8 :: GHC.Types.KindRep +[GblId, Caf=NoCafRefs] +krep8 = GHC.Types.KindRepVar 0# + +-- RHS size: {terms: 3, types: 2, coercions: 0, joins: 0/0} +krep9 :: [GHC.Types.KindRep] +[GblId, Caf=NoCafRefs] +krep9 = + GHC.Types.: + @ GHC.Types.KindRep krep8 (GHC.Types.[] @ GHC.Types.KindRep) + +-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} +krep10 :: GHC.Types.KindRep +[GblId, Caf=NoCafRefs] +krep10 = GHC.Types.KindRepTyConApp Roles13.$tcWrap krep9 + +-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} +krep11 :: GHC.Types.KindRep +[GblId, Caf=NoCafRefs] +krep11 = GHC.Types.KindRepFun krep7 krep10 + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +$tc'MkWrap1 :: GHC.Prim.Addr# +[GblId, Caf=NoCafRefs] +$tc'MkWrap1 = "'MkWrap"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +$tc'MkWrap2 :: GHC.Types.TrName +[GblId, Caf=NoCafRefs] +$tc'MkWrap2 = GHC.Types.TrNameS $tc'MkWrap1 + +-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0} +Roles13.$tc'MkWrap :: GHC.Types.TyCon +[GblId, Caf=NoCafRefs] +Roles13.$tc'MkWrap = + GHC.Types.TyCon + 15580677875333883466## + 808508687714473149## + Roles13.$trModule + $tc'MkWrap2 + 1# + krep11 diff --git a/testsuite/tests/roles/should_compile/Roles14.stderr b/testsuite/tests/roles/should_compile/Roles14.stderr index 8604b00ad2..61d0a597d1 100644 --- a/testsuite/tests/roles/should_compile/Roles14.stderr +++ b/testsuite/tests/roles/should_compile/Roles14.stderr @@ -14,16 +14,30 @@ Dependent packages: [base-4.10.0.0, ghc-prim-0.5.0.0, ==================== Typechecker ==================== Roles12.$tcC2 = GHC.Types.TyCon - 4006088231579841122## - 4783761708993822739## + 7996680154108933333## + 9454227235464419996## Roles12.$trModule (GHC.Types.TrNameS "C2"#) + 0 + krep +krep [InlPrag=[~]] + = GHC.Types.KindRepFun + (GHC.Types.KindRepTYPE GHC.Types.LiftedRep) + (GHC.Types.KindRepTyConApp GHC.Types.$tcConstraint []) Roles12.$tc'C:C2 = GHC.Types.TyCon - 5555822832309788726## - 2795860317217328413## + 7087988437584478859## + 11477953550142401435## Roles12.$trModule (GHC.Types.TrNameS "'C:C2"#) + 1 + krep +krep [InlPrag=[~]] + = GHC.Types.KindRepFun + (GHC.Types.KindRepFun + (GHC.Types.KindRepVar 0) (GHC.Types.KindRepVar 0)) + (GHC.Types.KindRepTyConApp + Roles12.$tcC2 ((:) (GHC.Types.KindRepVar 0) [])) Roles12.$trModule = GHC.Types.Module (GHC.Types.TrNameS "main"#) (GHC.Types.TrNameS "Roles12"#) diff --git a/testsuite/tests/roles/should_compile/Roles2.stderr b/testsuite/tests/roles/should_compile/Roles2.stderr index cea02f5215..7a795a3fa6 100644 --- a/testsuite/tests/roles/should_compile/Roles2.stderr +++ b/testsuite/tests/roles/should_compile/Roles2.stderr @@ -13,28 +13,56 @@ Dependent packages: [base-4.10.0.0, ghc-prim-0.5.0.0, ==================== Typechecker ==================== Roles2.$tcT2 = GHC.Types.TyCon - 5934726586329293381## - 1923031187495159753## + 9065817229114433861## + 13399581642971864140## Roles2.$trModule (GHC.Types.TrNameS "T2"#) + 0 + krep +krep [InlPrag=[~]] + = GHC.Types.KindRepFun + (GHC.Types.KindRepTYPE GHC.Types.LiftedRep) + (GHC.Types.KindRepTYPE GHC.Types.LiftedRep) Roles2.$tc'K2 = GHC.Types.TyCon - 1362115092449420584## - 15899377929296700609## + 17395957229042313563## + 12263882107019815181## Roles2.$trModule (GHC.Types.TrNameS "'K2"#) + 1 + krep +krep [InlPrag=[~]] + = GHC.Types.KindRepFun + (GHC.Types.KindRepTyConApp + GHC.Ptr.$tcFunPtr ((:) (GHC.Types.KindRepVar 0) [])) + (GHC.Types.KindRepTyConApp + Roles2.$tcT2 ((:) (GHC.Types.KindRepVar 0) [])) Roles2.$tcT1 = GHC.Types.TyCon - 13879106829711353992## - 15151456821588362072## + 10310640733256438505## + 9162099558816022096## Roles2.$trModule (GHC.Types.TrNameS "T1"#) + 0 + krep +krep [InlPrag=[~]] + = GHC.Types.KindRepFun + (GHC.Types.KindRepTYPE GHC.Types.LiftedRep) + (GHC.Types.KindRepTYPE GHC.Types.LiftedRep) Roles2.$tc'K1 = GHC.Types.TyCon - 14735176013935828521## - 17563925141462511949## + 16530009231990968394## + 11761390951471299534## Roles2.$trModule (GHC.Types.TrNameS "'K1"#) + 1 + krep +krep [InlPrag=[~]] + = GHC.Types.KindRepFun + (GHC.Types.KindRepTyConApp + GHC.Types.$tcIO ((:) (GHC.Types.KindRepVar 0) [])) + (GHC.Types.KindRepTyConApp + Roles2.$tcT1 ((:) (GHC.Types.KindRepVar 0) [])) Roles2.$trModule = GHC.Types.Module (GHC.Types.TrNameS "main"#) (GHC.Types.TrNameS "Roles2"#) diff --git a/testsuite/tests/roles/should_compile/Roles3.stderr b/testsuite/tests/roles/should_compile/Roles3.stderr index 1541f892a9..5d3c38c355 100644 --- a/testsuite/tests/roles/should_compile/Roles3.stderr +++ b/testsuite/tests/roles/should_compile/Roles3.stderr @@ -35,52 +35,93 @@ Dependent packages: [base-4.10.0.0, ghc-prim-0.5.0.0, ==================== Typechecker ==================== Roles3.$tcC4 = GHC.Types.TyCon - 12861862461396457184## - 6389612623460961504## + 6800596812149592130## + 15513203864133461281## Roles3.$trModule (GHC.Types.TrNameS "C4"#) -Roles3.$tc'C:C4 - = GHC.Types.TyCon - 5012080351591218464## - 14312195554521420369## - Roles3.$trModule - (GHC.Types.TrNameS "'C:C4"#) + 0 + krep +krep [InlPrag=[~]] + = GHC.Types.KindRepFun + (GHC.Types.KindRepTYPE GHC.Types.LiftedRep) + (GHC.Types.KindRepFun + (GHC.Types.KindRepTYPE GHC.Types.LiftedRep) + (GHC.Types.KindRepTyConApp GHC.Types.$tcConstraint [])) Roles3.$tcC3 = GHC.Types.TyCon - 5998139369941479154## - 6816352641934636458## + 5076086601454991970## + 10299714674904836194## Roles3.$trModule (GHC.Types.TrNameS "C3"#) -Roles3.$tc'C:C3 - = GHC.Types.TyCon - 5363370173992879615## - 3444510123613553605## - Roles3.$trModule - (GHC.Types.TrNameS "'C:C3"#) + 0 + krep +krep [InlPrag=[~]] + = GHC.Types.KindRepFun + (GHC.Types.KindRepTYPE GHC.Types.LiftedRep) + (GHC.Types.KindRepFun + (GHC.Types.KindRepTYPE GHC.Types.LiftedRep) + (GHC.Types.KindRepTyConApp GHC.Types.$tcConstraint [])) Roles3.$tcC2 = GHC.Types.TyCon - 8833962732139387711## - 7891126688522429937## + 7902873224172523979## + 11840994447152209031## Roles3.$trModule (GHC.Types.TrNameS "C2"#) + 0 + krep +krep [InlPrag=[~]] + = GHC.Types.KindRepFun + (GHC.Types.KindRepTYPE GHC.Types.LiftedRep) + (GHC.Types.KindRepFun + (GHC.Types.KindRepTYPE GHC.Types.LiftedRep) + (GHC.Types.KindRepTyConApp GHC.Types.$tcConstraint [])) Roles3.$tc'C:C2 = GHC.Types.TyCon - 17372867324718144313## - 13604113872247370917## + 11218882737915989529## + 9454910899374397367## Roles3.$trModule (GHC.Types.TrNameS "'C:C2"#) + 2 + krep +krep [InlPrag=[~]] + = GHC.Types.KindRepFun + (GHC.Types.KindRepFun + (GHC.Types.KindRepTyConApp + Data.Type.Equality.$tc~ + ((:) + (GHC.Types.KindRepTYPE GHC.Types.LiftedRep) + ((:) (GHC.Types.KindRepVar 0) ((:) (GHC.Types.KindRepVar 1) [])))) + (GHC.Types.KindRepFun + (GHC.Types.KindRepVar 0) (GHC.Types.KindRepVar 1))) + (GHC.Types.KindRepTyConApp + Roles3.$tcC2 + ((:) (GHC.Types.KindRepVar 0) ((:) (GHC.Types.KindRepVar 1) []))) Roles3.$tcC1 = GHC.Types.TyCon - 16242970448469140073## - 10229725431456576413## + 11013585501375994163## + 16371608655219610659## Roles3.$trModule (GHC.Types.TrNameS "C1"#) + 0 + krep +krep [InlPrag=[~]] + = GHC.Types.KindRepFun + (GHC.Types.KindRepTYPE GHC.Types.LiftedRep) + (GHC.Types.KindRepTyConApp GHC.Types.$tcConstraint []) Roles3.$tc'C:C1 = GHC.Types.TyCon - 2927144765823607117## - 15172069236577673237## + 4508088879886988796## + 13962145553903222779## Roles3.$trModule (GHC.Types.TrNameS "'C:C1"#) + 1 + krep +krep [InlPrag=[~]] + = GHC.Types.KindRepFun + (GHC.Types.KindRepFun + (GHC.Types.KindRepVar 0) (GHC.Types.KindRepVar 0)) + (GHC.Types.KindRepTyConApp + Roles3.$tcC1 ((:) (GHC.Types.KindRepVar 0) [])) Roles3.$trModule = GHC.Types.Module (GHC.Types.TrNameS "main"#) (GHC.Types.TrNameS "Roles3"#) diff --git a/testsuite/tests/roles/should_compile/Roles4.stderr b/testsuite/tests/roles/should_compile/Roles4.stderr index 49e9ac9768..989d77a9d6 100644 --- a/testsuite/tests/roles/should_compile/Roles4.stderr +++ b/testsuite/tests/roles/should_compile/Roles4.stderr @@ -20,28 +20,58 @@ Dependent packages: [base-4.10.0.0, ghc-prim-0.5.0.0, ==================== Typechecker ==================== Roles4.$tcC3 = GHC.Types.TyCon - 16502190608089501863## - 13971441568961069854## + 7508642517340826358## + 16938219270597865136## Roles4.$trModule (GHC.Types.TrNameS "C3"#) + 0 + krep +krep [InlPrag=[~]] + = GHC.Types.KindRepFun + (GHC.Types.KindRepTYPE GHC.Types.LiftedRep) + (GHC.Types.KindRepTyConApp GHC.Types.$tcConstraint []) Roles4.$tc'C:C3 = GHC.Types.TyCon - 16482122951248115051## - 8497036782794772516## + 3133378316178104365## + 15809386433947157376## Roles4.$trModule (GHC.Types.TrNameS "'C:C3"#) + 1 + krep +krep [InlPrag=[~]] + = GHC.Types.KindRepFun + (GHC.Types.KindRepFun + (GHC.Types.KindRepVar 0) + (GHC.Types.KindRepTyConApp + GHC.Types.$tc[] ((:) (GHC.Types.KindRepVar 0) []))) + (GHC.Types.KindRepTyConApp + Roles4.$tcC3 ((:) (GHC.Types.KindRepVar 0) [])) Roles4.$tcC1 = GHC.Types.TyCon - 11951908835899020229## - 6518430686554778113## + 13392243382482428602## + 1780037961948725012## Roles4.$trModule (GHC.Types.TrNameS "C1"#) + 0 + krep +krep [InlPrag=[~]] + = GHC.Types.KindRepFun + (GHC.Types.KindRepTYPE GHC.Types.LiftedRep) + (GHC.Types.KindRepTyConApp GHC.Types.$tcConstraint []) Roles4.$tc'C:C1 = GHC.Types.TyCon - 11393997571952951642## - 4382794907973051606## + 3870707671502302648## + 10631907186261837450## Roles4.$trModule (GHC.Types.TrNameS "'C:C1"#) + 1 + krep +krep [InlPrag=[~]] + = GHC.Types.KindRepFun + (GHC.Types.KindRepFun + (GHC.Types.KindRepVar 0) (GHC.Types.KindRepVar 0)) + (GHC.Types.KindRepTyConApp + Roles4.$tcC1 ((:) (GHC.Types.KindRepVar 0) [])) Roles4.$trModule = GHC.Types.Module (GHC.Types.TrNameS "main"#) (GHC.Types.TrNameS "Roles4"#) diff --git a/testsuite/tests/roles/should_compile/T8958.stderr b/testsuite/tests/roles/should_compile/T8958.stderr index a527d1f02e..52bfa274c9 100644 --- a/testsuite/tests/roles/should_compile/T8958.stderr +++ b/testsuite/tests/roles/should_compile/T8958.stderr @@ -22,40 +22,96 @@ Dependent packages: [base-4.10.0.0, ghc-prim-0.5.0.0, ==================== Typechecker ==================== T8958.$tcMap = GHC.Types.TyCon - 11173210732975605893## - 6338753504925142034## + 16542473435673943392## + 5374201132143305512## T8958.$trModule (GHC.Types.TrNameS "Map"#) + 0 + krep +krep [InlPrag=[~]] + = GHC.Types.KindRepFun + (GHC.Types.KindRepTYPE GHC.Types.LiftedRep) + (GHC.Types.KindRepFun + (GHC.Types.KindRepTYPE GHC.Types.LiftedRep) + (GHC.Types.KindRepTYPE GHC.Types.LiftedRep)) T8958.$tc'MkMap = GHC.Types.TyCon - 10702411725744601909## - 8660532495248702786## + 2942839876828444488## + 3989137838066763457## T8958.$trModule (GHC.Types.TrNameS "'MkMap"#) + 2 + krep +krep [InlPrag=[~]] + = GHC.Types.KindRepFun + (GHC.Types.KindRepTyConApp + GHC.Types.$tc[] + ((:) @ GHC.Types.KindRep + (GHC.Types.KindRepTyConApp + GHC.Tuple.$tc(,) + ((:) @ GHC.Types.KindRep + (GHC.Types.KindRepVar 0) + ((:) @ GHC.Types.KindRep + (GHC.Types.KindRepVar 1) [] @ GHC.Types.KindRep))) + [] @ GHC.Types.KindRep)) + (GHC.Types.KindRepTyConApp + T8958.$tcMap + ((:) @ GHC.Types.KindRep + (GHC.Types.KindRepVar 0) + ((:) @ GHC.Types.KindRep + (GHC.Types.KindRepVar 1) [] @ GHC.Types.KindRep))) T8958.$tcRepresentational = GHC.Types.TyCon - 17939208465687456137## - 86959701938445380## + 12809567151893673426## + 12159693688248149156## T8958.$trModule (GHC.Types.TrNameS "Representational"#) + 0 + krep +krep [InlPrag=[~]] + = GHC.Types.KindRepFun + (GHC.Types.KindRepTYPE GHC.Types.LiftedRep) + (GHC.Types.KindRepTyConApp + GHC.Types.$tcConstraint [] @ GHC.Types.KindRep) T8958.$tc'C:Representational = GHC.Types.TyCon - 6623579006299218188## - 18041743345929230411## + 2358772282532242424## + 5444038897914446879## T8958.$trModule (GHC.Types.TrNameS "'C:Representational"#) + 1 + krep +krep [InlPrag=[~]] + = GHC.Types.KindRepTyConApp + T8958.$tcRepresentational + ((:) @ GHC.Types.KindRep + (GHC.Types.KindRepVar 0) [] @ GHC.Types.KindRep) T8958.$tcNominal = GHC.Types.TyCon - 5048799062136959048## - 4899664595355811926## + 12224997609886144634## + 9866011944332051160## T8958.$trModule (GHC.Types.TrNameS "Nominal"#) + 0 + krep +krep [InlPrag=[~]] + = GHC.Types.KindRepFun + (GHC.Types.KindRepTYPE GHC.Types.LiftedRep) + (GHC.Types.KindRepTyConApp + GHC.Types.$tcConstraint [] @ GHC.Types.KindRep) T8958.$tc'C:Nominal = GHC.Types.TyCon - 13167926310643805202## - 1726092271306256063## + 10562260635335201742## + 1215478186250709459## T8958.$trModule (GHC.Types.TrNameS "'C:Nominal"#) + 1 + krep +krep [InlPrag=[~]] + = GHC.Types.KindRepTyConApp + T8958.$tcNominal + ((:) @ GHC.Types.KindRep + (GHC.Types.KindRepVar 0) [] @ GHC.Types.KindRep) T8958.$trModule = GHC.Types.Module (GHC.Types.TrNameS "main"#) (GHC.Types.TrNameS "T8958"#) diff --git a/testsuite/tests/safeHaskell/unsafeLibs/GoodImport03.hs b/testsuite/tests/safeHaskell/unsafeLibs/GoodImport03.hs index 84e728ffb3..edd6d65fcb 100644 --- a/testsuite/tests/safeHaskell/unsafeLibs/GoodImport03.hs +++ b/testsuite/tests/safeHaskell/unsafeLibs/GoodImport03.hs @@ -56,7 +56,6 @@ import Data.String import Data.Traversable import Data.Tuple import Data.Typeable -import Data.Typeable.Internal import Data.Unique import Data.Version import Data.Word @@ -113,6 +112,8 @@ import Text.Read.Lex import Text.Show import Text.Show.Functions +import Type.Reflection + -- import Unsafe.Coerce f :: Int diff --git a/testsuite/tests/simplCore/should_compile/T7360.stderr b/testsuite/tests/simplCore/should_compile/T7360.stderr index e3fea9ba85..bf2c6df607 100644 --- a/testsuite/tests/simplCore/should_compile/T7360.stderr +++ b/testsuite/tests/simplCore/should_compile/T7360.stderr @@ -1,7 +1,7 @@ ==================== Tidy Core ==================== Result size of Tidy Core - = {terms: 94, types: 48, coercions: 0, joins: 0/0} + = {terms: 125, types: 58, coercions: 0, joins: 0/0} -- RHS size: {terms: 6, types: 3, coercions: 0, joins: 0/0} T7360.$WFoo3 [InlPrag=INLINE] :: Int -> Foo @@ -119,129 +119,174 @@ T7360.$trModule :: GHC.Types.Module T7360.$trModule = GHC.Types.Module T7360.$trModule3 T7360.$trModule1 +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +T7360.$tcFoo1 [InlPrag=[~]] :: GHC.Types.KindRep +[GblId, Caf=NoCafRefs, Str=m5] +T7360.$tcFoo1 = GHC.Types.KindRepTYPE GHC.Types.LiftedRep + -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} -T7360.$tc'Foo9 :: GHC.Prim.Addr# +T7360.$tcFoo3 :: GHC.Prim.Addr# [GblId, Caf=NoCafRefs, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}] -T7360.$tc'Foo9 = "'Foo3"# + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}] +T7360.$tcFoo3 = "Foo"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} -T7360.$tc'Foo8 :: GHC.Types.TrName +T7360.$tcFoo2 :: GHC.Types.TrName [GblId, Caf=NoCafRefs, Str=m1, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] -T7360.$tc'Foo8 = GHC.Types.TrNameS T7360.$tc'Foo9 +T7360.$tcFoo2 = GHC.Types.TrNameS T7360.$tcFoo3 --- RHS size: {terms: 5, types: 0, coercions: 0, joins: 0/0} -T7360.$tc'Foo3 :: GHC.Types.TyCon +-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0} +T7360.$tcFoo :: GHC.Types.TyCon [GblId, Caf=NoCafRefs, Str=m, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 50}] -T7360.$tc'Foo3 = + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 70}] +T7360.$tcFoo = GHC.Types.TyCon - 10507205234936349519## - 8302184214013227554## + 1581370841583180512## + 13291578023368289311## T7360.$trModule - T7360.$tc'Foo8 + T7360.$tcFoo2 + 0# + T7360.$tcFoo1 + +-- RHS size: {terms: 3, types: 1, coercions: 0, joins: 0/0} +T7360.$tc'Foo4 [InlPrag=[~]] :: GHC.Types.KindRep +[GblId, Caf=NoCafRefs, Str=m1] +T7360.$tc'Foo4 = + GHC.Types.KindRepTyConApp + T7360.$tcFoo (GHC.Types.[] @ GHC.Types.KindRep) -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} -T7360.$tc'Foo7 :: GHC.Prim.Addr# +T7360.$tc'Foo6 :: GHC.Prim.Addr# [GblId, Caf=NoCafRefs, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}] -T7360.$tc'Foo7 = "'Foo2"# +T7360.$tc'Foo6 = "'Foo1"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} -T7360.$tc'Foo6 :: GHC.Types.TrName +T7360.$tc'Foo5 :: GHC.Types.TrName [GblId, Caf=NoCafRefs, Str=m1, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] -T7360.$tc'Foo6 = GHC.Types.TrNameS T7360.$tc'Foo7 +T7360.$tc'Foo5 = GHC.Types.TrNameS T7360.$tc'Foo6 --- RHS size: {terms: 5, types: 0, coercions: 0, joins: 0/0} -T7360.$tc'Foo2 :: GHC.Types.TyCon +-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0} +T7360.$tc'Foo1 :: GHC.Types.TyCon [GblId, Caf=NoCafRefs, Str=m, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 50}] -T7360.$tc'Foo2 = + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 70}] +T7360.$tc'Foo1 = GHC.Types.TyCon - 9825259700232563546## - 11056638024476048052## + 3986951253261644518## + 2515097940992351150## T7360.$trModule - T7360.$tc'Foo6 + T7360.$tc'Foo5 + 0# + T7360.$tc'Foo4 + +-- RHS size: {terms: 3, types: 1, coercions: 0, joins: 0/0} +T7360.$tc'Foo7 [InlPrag=[~]] :: GHC.Types.KindRep +[GblId, Caf=NoCafRefs, Str=m1] +T7360.$tc'Foo7 = + GHC.Types.KindRepTyConApp + T7360.$tcFoo (GHC.Types.[] @ GHC.Types.KindRep) -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} -T7360.$tc'Foo5 :: GHC.Prim.Addr# +T7360.$tc'Foo9 :: GHC.Prim.Addr# [GblId, Caf=NoCafRefs, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}] -T7360.$tc'Foo5 = "'Foo1"# +T7360.$tc'Foo9 = "'Foo2"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} -T7360.$tc'Foo4 :: GHC.Types.TrName +T7360.$tc'Foo8 :: GHC.Types.TrName [GblId, Caf=NoCafRefs, Str=m1, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] -T7360.$tc'Foo4 = GHC.Types.TrNameS T7360.$tc'Foo5 +T7360.$tc'Foo8 = GHC.Types.TrNameS T7360.$tc'Foo9 --- RHS size: {terms: 5, types: 0, coercions: 0, joins: 0/0} -T7360.$tc'Foo1 :: GHC.Types.TyCon +-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0} +T7360.$tc'Foo2 :: GHC.Types.TyCon [GblId, Caf=NoCafRefs, Str=m, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 50}] -T7360.$tc'Foo1 = + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 70}] +T7360.$tc'Foo2 = GHC.Types.TyCon - 2058692068419561651## - 9152017373001677943## + 17325079864060690428## + 2969742457748208427## T7360.$trModule - T7360.$tc'Foo4 + T7360.$tc'Foo8 + 0# + T7360.$tc'Foo7 + +-- RHS size: {terms: 3, types: 1, coercions: 0, joins: 0/0} +krep :: GHC.Types.KindRep +[GblId, Str=m1] +krep = + GHC.Types.KindRepTyConApp + GHC.Types.$tcInt (GHC.Types.[] @ GHC.Types.KindRep) + +-- RHS size: {terms: 3, types: 1, coercions: 0, joins: 0/0} +krep1 :: GHC.Types.KindRep +[GblId, Caf=NoCafRefs, Str=m1] +krep1 = + GHC.Types.KindRepTyConApp + T7360.$tcFoo (GHC.Types.[] @ GHC.Types.KindRep) + +-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} +T7360.$tc'Foo10 [InlPrag=[~]] :: GHC.Types.KindRep +[GblId, Str=m4] +T7360.$tc'Foo10 = GHC.Types.KindRepFun krep krep1 -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} -T7360.$tcFoo2 :: GHC.Prim.Addr# +T7360.$tc'Foo12 :: GHC.Prim.Addr# [GblId, Caf=NoCafRefs, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}] -T7360.$tcFoo2 = "Foo"# + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}] +T7360.$tc'Foo12 = "'Foo3"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} -T7360.$tcFoo1 :: GHC.Types.TrName +T7360.$tc'Foo11 :: GHC.Types.TrName [GblId, Caf=NoCafRefs, Str=m1, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}] -T7360.$tcFoo1 = GHC.Types.TrNameS T7360.$tcFoo2 +T7360.$tc'Foo11 = GHC.Types.TrNameS T7360.$tc'Foo12 --- RHS size: {terms: 5, types: 0, coercions: 0, joins: 0/0} -T7360.$tcFoo :: GHC.Types.TyCon +-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0} +T7360.$tc'Foo3 :: GHC.Types.TyCon [GblId, - Caf=NoCafRefs, Str=m, Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, - WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 50}] -T7360.$tcFoo = + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 70}] +T7360.$tc'Foo3 = GHC.Types.TyCon - 8358641983981300860## - 582034888424804490## + 3674231676522181654## + 2694749919371021431## T7360.$trModule - T7360.$tcFoo1 + T7360.$tc'Foo11 + 0# + T7360.$tc'Foo10 diff --git a/testsuite/tests/simplCore/should_compile/T8274.stdout b/testsuite/tests/simplCore/should_compile/T8274.stdout index df8253f510..90d5cebefb 100644 --- a/testsuite/tests/simplCore/should_compile/T8274.stdout +++ b/testsuite/tests/simplCore/should_compile/T8274.stdout @@ -4,15 +4,20 @@ T8274.$trModule4 :: Addr# T8274.$trModule4 = "main"# T8274.$trModule2 :: Addr# T8274.$trModule2 = "T8274"# -T8274.$tc'Positives2 :: Addr# -T8274.$tc'Positives2 = "'Positives"# -T8274.$tc'Positives = GHC.Types.TyCon 14732531009298850569## 4925356269917933860## T8274.$trModule T8274.$tc'Positives1 -T8274.$tcP2 :: Addr# -T8274.$tcP2 = "P"# -T8274.$tcP = GHC.Types.TyCon 11095028091707994303## 9476557054198009608## T8274.$trModule T8274.$tcP1 -T8274.$tc'Negatives2 :: Addr# -T8274.$tc'Negatives2 = "'Negatives"# -T8274.$tc'Negatives = GHC.Types.TyCon 15950179315687996644## 11481167534507418130## T8274.$trModule T8274.$tc'Negatives1 -T8274.$tcN2 :: Addr# -T8274.$tcN2 = "N"# -T8274.$tcN = GHC.Types.TyCon 7479687563082171902## 17616649989360543185## T8274.$trModule T8274.$tcN1 +T8274.$tcP3 :: Addr# +T8274.$tcP3 = "P"# +T8274.$tcP = GHC.Types.TyCon 7483823267324216774## 12197132127820124256## T8274.$trModule T8274.$tcP2 0# T8274.$tcP1 +krep = GHC.Types.KindRepTyConApp GHC.Types.$tcInt# (GHC.Types.[] @ GHC.Types.KindRep) +krep1 = GHC.Types.KindRepTyConApp GHC.Types.$tcFloat# (GHC.Types.[] @ GHC.Types.KindRep) +krep2 = GHC.Types.KindRepTyConApp GHC.Types.$tcDouble# (GHC.Types.[] @ GHC.Types.KindRep) +krep3 = GHC.Types.KindRepTyConApp GHC.Types.$tcChar# (GHC.Types.[] @ GHC.Types.KindRep) +krep4 = GHC.Types.KindRepTyConApp GHC.Types.$tcWord# (GHC.Types.[] @ GHC.Types.KindRep) +T8274.$tc'Positives3 :: Addr# +T8274.$tc'Positives3 = "'Positives"# + = GHC.Types.TyCon 14886798270706315033## 15735393004803600911## T8274.$trModule T8274.$tc'Positives2 0# T8274.$tc'Positives1 +T8274.$tcN3 :: Addr# +T8274.$tcN3 = "N"# +T8274.$tcN = GHC.Types.TyCon 17387464673997143412## 16681536026493340311## T8274.$trModule T8274.$tcN2 0# T8274.$tcN1 +T8274.$tc'Negatives3 :: Addr# +T8274.$tc'Negatives3 = "'Negatives"# + = GHC.Types.TyCon 14330047746189143983## 12207513731214201811## T8274.$trModule T8274.$tc'Negatives2 0# T8274.$tc'Negatives1 diff --git a/testsuite/tests/th/TH_Roles2.stderr b/testsuite/tests/th/TH_Roles2.stderr index 33fec8e9d5..7b872aae9a 100644 --- a/testsuite/tests/th/TH_Roles2.stderr +++ b/testsuite/tests/th/TH_Roles2.stderr @@ -4,17 +4,23 @@ TYPE CONSTRUCTORS data T (a :: k) COERCION AXIOMS Dependent modules: [] -Dependent packages: [array-0.5.1.1, base-4.9.0.0, deepseq-1.4.2.0, +Dependent packages: [array-0.5.1.2, base-4.10.0.0, deepseq-1.4.3.0, ghc-boot-th-8.1, ghc-prim-0.5.0.0, integer-gmp-1.0.0.1, - pretty-1.1.3.3, template-haskell-2.11.0.0] + pretty-1.1.3.3, template-haskell-2.12.0.0] ==================== Typechecker ==================== TH_Roles2.$tcT = GHC.Types.TyCon - 6325001754388382679## - 4656387726417942748## + 11651627537942629178## + 11503899791410937231## TH_Roles2.$trModule (GHC.Types.TrNameS "T"#) + 1 + krep_a7XD +krep_a7XD [InlPrag=[~]] + = GHC.Types.KindRepFun + (GHC.Types.KindRepVar 0) + (GHC.Types.KindRepTYPE GHC.Types.LiftedRep) TH_Roles2.$trModule = GHC.Types.Module (GHC.Types.TrNameS "main"#) (GHC.Types.TrNameS "TH_Roles2"#) diff --git a/testsuite/tests/typecheck/should_compile/tc167.hs b/testsuite/tests/typecheck/should_compile/tc167.hs index b42ceacdc8..773075022c 100644 --- a/testsuite/tests/typecheck/should_compile/tc167.hs +++ b/testsuite/tests/typecheck/should_compile/tc167.hs @@ -1,13 +1,15 @@ {-# LANGUAGE MagicHash #-} --- Type checking with unboxed kinds fails when (->) is used in a prefix way +-- It used to be that (->) would have a very restrictive kind when used in +-- prefix position. This restriction was lifted after the levity polymorphism +-- work in 2016. module ShouldSucceed where import GHC.Base type T = (->) Int# --- Here's the comment from TypeRep: +-- Here's the old comment from TypeRep: -- -- funTyCon = mkFunTyCon funTyConName -- (mkArrowKinds [liftedTypeKind, liftedTypeKind] diff --git a/testsuite/tests/typecheck/should_fail/TcStaticPointersFail02.stderr b/testsuite/tests/typecheck/should_fail/TcStaticPointersFail02.stderr index e6e637cfeb..fd6be80c7e 100644 --- a/testsuite/tests/typecheck/should_fail/TcStaticPointersFail02.stderr +++ b/testsuite/tests/typecheck/should_fail/TcStaticPointersFail02.stderr @@ -1,13 +1,13 @@ TcStaticPointersFail02.hs:9:6: error: - • No instance for (Data.Typeable.Internal.Typeable b) + • No instance for (base-4.10.0.0:Data.Typeable.Internal.Typeable b) arising from a static form • In the expression: static (undefined :: (forall a. a -> a) -> b) In an equation for ‘f1’: f1 = static (undefined :: (forall a. a -> a) -> b) TcStaticPointersFail02.hs:12:6: error: - • No instance for (Data.Typeable.Internal.Typeable + • No instance for (base-4.10.0.0:Data.Typeable.Internal.Typeable (Monad m => a -> m a)) arising from a static form (maybe you haven't applied a function to enough arguments?) diff --git a/testsuite/tests/typecheck/should_run/TestTypeableBinary.hs b/testsuite/tests/typecheck/should_run/TestTypeableBinary.hs new file mode 100644 index 0000000000..e427c13725 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/TestTypeableBinary.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} + +import qualified Data.ByteString as BS +import Type.Reflection +import Data.Binary +import GHCi.TH.Binary () + +import GHC.Exts +import Data.Kind +import Data.Proxy + +testRoundtrip :: Typeable a => TypeRep a -> IO () +testRoundtrip rep + | rep /= rep' = putStrLn $ "bad: " ++ show rep ++ " /= " ++ show rep' + | otherwise = putStrLn $ "good: " ++ show rep + where + rep' = decode (encode rep) + +main :: IO () +main = do + testRoundtrip (typeRep :: TypeRep Int) + testRoundtrip (typeRep :: TypeRep Int#) + testRoundtrip (typeRep :: TypeRep IO) + testRoundtrip (typeRep :: TypeRep Maybe) + testRoundtrip (typeRep :: TypeRep TYPE) + testRoundtrip (typeRep :: TypeRep RuntimeRep) + testRoundtrip (typeRep :: TypeRep 'IntRep) + testRoundtrip (typeRep :: TypeRep (->)) + testRoundtrip (typeRep :: TypeRep (Proxy Int)) + testRoundtrip (typeRep :: TypeRep (Proxy Int#)) + testRoundtrip (typeRep :: TypeRep Type) + testRoundtrip (typeRep :: TypeRep (Int -> Int)) + testRoundtrip (typeRep :: TypeRep 5) + testRoundtrip (typeRep :: TypeRep "hello world") + testRoundtrip (typeRep :: TypeRep ('Just 5)) diff --git a/testsuite/tests/typecheck/should_run/TestTypeableBinary.stdout b/testsuite/tests/typecheck/should_run/TestTypeableBinary.stdout new file mode 100644 index 0000000000..515738e98e --- /dev/null +++ b/testsuite/tests/typecheck/should_run/TestTypeableBinary.stdout @@ -0,0 +1,15 @@ +good: Int +good: Int# +good: IO +good: Maybe +good: TYPE +good: RuntimeRep +good: 'IntRep +good: (->) 'LiftedRep 'LiftedRep +good: Proxy * Int +good: Proxy (TYPE 'IntRep) Int# +good: * +good: Int -> Int +good: 5 +good: "hello world" +good: 'Just Nat 5 diff --git a/testsuite/tests/typecheck/should_run/TypeOf.stdout b/testsuite/tests/typecheck/should_run/TypeOf.stdout index 99f113cf00..3c125fecfd 100644 --- a/testsuite/tests/typecheck/should_run/TypeOf.stdout +++ b/testsuite/tests/typecheck/should_run/TypeOf.stdout @@ -5,7 +5,7 @@ Word Double IO () (Char,Int,[Char]) -TypeRep +SomeTypeRep Bool Ordering Int -> Int @@ -13,7 +13,7 @@ Proxy Constraint (Eq Int) Proxy Constraint (Int,Int) Proxy Symbol "hello world" Proxy Nat 1 -Proxy [Nat] (': Nat 1 (': Nat 2 (': Nat 3 '[]))) +Proxy [Nat] (': Nat 1 (': Nat 2 (': Nat 3 ('[] Nat)))) Proxy Ordering 'EQ Proxy (RuntimeRep -> Constraint) TYPE Proxy Constraint Constraint @@ -21,4 +21,4 @@ Proxy Constraint Constraint Proxy Constraint Constraint Proxy RuntimeRep 'LiftedRep Proxy (Nat,Symbol) ('(,) Nat Symbol 1 "hello") -Proxy (Constraint -> Constraint -> Constraint) ~~ +Proxy (Constraint -> Constraint -> Constraint) (~~ Constraint Constraint) diff --git a/testsuite/tests/typecheck/should_run/TypeRep.hs b/testsuite/tests/typecheck/should_run/TypeRep.hs index 5fbf909193..002e4fbac0 100644 --- a/testsuite/tests/typecheck/should_run/TypeRep.hs +++ b/testsuite/tests/typecheck/should_run/TypeRep.hs @@ -1,5 +1,9 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE TypeInType #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE MagicHash #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE AllowAmbiguousTypes #-} @@ -30,6 +34,12 @@ main = do print $ rep @Bool print $ rep @Ordering print $ rep @(Int -> Int) + print $ rep @((Eq Int, Eq String) :: Constraint) + + -- Unboxed things (#12049) + print $ rep @Int# + print $ rep @(##) + print $ rep @(# Int#, Int #) -- Various instantiations of a kind-polymorphic type print $ rep @(Proxy (Eq Int)) @@ -45,4 +55,4 @@ main = do print $ rep @(Proxy 'LiftedRep) -- Something lifted and primitive - print $ rep @RealWorld + print $ rep @RealWorld -- #12132 diff --git a/testsuite/tests/typecheck/should_run/TypeRep.stdout b/testsuite/tests/typecheck/should_run/TypeRep.stdout index 09b4cea574..8f5d3fb232 100644 --- a/testsuite/tests/typecheck/should_run/TypeRep.stdout +++ b/testsuite/tests/typecheck/should_run/TypeRep.stdout @@ -10,11 +10,15 @@ IO Bool Ordering Int -> Int +(%,%) (Eq Int) (Eq [Char]) +Int# +(##) +(#,#) 'IntRep 'LiftedRep Int# Int Proxy Constraint (Eq Int) Proxy Constraint (Int,Int) Proxy Symbol "hello world" Proxy Nat 1 -Proxy [Nat] (': Nat 1 (': Nat 2 (': Nat 3 '[]))) +Proxy [Nat] (': Nat 1 (': Nat 2 (': Nat 3 ('[] Nat)))) Proxy Ordering 'EQ Proxy (RuntimeRep -> Constraint) TYPE Proxy Constraint Constraint diff --git a/testsuite/tests/typecheck/should_run/Typeable1.hs b/testsuite/tests/typecheck/should_run/Typeable1.hs new file mode 100644 index 0000000000..02a7ebb98b --- /dev/null +++ b/testsuite/tests/typecheck/should_run/Typeable1.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE PolyKinds #-} + +import Type.Reflection +import Data.Kind + +data ComposeK (f :: k' -> Type) (g :: k -> k') a = ComposeK (f (g a)) + +main :: IO () +main = do + let x :: ComposeK Maybe Maybe Int + x = undefined + + App x y <- pure $ typeOf x + print (x, y) + + App x y <- pure x + print (x, y) + + App x y <- pure x + print (x, y) + + App x y <- pure x -- This makes GHC panic + print (x, y) diff --git a/testsuite/tests/typecheck/should_run/Typeable1.stderr b/testsuite/tests/typecheck/should_run/Typeable1.stderr new file mode 100644 index 0000000000..9a7d3b799c --- /dev/null +++ b/testsuite/tests/typecheck/should_run/Typeable1.stderr @@ -0,0 +1,25 @@ + +Typeable1.hs:22:5: error: + • Couldn't match kind ‘* -> (* -> *) -> (* -> *) -> * -> *’ + with ‘forall k. (* -> *) -> (k -> *) -> k -> *’ + Inaccessible code in + a pattern with pattern synonym: + App :: forall k2 (t :: k2). + () => + forall k1 (a :: k1 -> k2) (b :: k1). + t ~ a b => + TypeRep a -> TypeRep b -> TypeRep t, + in a pattern binding in + 'do' block + • In the pattern: App x y + In a stmt of a 'do' block: App x y <- pure x + In the expression: + do let x :: ComposeK Maybe Maybe Int + x = undefined + App x y <- pure $ typeOf x + print (x, y) + App x y <- pure x + .... + • Relevant bindings include + y :: TypeRep b2 (bound at Typeable1.hs:19:11) + x :: TypeRep a2 (bound at Typeable1.hs:19:9) diff --git a/testsuite/tests/typecheck/should_run/TypeableEq.hs b/testsuite/tests/typecheck/should_run/TypeableEq.hs new file mode 100644 index 0000000000..6fe6aa7c11 --- /dev/null +++ b/testsuite/tests/typecheck/should_run/TypeableEq.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE PolyKinds, TypeFamilies #-} + +-- | Test equality predicates of Type.Reflection. +module Main where + +import Type.Reflection +import Data.Kind +import Data.Maybe +import Data.Proxy +import Data.Functor.Const +import Data.Functor.Product + +--data Product (f :: k -> Type) (g :: k -> Type) (a :: k) +-- = Product (f x) (g x) + +test1 :: IO () +test1 = do + let x = typeRep :: TypeRep (Maybe String) + y = typeRep :: TypeRep (Maybe Int) + + checkEq False x y + App maybe1 _ <- pure x + App maybe2 _ <- pure y + checkEq True maybe1 maybe2 + + +test2 :: IO () +test2 = do + let x = typeRep :: TypeRep (Proxy String) + y = typeRep :: TypeRep (Proxy Int) + + checkEq False x y + App proxy1 _ <- pure x + App proxy2 _ <- pure y + checkEq True proxy1 proxy2 + + +test3 :: IO () +test3 = do + let x = typeRep :: TypeRep (Product (Const String) (Const Int) Int) + y = typeRep :: TypeRep (Product (Const String) (Const Char) Int) + checkEq False x y + App dx _ <- pure x -- "d" stands for decomposed + App dy _ <- pure y + checkEq False dx dy + App ddx _ <- pure dx + App ddy _ <- pure dy + checkEq True ddx ddy + + +test4 :: IO () +test4 = do + let x = typeRep :: TypeRep (Product (Const String) (Const Int) Int) + y = typeRep :: TypeRep (Product (Const String) (Const Int) Char) + + checkEq False x y + App dx _ <- pure x + App dy _ <- pure y + checkEq True dx dy + App ddx _ <- pure dx + App ddy _ <- pure dy + checkEq True ddx ddy + + +main :: IO () +main = sequence_ [test1, test2, test3, test4] + +type IsEqual = Bool + +check :: Bool -> String -> IO () +check success msg = putStrLn $ goodBad ++ " " ++ msg + where goodBad + | success = "good" + | otherwise = "bad " + +checkEq :: IsEqual -> TypeRep a -> TypeRep b -> IO () +checkEq expected a b = + check success (show a ++ " == " ++ show b ++ "?") + where success = isJust (a `eqTypeRep` b) == expected diff --git a/testsuite/tests/typecheck/should_run/TypeableEq.stdout b/testsuite/tests/typecheck/should_run/TypeableEq.stdout new file mode 100644 index 0000000000..bff6d9ee2c --- /dev/null +++ b/testsuite/tests/typecheck/should_run/TypeableEq.stdout @@ -0,0 +1,10 @@ +good Maybe [Char] == Maybe Int? +good Maybe == Maybe? +good Proxy * [Char] == Proxy * Int? +good Proxy * == Proxy *? +good Product * (Const * [Char]) (Const * Int) Int == Product * (Const * [Char]) (Const * Char) Int? +good Product * (Const * [Char]) (Const * Int) == Product * (Const * [Char]) (Const * Char)? +good Product * (Const * [Char]) == Product * (Const * [Char])? +good Product * (Const * [Char]) (Const * Int) Int == Product * (Const * [Char]) (Const * Int) Char? +good Product * (Const * [Char]) (Const * Int) == Product * (Const * [Char]) (Const * Int)? +good Product * (Const * [Char]) == Product * (Const * [Char])? diff --git a/testsuite/tests/typecheck/should_run/all.T b/testsuite/tests/typecheck/should_run/all.T index eab9f8a8a8..c44a23e1ff 100755 --- a/testsuite/tests/typecheck/should_run/all.T +++ b/testsuite/tests/typecheck/should_run/all.T @@ -117,3 +117,6 @@ test('KindInvariant', normal, ghci_script, ['KindInvariant.script']) test('StrictPats', normal, compile_and_run, ['']) test('T12809', normal, compile_and_run, ['']) test('EtaExpandLevPoly', normal, compile_and_run, ['']) +test('TestTypeableBinary', normal, compile_and_run, ['']) +test('Typeable1', normal, compile_fail, ['']) +test('TypeableEq', normal, compile_and_run, ['']) |