Cache TypeRep kinds aggressively
authorDavid Feuer <david.feuer@gmail.com>
Fri, 1 Dec 2017 22:00:24 +0000 (17:00 -0500)
committerDavid Feuer <David.Feuer@gmail.com>
Fri, 1 Dec 2017 22:00:25 +0000 (17:00 -0500)
Cache `TypeRep k` in each `TrApp` or `TrTyCon` constructor of
`TypeRep (a :: k)`. This makes `typeRepKind` cheap.

With this change, we won't need any special effort to deserialize
typereps efficiently. The downside, of course, is that we make
`TypeRep`s slightly larger.

Reviewers: austin, hvr, bgamari, simonpj

Reviewed By: bgamari, simonpj

Subscribers: carter, simonpj, rwbarton, thomie

GHC Trac Issues: #14254

Differential Revision: https://phabricator.haskell.org/D4085

12 files changed:
compiler/deSugar/DsBinds.hs
compiler/prelude/PrelNames.hs
compiler/typecheck/TcTypeable.hs
libraries/base/Data/Typeable/Internal.hs
libraries/base/GHC/Show.hs
libraries/base/Type/Reflection/Unsafe.hs
testsuite/tests/ghci.debugger/scripts/break006.stderr
testsuite/tests/ghci.debugger/scripts/print019.stderr
testsuite/tests/indexed-types/should_fail/T12522a.stderr
testsuite/tests/overloadedlists/should_fail/overloadedlistsfail01.stderr
testsuite/tests/typecheck/should_compile/holes2.stderr
testsuite/tests/typecheck/should_fail/tcfail133.stderr

index e11f580..3048871 100644 (file)
@@ -1239,10 +1239,12 @@ ds_ev_typeable ty (EvTypeableTyCon tc kind_ev)
          -- 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 ]
+       ; let expr = mkApps (Var mkTrCon) [ Type (typeKind ty)
+                                         , Type ty
+                                         , tc_rep
+                                         , kind_args ]
+       -- ; pprRuntimeTrace "Trace mkTrTyCon" (ppr expr) expr
+       ; return expr
        }
 
 ds_ev_typeable ty (EvTypeableTyApp ev1 ev2)
@@ -1253,8 +1255,11 @@ ds_ev_typeable ty (EvTypeableTyApp ev1 ev2)
                     -- 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 ] }
+       ; let expr =  mkApps (mkTyApps (Var mkTrApp) [ k1, k2, t1, t2 ])
+                            [ e1, e2 ]
+       -- ; pprRuntimeTrace "Trace mkTrApp" (ppr expr) expr
+       ; return expr
+       }
 
 ds_ev_typeable ty (EvTypeableTrFun ev1 ev2)
   | Just (t1,t2) <- splitFunTy_maybe ty
index f418348..47b1465 100644 (file)
@@ -240,6 +240,7 @@ basicKnownKeyNames
         typeLitSymbolDataConName,
         typeLitNatDataConName,
         typeRepIdName,
+        mkTrTypeName,
         mkTrConName,
         mkTrAppName,
         mkTrFunName,
@@ -1256,6 +1257,7 @@ typeableClassName
   , typeRepTyConName
   , someTypeRepTyConName
   , someTypeRepDataConName
+  , mkTrTypeName
   , mkTrConName
   , mkTrAppName
   , mkTrFunName
@@ -1269,6 +1271,7 @@ typeRepTyConName      = tcQual  tYPEABLE_INTERNAL (fsLit "TypeRep")        typeR
 someTypeRepTyConName   = tcQual tYPEABLE_INTERNAL (fsLit "SomeTypeRep")    someTypeRepTyConKey
 someTypeRepDataConName = dcQual tYPEABLE_INTERNAL (fsLit "SomeTypeRep")    someTypeRepDataConKey
 typeRepIdName         = varQual tYPEABLE_INTERNAL (fsLit "typeRep#")       typeRepIdKey
+mkTrTypeName          = varQual tYPEABLE_INTERNAL (fsLit "mkTrType")       mkTrTypeKey
 mkTrConName           = varQual tYPEABLE_INTERNAL (fsLit "mkTrCon")        mkTrConKey
 mkTrAppName           = varQual tYPEABLE_INTERNAL (fsLit "mkTrApp")        mkTrAppKey
 mkTrFunName           = varQual tYPEABLE_INTERNAL (fsLit "mkTrFun")        mkTrFunKey
