diff options
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, ['']) |