Type-indexed Typeable
authorBen Gamari <ben@smart-cactus.org>
Thu, 2 Feb 2017 06:29:26 +0000 (01:29 -0500)
committerBen Gamari <ben@smart-cactus.org>
Sat, 18 Feb 2017 05:09:27 +0000 (00:09 -0500)
This at long last realizes the ideas for type-indexed Typeable discussed in A
Reflection on Types (#11011). The general sketch of the project is described on
the Wiki (Typeable/BenGamari). The general idea is that we are adding a type
index to `TypeRep`,

    data TypeRep (a :: k)

This index allows the typechecker to reason about the type represented by the `TypeRep`.
This index representation mechanism is exposed as `Type.Reflection`, which also provides
a number of patterns for inspecting `TypeRep`s,

```lang=haskell
pattern TRFun :: forall k (fun :: k). ()
              => forall (r1 :: RuntimeRep) (r2 :: RuntimeRep)
                        (arg :: TYPE r1) (res :: TYPE r2).
                 (k ~ Type, fun ~~ (arg -> res))
              => TypeRep arg
              -> TypeRep res
              -> TypeRep fun

pattern TRApp :: forall k2 (t :: k2). ()
              => forall k1 (a :: k1 -> k2) (b :: k1). (t ~ a b)
              => TypeRep a -> TypeRep b -> TypeRep t

-- | Pattern match on a type constructor.
pattern TRCon :: forall k (a :: k). TyCon -> TypeRep a

-- | Pattern match on a type constructor including its instantiated kind
-- variables.
pattern TRCon' :: forall k (a :: k). TyCon -> [SomeTypeRep] -> TypeRep a
```

In addition, we give the user access to the kind of a `TypeRep` (#10343),

    typeRepKind :: TypeRep (a :: k) -> TypeRep k

Moreover, all of this plays nicely with 8.2's levity polymorphism, including the
newly levity polymorphic (->) type constructor.

Library changes
---------------

The primary change here is the introduction of a Type.Reflection module to base.
This module provides access to the new type-indexed TypeRep introduced in this
patch. We also continue to provide the unindexed Data.Typeable interface, which
is simply a type synonym for the existentially quantified SomeTypeRep,

    data SomeTypeRep where SomeTypeRep :: TypeRep a -> SomeTypeRep

Naturally, this change also touched Data.Dynamic, which can now export the
Dynamic data constructor. Moreover, I removed a blanket reexport of
Data.Typeable from Data.Dynamic (which itself doesn't even import Data.Typeable
now).

We also add a kind heterogeneous type equality type, (:~~:), to
Data.Type.Equality.

Implementation
--------------

The implementation strategy is described in Note [Grand plan for Typeable] in
TcTypeable. None of it was difficult, but it did exercise a number of parts of
the new levity polymorphism story which had not yet been exercised, which took
some sorting out.

The rough idea is that we augment the TyCon produced for each type constructor
with information about the constructor's kind (which we call a KindRep). This
allows us to reconstruct the monomorphic result kind of an particular
instantiation of a type constructor given its kind arguments.

Unfortunately all of this takes a fair amount of work to generate and send
through the compilation pipeline. In particular, the KindReps can unfortunately
get quite large. Moreover, the simplifier will float out various pieces of them,
resulting in numerous top-level bindings. Consequently we mark the KindRep
bindings as noinline, ensuring that the float-outs don't make it into the
interface file. This is important since there is generally little benefit to
inlining KindReps and they would otherwise strongly affect compiler performance.

Performance
-----------

Initially I was hoping to also clear up the remaining holes in Typeable's
coverage by adding support for both unboxed tuples (#12409) and unboxed sums
(#13276). While the former was fairly straightforward, the latter ended up being
quite difficult: while the implementation can support them easily, enabling this
support causes thousands of Typeable bindings to be emitted to the GHC.Types as
each arity-N sum tycon brings with it N promoted datacons, each of which has a
KindRep whose size which itself scales with N. Doing this was simply too
expensive to be practical; consequently I've disabled support for the time
being.

Even after disabling sums this change regresses compiler performance far more
than I would like. In particular there are several testcases in the testsuite
which consist mostly of types which regress by over 30% in compiler allocations.
These include (considering the "bytes allocated" metric),

 * T1969:  +10%
 * T10858: +23%
 * T3294:  +19%
 * T5631:  +41%
 * T6048:  +23%
 * T9675:  +20%
 * T9872a: +5.2%
 * T9872d: +12%
 * T9233:  +10%
 * T10370: +34%
 * T12425: +30%
 * T12234: +16%
 * 13035:  +17%
 * T4029:  +6.1%

I've spent quite some time chasing down the source of this regression and while
I was able to make som improvements, I think this approach of generating
Typeable bindings at time of type definition is doomed to give us unnecessarily
large compile-time overhead.

In the future I think we should consider moving some of all of the Typeable
binding generation logic back to the solver (where it was prior to
91c6b1f54aea658b0056caec45655475897f1972). I've opened #13261 documenting this
proposal.

79 files changed:
compiler/backpack/RnModIface.hs
compiler/basicTypes/MkId.hs
compiler/basicTypes/OccName.hs
compiler/coreSyn/CoreLint.hs
compiler/deSugar/DsBinds.hs
compiler/prelude/KnownUniques.hs
compiler/prelude/PrelNames.hs
compiler/prelude/THNames.hs
compiler/prelude/TysWiredIn.hs
compiler/rename/RnSource.hs
compiler/typecheck/TcBackpack.hs
compiler/typecheck/TcEvidence.hs
compiler/typecheck/TcHsSyn.hs
compiler/typecheck/TcInteract.hs
compiler/typecheck/TcRnDriver.hs
compiler/typecheck/TcTypeable.hs
compiler/types/Kind.hs
compiler/types/TyCon.hs
compiler/types/Type.hs
compiler/types/Type.hs-boot
compiler/utils/Binary.hs
compiler/utils/Fingerprint.hsc
libraries/base/Data/Dynamic.hs
libraries/base/Data/Type/Equality.hs
libraries/base/Data/Typeable.hs
libraries/base/Data/Typeable/Internal.hs
libraries/base/GHC/Conc/Sync.hs
libraries/base/GHC/Show.hs
libraries/base/Type/Reflection.hs [new file with mode: 0644]
libraries/base/Type/Reflection/Unsafe.hs [new file with mode: 0644]
libraries/base/base.cabal
libraries/base/changelog.md
libraries/base/tests/T11334a.stdout
libraries/base/tests/all.T
libraries/base/tests/dynamic002.hs
libraries/base/tests/dynamic002.stdout
libraries/base/tests/dynamic004.hs
libraries/ghc-boot/GHC/Serialized.hs
libraries/ghc-prim/GHC/Classes.hs
libraries/ghc-prim/GHC/Types.hs
libraries/ghci/GHCi/Message.hs
libraries/ghci/GHCi/TH/Binary.hs
testsuite/tests/deSugar/should_compile/T2431.stderr
testsuite/tests/dependent/should_compile/RaeJobTalk.hs
testsuite/tests/dependent/should_compile/T11711.hs
testsuite/tests/dependent/should_compile/dynamic-paper.hs
testsuite/tests/deriving/perf/all.T
testsuite/tests/ghci.debugger/scripts/print019.stderr
testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr
testsuite/tests/patsyn/should_compile/T12698.hs
testsuite/tests/perf/compiler/all.T
testsuite/tests/perf/haddock/all.T
testsuite/tests/perf/should_run/all.T
testsuite/tests/perf/space_leaks/all.T
testsuite/tests/polykinds/T8132.hs
testsuite/tests/polykinds/T8132.stderr
testsuite/tests/roles/should_compile/Roles1.stderr
testsuite/tests/roles/should_compile/Roles13.stderr
testsuite/tests/roles/should_compile/Roles14.stderr
testsuite/tests/roles/should_compile/Roles2.stderr
testsuite/tests/roles/should_compile/Roles3.stderr
testsuite/tests/roles/should_compile/Roles4.stderr
testsuite/tests/roles/should_compile/T8958.stderr
testsuite/tests/safeHaskell/unsafeLibs/GoodImport03.hs
testsuite/tests/simplCore/should_compile/T7360.stderr
testsuite/tests/simplCore/should_compile/T8274.stdout
testsuite/tests/th/TH_Roles2.stderr
testsuite/tests/typecheck/should_compile/tc167.hs
testsuite/tests/typecheck/should_fail/TcStaticPointersFail02.stderr
testsuite/tests/typecheck/should_run/TestTypeableBinary.hs [new file with mode: 0644]
testsuite/tests/typecheck/should_run/TestTypeableBinary.stdout [new file with mode: 0644]
testsuite/tests/typecheck/should_run/TypeOf.stdout
testsuite/tests/typecheck/should_run/TypeRep.hs
testsuite/tests/typecheck/should_run/TypeRep.stdout
testsuite/tests/typecheck/should_run/Typeable1.hs [new file with mode: 0644]
testsuite/tests/typecheck/should_run/Typeable1.stderr [new file with mode: 0644]
testsuite/tests/typecheck/should_run/TypeableEq.hs [new file with mode: 0644]
testsuite/tests/typecheck/should_run/TypeableEq.stdout [new file with mode: 0644]
testsuite/tests/typecheck/should_run/all.T

index d77d061..1b11a0f 100644 (file)
@@ -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)
index 65860d9..8a204be 100644 (file)
@@ -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
index 0de9801..cde7cc5 100644 (file)
@@ -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,
index 2f34046..4aa7d44 100644 (file)
@@ -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
 
index b367d69..efe3e7a 100644 (file)
@@ -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
index 2dc6f83..8f1b0b6 100644 (file)
@@ -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]
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
index 47b78f1..470b736 100644 (file)
@@ -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
index 253a89b..1b9e624 100644 (file)
@@ -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
 
 {- *********************************************************************
 *                                                                      *
index 0eeb5e3..85771a0 100644 (file)
@@ -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)
index 65acf80..3e46274 100644 (file)
@@ -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,
index a2e5abe..2b4b05c 100644 (file)
@@ -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:
index 2de2223..4455c9b 100644 (file)
@@ -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
 
 
index 6061ecc..6ad2b28 100644 (file)
@@ -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') }
index e01bd64..e1ad484 100644 (file)
@@ -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]
index 05ed92a..082b2fd 100644 (file)
@@ -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 ()
index 86d1d1c..e7fe588 100644 (file)
@@ -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)
index b67eec0..5fd17f9 100644 (file)
@@ -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
index 1b80d20..7140009 100644 (file)
@@ -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
index a50b76b..460eb5e 100644 (file)
@@ -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
index 9436d19..560c251 100644 (file)
@@ -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])
index ffd1eb2..b10ab1d 100644 (file)
@@ -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
index f797654..d4cee0e 100644 (file)
@@ -15,6 +15,7 @@ module Fingerprint (
         fingerprintByteString,
         -- * Re-exported from GHC.Fingerprint
         Fingerprint(..), fingerprint0,
+        fingerprintFingerprints,
         fingerprintData,
         fingerprintString,
         getFileHash
index 218bdc1..5a4f3f9 100644 (file)
@@ -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
index 2330200..73f8407 100644 (file)
@@ -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.
index d722519..8a6422e 100644 (file)
@@ -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
 --
 -- == 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
 -----------------------------------------------------------------------------
 
 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
index 7746bfb..800dc2a 100644 (file)
@@ -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 #-}
 -----------------------------------------------------------------------------
 
 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]