@@ -2329,6 +2332,7 @@ proxyHashKey = mkPreludeMiscIdUnique 502
 
 -- Used to make `Typeable` dictionaries
 mkTyConKey
+  , mkTrTypeKey
   , mkTrConKey
   , mkTrAppKey
   , mkTrFunKey
@@ -2337,12 +2341,13 @@ mkTyConKey
   , typeRepIdKey
   :: Unique
 mkTyConKey            = mkPreludeMiscIdUnique 503
-mkTrConKey            = mkPreludeMiscIdUnique 504
-mkTrAppKey            = mkPreludeMiscIdUnique 505
-typeNatTypeRepKey     = mkPreludeMiscIdUnique 506
-typeSymbolTypeRepKey  = mkPreludeMiscIdUnique 507
-typeRepIdKey          = mkPreludeMiscIdUnique 508
-mkTrFunKey            = mkPreludeMiscIdUnique 509
+mkTrTypeKey           = mkPreludeMiscIdUnique 504
+mkTrConKey            = mkPreludeMiscIdUnique 505
+mkTrAppKey            = mkPreludeMiscIdUnique 506
+typeNatTypeRepKey     = mkPreludeMiscIdUnique 507
+typeSymbolTypeRepKey  = mkPreludeMiscIdUnique 508
+typeRepIdKey          = mkPreludeMiscIdUnique 509
+mkTrFunKey            = mkPreludeMiscIdUnique 510
 
 -- Representations for primitive types
 trTYPEKey
@@ -2350,10 +2355,10 @@ trTYPEKey
   , trRuntimeRepKey
   , tr'PtrRepLiftedKey
   :: Unique
-trTYPEKey              = mkPreludeMiscIdUnique 510
-trTYPE'PtrRepLiftedKey = mkPreludeMiscIdUnique 511
-trRuntimeRepKey        = mkPreludeMiscIdUnique 512
-tr'PtrRepLiftedKey     = mkPreludeMiscIdUnique 513
+trTYPEKey              = mkPreludeMiscIdUnique 511
+trTYPE'PtrRepLiftedKey = mkPreludeMiscIdUnique 512
+trRuntimeRepKey        = mkPreludeMiscIdUnique 513
+tr'PtrRepLiftedKey     = mkPreludeMiscIdUnique 514
 
 -- KindReps for common cases
 starKindRepKey, starArrStarKindRepKey, starArrStarArrStarKindRepKey :: Unique
index ed4b548..6fa875b 100644 (file)
@@ -655,17 +655,20 @@ The TypeRep encoding of `Proxy Type Int` looks like this:
 
     $tcProxy :: GHC.Types.TyCon
     $trInt   :: TypeRep Int
-    $trType  :: TypeRep Type
+    TrType   :: TypeRep Type
 
     $trProxyType :: TypeRep (Proxy Type :: Type -> Type)
     $trProxyType = TrTyCon $tcProxy
-                           [$trType]  -- kind variable instantiation
+                           [TrType]  -- kind variable instantiation
+                           (tyConKind $tcProxy [TrType]) -- The TypeRep of
+                                                         -- Type -> Type
 
     $trProxy :: TypeRep (Proxy Type Int)
-    $trProxy = TrApp $trProxyType $trInt
+    $trProxy = TrApp $trProxyType $trInt TrType
 
     $tkProxy :: GHC.Types.KindRep
-    $tkProxy = KindRepFun (KindRepVar 0) (KindRepTyConApp $trType [])
+    $tkProxy = KindRepFun (KindRepVar 0)
+                          (KindRepTyConApp (KindRepTYPE LiftedRep) [])
 
 Note how $trProxyType cannot use 'TrApp', because TypeRep cannot represent
 polymorphic types.  So instead
@@ -679,9 +682,10 @@ polymorphic types.  So instead
        Proxy :: forall k. k->Type
 
  * A KindRep is just a recipe that we can instantiate with the
-   argument kinds, using Data.Typeable.Internal.instantiateKindRep.
+   argument kinds, using Data.Typeable.Internal.tyConKind and
+   store in the relevant 'TypeRep' constructor.
 
