Implement `Typeable` support for type-level literals (#8778).

2 files changed, 53 insertions, 4 deletions

diff --git a/libraries/base/Data/Typeable/Internal.hs b/libraries/base/Data/Typeable/Internal.hs
index 1bee846a73..0e42bcdd87 100644
--- a/libraries/base/Data/Typeable/Internal.hs
+++ b/libraries/base/Data/Typeable/Internal.hs
@@ -22,6 +22,8 @@
            , PolyKinds
            , ConstraintKinds
            , DeriveDataTypeable
+           , DataKinds
+           , UndecidableInstances
            , StandaloneDeriving #-}
 
 module Data.Typeable.Internal (
@@ -63,6 +65,7 @@ import GHC.STRef        ( STRef )
 import GHC.Ptr          ( Ptr, FunPtr )
 -- import GHC.Stable
 import GHC.Arr          ( Array, STArray, Ix )
+import GHC.TypeLits ( Nat, Symbol, KnownNat, KnownSymbol, natVal', symbolVal' )
 import Data.Type.Coercion
 import Data.Type.Equality
 import Text.ParserCombinators.ReadP ( ReadP )
@@ -411,3 +414,38 @@ deriving instance Typeable Monad
 deriving instance Typeable MonadPlus
 
 deriving instance Typeable Typeable
+
+
+
+--------------------------------------------------------------------------------
+-- Instances for type literals
+
+instance KnownNat n => Typeable (n :: Nat) where
+  typeRep# p = mkTyConApp tc []
+    where
+    tc = TyCon
+           { tyConHash     = fingerprintString (mk pack modu nm)
+           , tyConPackage  = pack
+           , tyConModule   = modu
+           , tyConName     = nm
+           }
+    pack = "base"
+    modu = "GHC.TypeLits"
+    nm   = show (natVal' p)
+    mk a b c = a ++ " " ++ b ++ " " ++ c
+
+
+instance KnownSymbol s => Typeable (s :: Symbol) where
+  typeRep# p = mkTyConApp tc []
+    where
+    tc = TyCon
+           { tyConHash     = fingerprintString (mk pack modu nm)
+           , tyConPackage  = pack
+           , tyConModule   = modu
+           , tyConName     = nm
+           }
+    pack = "base"
+    modu = "GHC.TypeLits"
+    nm   = show (symbolVal' p)
+    mk a b c = a ++ " " ++ b ++ " " ++ c
+
diff --git a/libraries/base/GHC/TypeLits.hs b/libraries/base/GHC/TypeLits.hs
index 53a6004b36..cc76bc9101 100644
--- a/libraries/base/GHC/TypeLits.hs
+++ b/libraries/base/GHC/TypeLits.hs
@@ -10,6 +10,7 @@
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE UndecidableInstances #-}  -- for compiling instances of (==)
 {-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE MagicHash #-}
 
 {-| This module is an internal GHC module.  It declares the constants used
 in the implementation of type-level natural numbers.  The programmer interface
@@ -23,8 +24,8 @@ module GHC.TypeLits
     Nat, Symbol
 
     -- * Linking type and value level
-  , KnownNat, natVal
-  , KnownSymbol, symbolVal
+  , KnownNat, natVal, natVal'
+  , KnownSymbol, symbolVal, symbolVal'
   , SomeNat(..), SomeSymbol(..)
   , someNatVal, someSymbolVal
   , sameNat, sameSymbol
@@ -41,9 +42,9 @@ import GHC.Num(Integer)
 import GHC.Base(String)
 import GHC.Show(Show(..))
 import GHC.Read(Read(..))
-import GHC.Prim(magicDict)
+import GHC.Prim(magicDict, Proxy#)
 import Data.Maybe(Maybe(..))
-import Data.Proxy(Proxy(..))
+import Data.Proxy (Proxy(..))
 import Data.Type.Equality(type (==), (:~:)(Refl))
 import Unsafe.Coerce(unsafeCoerce)
 
@@ -80,6 +81,16 @@ symbolVal :: forall n proxy. KnownSymbol n => proxy n -> String
 symbolVal _ = case symbolSing :: SSymbol n of
                 SSymbol x -> x
 
+-- | /Since: 4.7.0.0/
+natVal' :: forall n. KnownNat n => Proxy# n -> Integer
+natVal' _ = case natSing :: SNat n of
+             SNat x -> x
+
+-- | /Since: 4.7.0.0/
+symbolVal' :: forall n. KnownSymbol n => Proxy# n -> String
+symbolVal' _ = case symbolSing :: SSymbol n of
+                SSymbol x -> x
+
 
 
 -- | This type represents unknown type-level natural numbers.