index a9629c4..e8823e5 100644 (file)
@@ -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
index 46fc8fe..510c655 100644 (file)
@@ -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 (file)
index 0000000..37efcba
--- /dev/null
@@ -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 (file)
index 0000000..4e367f5
--- /dev/null
@@ -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
index 49e23e5..2649173 100644 (file)
@@ -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
index aa7302d..fd8f188 100644 (file)
     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
index caeb85b..c2d860d 100644 (file)
@@ -1,3 +1,3 @@
-Proxy (* -> Maybe *) 'Just
+Proxy (* -> Maybe *) ('Just *)
 Proxy * *
 Proxy * (TYPE 'UnliftedRep)
index 8e5125f..7125b63 100644 (file)
@@ -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, [''])
index 6d53d2e..3904b45 100644 (file)
@@ -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
index 8b55566..2426682 100644 (file)
@@ -28,7 +28,7 @@ ST () ()
 StableName ()
 StablePtr ()
 TyCon
-TypeRep
+SomeTypeRep
 Word8
 Word16
 Word32
index e6b7a82..2091646 100644 (file)
@@ -1,7 +1,6 @@
 module Main where
 
 import Data.Typeable
-import Data.Typeable.Internal
 import GHC.Fingerprint
 import Text.Printf
 
index fbb9684..42a9604 100644 (file)
@@ -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]
index 5fa118a..3fd4bc0 100644 (file)
@@ -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
index c913af6..a4b7a91 100644 (file)
@@ -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
index 71da228..80a495f 100644 (file)
@@ -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
index e930956..fcff168 100644 (file)
@@ -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)
index 8382640..d601d5d 100644 (file)
@@ -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
 
 
 