-   Data.Typeable.Internal.typeRepKind uses instantiateKindRep
+   Data.Typeable.Internal.typeRepKind looks up the stored kinds.
 
  * In a KindRep, the kind variables are represented by 0-indexed
    de Bruijn numbers:
index 221dfb5..d2ed9d1 100644 (file)
@@ -75,7 +75,7 @@ module Data.Typeable.Internal (
 
     -- * Construction
     -- | These are for internal use only
-    mkTrCon, mkTrApp, mkTrFun,
+    mkTrType, mkTrCon, mkTrApp, mkTrAppChecked, mkTrFun,
     mkTyCon, mkTyCon#,
     typeSymbolTypeRep, typeNatTypeRep,
   ) where
@@ -97,6 +97,7 @@ import {-# SOURCE #-} GHC.Fingerprint
    -- Better to break the loop here, because we want non-SOURCE imports
    -- of Data.Typeable as much as possible so we can optimise the derived
    -- instances.
+-- import {-# SOURCE #-} Debug.Trace (trace)
 
 #include "MachDeps.h"
 
@@ -178,6 +179,8 @@ rnfTyCon (TyCon _ _ m n _ k) = rnfModule m `seq` rnfTrName n `seq` rnfKindRep k
 -- | A concrete representation of a (monomorphic) type.
 -- 'TypeRep' supports reasonably efficient equality.
 data TypeRep (a :: k) where
+    -- The TypeRep of Type. See Note [Kind caching], Wrinkle 2
+    TrType :: TypeRep Type
     TrTyCon :: { -- See Note [TypeRep fingerprints]
                  trTyConFingerprint :: {-# UNPACK #-} !Fingerprint
 
@@ -186,7 +189,8 @@ data TypeRep (a :: k) where
                  -- 'Just :: Bool -> Maybe Bool, the trTyCon will be
                  -- 'Just and the trKindVars will be [Bool].
                , trTyCon :: !TyCon
-               , trKindVars :: [SomeTypeRep] }
+               , trKindVars :: [SomeTypeRep]
+               , trTyConKind :: !(TypeRep k) }  -- See Note [Kind caching]
             -> TypeRep (a :: k)
 
     -- | Invariant: Saturated arrow types (e.g. things of the form @a -> b@)
@@ -198,8 +202,9 @@ data TypeRep (a :: k) where
                  -- The TypeRep represents the application of trAppFun
                  -- to trAppArg. For Maybe Int, the trAppFun will be Maybe
                  -- and the trAppArg will be Int.
-               , trAppFun :: TypeRep (a :: k1 -> k2)
-               , trAppArg :: TypeRep (b :: k1) }
+               , trAppFun :: !(TypeRep (a :: k1 -> k2))
+               , trAppArg :: !(TypeRep (b :: k1))
+               , trAppKind :: !(TypeRep k2) }   -- See Note [Kind caching]
             -> TypeRep (a b)
 
     -- | @TrFun fpr a b@ represents a function type @a -> b@. We use this for
@@ -211,8 +216,8 @@ data TypeRep (a :: k) where
 
                  -- The TypeRep represents a function from trFunArg to
                  -- trFunRes.
-               , trFunArg :: TypeRep a
-               , trFunRes :: TypeRep b }
+               , trFunArg :: !(TypeRep a)
+               , trFunRes :: !(TypeRep b) }
             -> TypeRep (a -> b)
 
 {- Note [TypeRep fingerprints]
@@ -222,6 +227,63 @@ us to test whether two TypeReps are equal in constant time, rather than
 having to walk their full structures.
 -}
 
+{- Note [Kind caching]
+   ~~~~~~~~~~~~~~~~~~~
+
+We cache the kind of the TypeRep in each TrTyCon and TrApp constructor.
+This is necessary to ensure that typeRepKind (which is used, at least, in
+deserialization and dynApply) is cheap. There are two reasons for this:
+
+1. Calculating the kind of a nest of type applications, such as
+
+  F X Y Z W   (App (App (App (App F X) Y) Z) W)
+
+is linear in the depth, which is already a bit pricy. In deserialization,
+we build up such a nest from the inside out, so without caching, that ends
+up taking quadratic time, and calculating the KindRep of the constructor,
+F, a linear number of times. See #14254.
+
+2. Calculating the kind of a type constructor, in instantiateTypeRep,
+requires building (allocating) a TypeRep for the kind "from scratch".
+This can get pricy. When combined with point (1), we can end up with
+a large amount of extra allocation deserializing very deep nests.
+See #14337.
+
+It is quite possible to speed up deserialization by structuring that process
+very carefully. Unfortunately, that doesn't help dynApply or anything else
+that may use typeRepKind. Since caching the kind isn't terribly expensive, it
+seems better to just do that and solve all the potential problems at once.
+
+There are two things we need to be careful about when caching kinds.
+
+Wrinkle 1:
+
+We want to do it eagerly. Suppose we have
+
+  tf :: TypeRep (f :: j -> k)
+  ta :: TypeRep (a :: j)
+
+Then the cached kind of App tf ta should be eagerly evaluated to k, rather
+than being stored as a thunk that will strip the (j ->) off of j -> k if
+and when it is forced.
+
+Wrinkle 2:
+
+We need to be able to represent TypeRep Type. This is a bit tricky because
+typeRepKind (typeRep @Type) = typeRep @Type, so if we actually cache the
+typerep of the kind of Type, we will have a loop. One simple way to do this
+is to make the cached kind fields lazy and allow TypeRep Type to be cyclical.
+
+But we *do not* want TypeReps to have cyclical structure! Most importantly,
+a cyclical structure cannot be stored in a compact region. Secondarily,
+using :force in GHCi on a cyclical structure will lead to non-termination.
+
+To avoid this trouble, we use a separate constructor for TypeRep Type.
+mkTrApp is responsible for recognizing that TYPE is being applied to
+'LiftedRep and produce trType; other functions must recognize that TrType
+represents an application.
+-}
+
 -- Compare keys for equality
 
 -- | @since 2.01
@@ -278,10 +340,15 @@ pattern Fun arg res <- TrFun {trFunArg = arg, trFunRes = res}
 --
 -- @since 4.8.0.0
 typeRepFingerprint :: TypeRep a -> Fingerprint
+typeRepFingerprint TrType = fpTYPELiftedRep
 typeRepFingerprint (TrTyCon {trTyConFingerprint = fpr}) = fpr
 typeRepFingerprint (TrApp {trAppFingerprint = fpr}) = fpr
 typeRepFingerprint (TrFun {trFunFingerprint = fpr}) = fpr
 
+-- For compiler use
+mkTrType :: TypeRep Type
+mkTrType = TrType
+
 -- | Construct a representation for a type constructor
 -- applied at a monomorphic kind.
 --
@@ -292,39 +359,74 @@ mkTrCon tc kind_vars = TrTyCon
     { trTyConFingerprint = fpr
     , trTyCon = tc
     , trKindVars = kind_vars
-    }
+    , trTyConKind = kind }
   where
     fpr_tc  = tyConFingerprint tc
     fpr_kvs = map someTypeRepFingerprint kind_vars
     fpr     = fingerprintFingerprints (fpr_tc:fpr_kvs)
+    kind    = unsafeCoerceRep $ tyConKind tc kind_vars
+
+-- The fingerprint of Type. We don't store this in the TrType
+-- constructor, so we need to build it here.
+fpTYPELiftedRep :: Fingerprint
+fpTYPELiftedRep = fingerprintFingerprints
+      [tyConFingerprint tyConTYPE, typeRepFingerprint trLiftedRep]
+-- There is absolutely nothing to gain and everything to lose
+-- by inlining the worker. The wrapper should inline anyway.
+{-# NOINLINE fpTYPELiftedRep #-}
+
+trTYPE :: TypeRep TYPE
+trTYPE = typeRep
 
--- | Construct a representation for a type application.
+trLiftedRep :: TypeRep 'LiftedRep
+trLiftedRep = typeRep
+
+-- | Construct a representation for a type application that is
+-- NOT a saturated arrow type. This is not checked!
 
 -- Note that this is known-key to the compiler, which uses it in desugar
--- 'Typeable' evidence. See Note [Kind caching]
+-- 'Typeable' evidence.
 mkTrApp :: forall k1 k2 (a :: k1 -> k2) (b :: k1).
            TypeRep (a :: k1 -> k2)
         -> TypeRep (b :: k1)
         -> TypeRep (a b)
-mkTrApp rep@(TrApp {trAppFun = p, trAppArg = x :: TypeRep x}) (y :: TypeRep y)
-  | TrTyCon {trTyCon=con} <- p
-  , con == funTyCon  -- cheap check first
-  , Just (IsTYPE (rx :: TypeRep rx)) <- isTYPE (typeRepKind x)
-  , Just (IsTYPE (ry :: TypeRep ry)) <- isTYPE (typeRepKind y)
-  , Just HRefl <- withTypeable x $ withTypeable rx $ withTypeable ry
-                  $ typeRep @((->) x :: TYPE ry -> Type) `eqTypeRep` rep
-  = mkTrFun x y
-mkTrApp a b = TrApp
+mkTrApp a b -- See Note [Kind caching], Wrinkle 2
+  | Just HRefl <- a `eqTypeRep` trTYPE
+  , Just HRefl <- b `eqTypeRep` trLiftedRep
+  = TrType
+
+  | TrFun {trFunRes = res_kind} <- typeRepKind a
+  = TrApp
     { trAppFingerprint = fpr
     , trAppFun = a
     , trAppArg = b
-    }
+    , trAppKind = res_kind }
 