index e5c2002..480db09 100644 (file)
@@ -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) ->
index 633ae35..0cd4dce 100644 (file)
@@ -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
 
index 0d55bba..1aa4ee5 100644 (file)
@@ -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
 
index 4c4bb97..8dee989 100644 (file)
@@ -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'])
index cc62fa1..c266bc8 100644 (file)
@@ -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
index fe7b8bf..c7db52a 100644 (file)
          ({ <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})} 
          ({ <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})} 
          ({ <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})} 
index 6ba45e4..27d54d8 100644 (file)
@@ -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
 
index 5f898fb..24b03d0 100644 (file)
@@ -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,
index 4c641d5..a148b71 100644 (file)
@@ -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)
index 4bd75f7..27d8df8 100644 (file)
@@ -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)
index a58ae2c..76ad7a7 100644 (file)
@@ -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,
index 337e288..cdbfd7f 100644 (file)
@@ -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
index c5f56f9..a1aaa13 100644 (file)
@@ -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’
index bb67a8c..a81e7c0 100644 (file)
@@ -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"#)
index 7e510d4..f336a69 100644 (file)
@@ -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
 
 
 
index 8604b00..61d0a59 100644 (file)
@@ -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"#)
index cea02f5..7a795a3 100644 (file)
@@ -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"#)
index 1541f89..5d3c38c 100644 (file)
@@ -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"#)
index 49e9ac9..989d77a 100644 (file)
@@ -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"#)
index a527d1f..52bfa27 100644 (file)
@@ -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"#)
index 84e728f..edd6d65 100644 (file)
@@ -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
index e3fea9b..bf2c6df 100644 (file)
@@ -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
 
 
 
index df8253f..90d5ceb 100644 (file)
@@ -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
index 33fec8e..7b872aa 100644 (file)
@@ -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"#)
index b42ceac..7730750 100644 (file)
@@ -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]
index e6e637c..fd6be80 100644 (file)
@@ -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 (file)
index 0000000..e427c13
--- /dev/null
@@ -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 (file)
index 0000000..515738e
--- /dev/null
@@ -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
index 99f113c..3c125fe 100644 (file)
@@ -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)
index 5fbf909..002e4fb 100644 (file)
@@ -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
index 09b4cea..8f5d3fb 100644 (file)
@@ -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 (file)
index 0000000..02a7ebb
--- /dev/null
@@ -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 (file)
index 0000000..9a7d3b7
--- /dev/null
@@ -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 (file)
index 0000000..6fe6aa7
--- /dev/null
@@ -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 (file)
index 0000000..bff6d9e
--- /dev/null
@@ -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])?
index eab9f8a..c44a23e 100755 (executable)
@@ -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, [''])