+  | otherwise = error ("Ill-kinded type application: "
+                           ++ show (typeRepKind a))
   where
     fpr_a = typeRepFingerprint a
     fpr_b = typeRepFingerprint b
     fpr   = fingerprintFingerprints [fpr_a, fpr_b]
 
+-- | Construct a representation for a type application that
+-- may be a saturated arrow type. This is renamed to mkTrApp in
+-- Type.Reflection.Unsafe
+mkTrAppChecked :: forall k1 k2 (a :: k1 -> k2) (b :: k1).
+                  TypeRep (a :: k1 -> k2)
+               -> TypeRep (b :: k1)
+               -> TypeRep (a b)
+mkTrAppChecked rep@(TrApp {trAppFun = p, trAppArg = x :: TypeRep x})
+               (y :: TypeRep y)
+  | TrTyCon {trTyCon=con} <- p
+  , con == funTyCon  -- cheap check first
+  , Just (IsTYPE (rx :: TypeRep rx)) <- isTYPE (typeRepKind x)
+  , Just (IsTYPE (ry :: TypeRep ry)) <- isTYPE (typeRepKind y)
+  , Just HRefl <- withTypeable x $ withTypeable rx $ withTypeable ry
+                  $ typeRep @((->) x :: TYPE ry -> Type) `eqTypeRep` rep
+  = mkTrFun x y
+mkTrAppChecked a b = mkTrApp a b
+
 -- | A type application.
 --
 -- For instance,
@@ -347,7 +449,7 @@ 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 <- (splitApp -> Just (IsApp f x))
-  where App f x = mkTrApp f x
+  where App f x = mkTrAppChecked f x
 
 data IsApp (a :: k) where
     IsApp :: forall k k' (f :: k' -> k) (x :: k'). ()
@@ -356,6 +458,7 @@ data IsApp (a :: k) where
 splitApp :: forall k (a :: k). ()
          => TypeRep a
          -> Maybe (IsApp a)
+splitApp TrType = Just (IsApp trTYPE trLiftedRep)
 splitApp (TrApp {trAppFun = f, trAppArg = x}) = Just (IsApp f x)
 splitApp rep@(TrFun {trFunArg=a, trFunRes=b}) = Just (IsApp (mkTrApp arr a) b)
   where arr = bareArrow rep
@@ -407,6 +510,7 @@ someTypeRepTyCon (SomeTypeRep t) = typeRepTyCon t
 
 -- | Observe the type constructor of a type representation
 typeRepTyCon :: TypeRep a -> TyCon
+typeRepTyCon TrType = tyConTYPE
 typeRepTyCon (TrTyCon {trTyCon = tc}) = tc
 typeRepTyCon (TrApp {trAppFun = a})   = typeRepTyCon a
 typeRepTyCon (TrFun {})               = typeRepTyCon $ typeRep @(->)
@@ -429,15 +533,10 @@ eqTypeRep a b
 
 -- | Observe the kind of a type.
 typeRepKind :: TypeRep (a :: k) -> TypeRep k
-typeRepKind (TrTyCon {trTyCon = tc, trKindVars = args})
-  = unsafeCoerceRep $ tyConKind tc args
-typeRepKind (TrApp {trAppFun = f})
-  | TrFun {trFunRes = res} <- typeRepKind f
-  = res
-  | otherwise
-  = error ("Ill-kinded type application: " ++ show (typeRepKind f))
-typeRepKind (TrFun {})
-  = typeRep @Type
+typeRepKind TrType = TrType
+typeRepKind (TrTyCon {trTyConKind = kind}) = kind
+typeRepKind (TrApp {trAppKind = kind}) = kind
+typeRepKind (TrFun {}) = typeRep @Type
 
 tyConKind :: TyCon -> [SomeTypeRep] -> SomeTypeRep
 tyConKind (TyCon _ _ _ _ nKindVars# kindRep) kindVars =
@@ -458,7 +557,7 @@ instantiateKindRep vars = go
             applyTy :: SomeTypeRep -> KindRep -> SomeTypeRep
             applyTy (SomeTypeRep acc) ty
               | SomeTypeRep ty' <- go ty
-              = SomeTypeRep $ mkTrApp (unsafeCoerce acc) (unsafeCoerce ty')
+              = SomeTypeRep $ mkTrApp (unsafeCoerce acc) ty'
         in foldl' applyTy tycon_app ty_args
     go (KindRepVar var)
       = vars A.! var
@@ -466,6 +565,7 @@ instantiateKindRep vars = go
       = SomeTypeRep $ mkTrApp (unsafeCoerceRep $ go f) (unsafeCoerceRep $ go a)
     go (KindRepFun a b)
       = SomeTypeRep $ mkTrFun (unsafeCoerceRep $ go a) (unsafeCoerceRep $ go b)
+    go (KindRepTYPE LiftedRep) = SomeTypeRep TrType
     go (KindRepTYPE r) = unkindedTypeRep $ tYPE `kApp` runtimeRepTypeRep r
     go (KindRepTypeLitS sort s)
       = mkTypeLitFromString sort (unpackCStringUtf8# s)
@@ -570,12 +670,14 @@ data IsTYPE (a :: Type) where
 
 -- | Is a type of the form @TYPE rep@?
 isTYPE :: TypeRep (a :: Type) -> Maybe (IsTYPE a)
+isTYPE TrType = Just (IsTYPE trLiftedRep)
 isTYPE (TrApp {trAppFun=f, trAppArg=r})
   | Just HRefl <- f `eqTypeRep` typeRep @TYPE
   = Just (IsTYPE r)
 isTYPE _ = Nothing
 
 getRuntimeRep :: forall (r :: RuntimeRep). TypeRep (TYPE r) -> TypeRep r
+getRuntimeRep TrType = trLiftedRep
 getRuntimeRep (TrApp {trAppArg=r}) = r
 getRuntimeRep _ = error "Data.Typeable.Internal.getRuntimeRep: impossible"
 
@@ -617,9 +719,8 @@ instance Show (TypeRep (a :: k)) where
 
 
 showTypeable :: Int -> TypeRep (a :: k) -> ShowS
+showTypeable _ TrType = showChar '*'
 showTypeable _ rep
-  | Just HRefl <- rep `eqTypeRep` (typeRep :: TypeRep Type) =
-    showChar '*'
   | isListTyCon tc, [ty] <- tys =
     showChar '[' . shows ty . showChar ']'
   | isTupleTyCon tc =
@@ -656,13 +757,33 @@ splitApps = go []
     go [] (TrFun {trFunArg = a, trFunRes = b})
       = (funTyCon, [SomeTypeRep a, SomeTypeRep b])
     go _  (TrFun {})
-      = errorWithoutStackTrace "Data.Typeable.Internal.splitApps: Impossible"
+      = errorWithoutStackTrace "Data.Typeable.Internal.splitApps: Impossible 1"
+    go [] TrType = (tyConTYPE, [SomeTypeRep trLiftedRep])
+    go _ TrType
+      = errorWithoutStackTrace "Data.Typeable.Internal.splitApps: Impossible 2"
+
+-- This is incredibly shady! We don't really want to do this here; we
+-- should really have the compiler reveal the TYPE TyCon directly
+-- somehow. We need to construct this by hand because otherwise
+-- we end up with horrible and somewhat mysterious loops trying to calculate
+-- typeRep @TYPE. For the moment, we use the fact that we can get the proper
+-- name of the ghc-prim package from the TyCon of LiftedRep (which we can
+-- produce a TypeRep for without difficulty), and then just substitute in the
+-- appropriate module and constructor names.
+--
+-- The ticket to find a better way to deal with this is
+-- Trac #14480.
+tyConTYPE :: TyCon
+tyConTYPE = mkTyCon (tyConPackage liftedRepTyCon) "GHC.Prim" "TYPE" 0
+       (KindRepFun (KindRepTyConApp liftedRepTyCon []) (KindRepTYPE LiftedRep))
+  where
+    liftedRepTyCon = typeRepTyCon (typeRep @RuntimeRep)
 
 funTyCon :: TyCon
 funTyCon = typeRepTyCon (typeRep @(->))
 
 isListTyCon :: TyCon -> Bool
-isListTyCon tc = tc == typeRepTyCon (typeRep :: TypeRep [Int])
+isListTyCon tc = tc == typeRepTyCon (typeRep :: TypeRep [])
 
 isTupleTyCon :: TyCon -> Bool
 isTupleTyCon tc
@@ -678,12 +799,11 @@ showArgs sep (a:as) = showsPrec 10 a . sep . showArgs sep as
 --
 -- @since 4.8.0.0
 rnfTypeRep :: TypeRep a -> ()
-rnfTypeRep (TrTyCon {trTyCon = tyc})
-  = rnfTyCon tyc
-rnfTypeRep (TrApp {trAppFun = f, trAppArg = x})
-  = rnfTypeRep f `seq` rnfTypeRep x
-rnfTypeRep (TrFun {trFunArg = x, trFunRes = y})
-  = rnfTypeRep x `seq` rnfTypeRep y
+-- The TypeRep structure is almost entirely strict by definition. The
+-- fingerprinting and strict kind caching ensure that everything
+-- else is forced anyway. So we don't need to do anything special
+-- to reduce to normal form.
+rnfTypeRep !_ = ()
 
 -- | Helper to fully evaluate 'SomeTypeRep' for use as @NFData(rnf)@
 -- implementation
index 980b4a7..d1c6075 100644 (file)
@@ -53,6 +53,8 @@ import GHC.Base
 import GHC.List ((!!), foldr1, break)
 import GHC.Num
 import GHC.Stack.Types
+import GHC.Types (TypeLitSort (..))
+
 
 -- | The @shows@ functions return a function that prepends the
 -- output 'String' to an existing 'String'.  This allows constant-time
@@ -547,3 +549,39 @@ integerToString n0 cs0
              c@(C# _) -> jblock' (d - 1) q (c : cs)
         where
         (q, r) = n `quotRemInt` 10
+
+instance Show KindRep where
+  showsPrec d (KindRepVar v) = showParen (d > 10) $
+    showString "KindRepVar " . showsPrec 11 v
+  showsPrec d (KindRepTyConApp p q) = showParen (d > 10) $
+    showString "KindRepTyConApp "
+      . showsPrec 11 p
+      . showString " "
+      . showsPrec 11 q
+  showsPrec d (KindRepApp p q) = showParen (d > 10) $
+    showString "KindRepApp "
+      . showsPrec 11 p
+      . showString " "
+      . showsPrec 11 q
+  showsPrec d (KindRepFun p q) = showParen (d > 10) $
+    showString "KindRepFun "
+      . showsPrec 11 p
+      . showString " "
+      . showsPrec 11 q
+  showsPrec d (KindRepTYPE rep) = showParen (d > 10) $
+    showString "KindRepTYPE " . showsPrec 11 rep
+  showsPrec d (KindRepTypeLitS p q) = showParen (d > 10) $
+    showString "KindRepTypeLitS "
+      . showsPrec 11 p
+      . showString " "
+      . showsPrec 11 (unpackCString# q)
+  showsPrec d (KindRepTypeLitD p q) = showParen (d > 10) $
+    showString "KindRepTypeLitD "
+      . showsPrec 11 p
+      . showString " "
+      . showsPrec 11 q
+
+deriving instance Show RuntimeRep
+deriving instance Show VecCount
+deriving instance Show VecElem
+deriving instance Show TypeLitSort
index c0f2327..9a8af16 100644 (file)
@@ -12,6 +12,7 @@
 -- type representations.
 --
 -----------------------------------------------------------------------------
+{-# LANGUAGE TypeInType, ScopedTypeVariables #-}
 
 module Type.Reflection.Unsafe (
       -- * Type representations
@@ -22,4 +23,12 @@ module Type.Reflection.Unsafe (
     , TyCon, mkTrCon, tyConKindRep, tyConKindArgs, tyConFingerprint
   ) where
 
-import Data.Typeable.Internal
+import Data.Typeable.Internal hiding (mkTrApp)
+import qualified Data.Typeable.Internal as TI
+
+-- | Construct a representation for a type application.
+mkTrApp :: forall k1 k2 (a :: k1 -> k2) (b :: k1).
+           TypeRep (a :: k1 -> k2)
+        -> TypeRep (b :: k1)
+        -> TypeRep (a b)
+mkTrApp = TI.mkTrAppChecked
index 8bd838d..a9429d9 100644 (file)
@@ -9,7 +9,7 @@
         instance Show Integer -- Defined in ‘GHC.Show’
         instance Show a => Show (Maybe a) -- Defined in ‘GHC.Show’
         ...plus 22 others
-        ...plus 12 instances involving out-of-scope types
+        ...plus 17 instances involving out-of-scope types
         (use -fprint-potential-instances to see them all)
     • In a stmt of an interactive GHCi command: print it
 
@@ -23,6 +23,6 @@
         instance Show Integer -- Defined in ‘GHC.Show’
         instance Show a => Show (Maybe a) -- Defined in ‘GHC.Show’
         ...plus 22 others
-        ...plus 12 instances involving out-of-scope types
+        ...plus 17 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 29d5317..70432f5 100644 (file)
@@ -9,6 +9,6 @@
         instance Show TyCon -- Defined in ‘GHC.Show’
         instance Show Integer -- Defined in ‘GHC.Show’
         ...plus 29 others
-        ...plus 13 instances involving out-of-scope types
+        ...plus 18 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 94ef226..d7a4f06 100644 (file)
@@ -11,7 +11,7 @@ T12522a.hs:20:26: error:
         instance Show Integer -- Defined in ‘GHC.Show’
         instance Show a => Show (Maybe a) -- Defined in ‘GHC.Show’
         ...plus 22 others
-        ...plus six instances involving out-of-scope types
+        ...plus 11 instances involving out-of-scope types
         (use -fprint-potential-instances to see them all)
     • In the first argument of ‘(++)’, namely ‘show n’
       In the second argument of ‘($)’, namely ‘show n ++ s’
index 1c5ab2e..5ece21f 100644 (file)
@@ -8,7 +8,7 @@ overloadedlistsfail01.hs:5:8: error:
         instance Show Integer -- Defined in ‘GHC.Show’
         instance Show a => Show (Maybe a) -- Defined in ‘GHC.Show’
         ...plus 22 others
-        ...plus 7 instances involving out-of-scope types
+        ...plus 12 instances involving out-of-scope types
         (use -fprint-potential-instances to see them all)
     • In the expression: print [1]
       In an equation for ‘main’: main = print [1]
index 9cca0e2..37c206c 100644 (file)
@@ -9,7 +9,7 @@ holes2.hs:3:5: warning: [-Wdeferred-type-errors (in -Wdefault)]
         instance Show Ordering -- Defined in ‘GHC.Show’
         instance Show Integer -- Defined in ‘GHC.Show’
         ...plus 23 others
-        ...plus 62 instances involving out-of-scope types
+        ...plus 67 instances involving out-of-scope types
         (use -fprint-potential-instances to see them all)
     • In the expression: show _
       In an equation for ‘f’: f = show _
index bf37f16..80e5ea7 100644 (file)
@@ -12,7 +12,7 @@ tcfail133.hs:68:7: error:
         instance (Number a, Digit b, Show a, Show b) => Show (a :@ b)
           -- Defined at tcfail133.hs:11:54
         ...plus 25 others
-        ...plus six instances involving out-of-scope types
+        ...plus 11 instances involving out-of-scope types
         (use -fprint-potential-instances to see them all)
     • In the expression: show $ add (One :@ Zero) (One :@ One)
       In an equation for ‘foo’: