[commit: ghc] wip/T9858-typeable-ben: Try another approach for type-level literals (b831888)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/T9858-typeable-ben
Link       : http://ghc.haskell.org/trac/ghc/changeset/b8318884315d1c03936168e05d40e3fce731eb47/ghc

>---------------------------------------------------------------

commit b8318884315d1c03936168e05d40e3fce731eb47
Author: Ben Gamari <ben at smart-cactus.org>
Date:   Wed Aug 26 14:59:32 2015 +0200

    Try another approach for type-level literals


>---------------------------------------------------------------

b8318884315d1c03936168e05d40e3fce731eb47
 compiler/deSugar/DsBinds.hs              | 19 ++++++++++---------
 compiler/prelude/PrelNames.hs            | 15 +++++----------
 libraries/base/Data/Typeable/Internal.hs | 14 +-------------
 3 files changed, 16 insertions(+), 32 deletions(-)

diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs
index 316e276..f80e369 100644
--- a/compiler/deSugar/DsBinds.hs
+++ b/compiler/deSugar/DsBinds.hs
@@ -940,17 +940,18 @@ ds_ev_typeable ty (EvTypeableTyApp ev1 ev2)
        ; ctr <- dsLookupGlobalId mkAppTyName
        ; return ( mkApps (Var ctr) [ e1, e2 ] ) }
 
-ds_ev_typeable ty (EvTypeableTyLit ev)
-  = do { dict <- dsEvTerm ev
-       ; ctr <- dsLookupGlobalId repConName
-              -- typeLitTypeRep :: Known{Nat,Symbol} a => Proxy# a -> TypeRep
-       ; let finst = mkTyApps (Var ctr) [ty]
-             proxy = mkTyApps (Var proxyHashId) [typeKind ty, ty]
-       ; return (mkApps finst [dict, proxy]) }
+ds_ev_typeable ty (EvTypeableTyLit _)
+  = do { -- dict <- dsEvTerm ev
+       ; ctr <- dsLookupGlobalId typeLitTypeRepName
+              -- typeLitTypeRep :: String -> TypeRep
+       -- ; let finst = mkTyApps (Var ctr) [ty]
+             -- proxy = mkTyApps (Var proxyHashId) [typeKind ty, ty]
+       ; tag <- mkStringExpr str
+       ; return (mkApps (Var ctr) [tag]) }
   where
     str
-      | Just _ <- isNumLitTy ty = typeNatTypeRepName
-      | Just _ <- isStrLitTy ty = typeSymbolTypeRepName
+      | Just n <- isNumLitTy ty = show n
+      | Just s <- isStrLitTy ty = show s
       | otherwise = panic "ds_ev_typeable: malformed TyLit evidence"
 
 ds_ev_typeable ty ev
diff --git a/compiler/prelude/PrelNames.hs b/compiler/prelude/PrelNames.hs
index 8dc79bc..49137b6 100644
--- a/compiler/prelude/PrelNames.hs
+++ b/compiler/prelude/PrelNames.hs
@@ -209,8 +209,7 @@ basicKnownKeyNames
         mkPolyTyConAppName,
         mkAppTyName,
         typeRepIdName,
-        typeNatTypeRepName,
-        typeSymbolTypeRepName,
+        typeLitTypeRepName,
         trTyConDataConName, trModuleDataConName, trNameSDataConName,
 
         -- Dynamic
@@ -1048,8 +1047,7 @@ typeableClassName
   , mkPolyTyConAppName
   , mkAppTyName
   , typeRepIdName
-  , typeNatTypeRepName
-  , typeSymbolTypeRepName
+  , typeLitTypeRepName
   :: Name
 typeableClassName     = clsQual tYPEABLE_INTERNAL (fsLit "Typeable")       typeableClassKey
 typeRepTyConName      = tcQual  tYPEABLE_INTERNAL (fsLit "TypeRep")        typeRepTyConKey
@@ -1059,8 +1057,7 @@ trNameSDataConName    = dcQual  gHC_TYPES         (fsLit "TrNameS")        trNam
 typeRepIdName         = varQual tYPEABLE_INTERNAL (fsLit "typeRep#")       typeRepIdKey
 mkPolyTyConAppName    = varQual tYPEABLE_INTERNAL (fsLit "mkPolyTyConApp") mkPolyTyConAppKey
 mkAppTyName           = varQual tYPEABLE_INTERNAL (fsLit "mkAppTy")        mkAppTyKey
-typeNatTypeRepName    = varQual tYPEABLE_INTERNAL (fsLit "typeNatTypeRep") typeNatTypeRepKey
-typeSymbolTypeRepName = varQual tYPEABLE_INTERNAL (fsLit "typeSymbolTypeRep") typeSymbolTypeRepKey
+typeLitTypeRepName    = varQual tYPEABLE_INTERNAL (fsLit "typeLitTypeRep") typeLitTypeRepKey
 
 
 -- Dynamic
@@ -1909,15 +1906,13 @@ proxyHashKey = mkPreludeMiscIdUnique 502
 mkTyConKey
   , mkPolyTyConAppKey
   , mkAppTyKey
-  , typeNatTypeRepKey
-  , typeSymbolTypeRepKey
+  , typeLitTypeRepKey
   , typeRepIdKey
   :: Unique
 mkTyConKey            = mkPreludeMiscIdUnique 503
 mkPolyTyConAppKey     = mkPreludeMiscIdUnique 504
 mkAppTyKey            = mkPreludeMiscIdUnique 505
-typeNatTypeRepKey     = mkPreludeMiscIdUnique 506
-typeSymbolTypeRepKey  = mkPreludeMiscIdUnique 507
+typeLitTypeRepKey     = mkPreludeMiscIdUnique 506
 typeRepIdKey      = mkPreludeMiscIdUnique 508
 
 -- Dynamic
diff --git a/libraries/base/Data/Typeable/Internal.hs b/libraries/base/Data/Typeable/Internal.hs
index 564f295..27063c1 100644
--- a/libraries/base/Data/Typeable/Internal.hs
+++ b/libraries/base/Data/Typeable/Internal.hs
@@ -67,14 +67,12 @@ module Data.Typeable.Internal (
     rnfTypeRep,
     showsTypeRep,
     typeRepKinds,
-    typeNatTypeRep,
-    typeSymbolTypeRep
+    typeLitTypeRep,
   ) where
 
 import GHC.Base
 import GHC.Word
 import GHC.Show
-import GHC.TypeLits
 import Data.Proxy
 
 import GHC.Fingerprint.Type
@@ -446,13 +444,3 @@ tcConstraint   = mkGhcTypesTyCon "Constraint"#
 
 funTc :: TyCon
 funTc = tcFun   -- Legacy
-
--- | Used to make `'Typeable' instance for things of kind Nat
-typeNatTypeRep :: KnownNat a => Proxy# a -> TypeRep
-typeNatTypeRep p = typeLitTypeRep (show (natVal' p))
-
--- | Used to make `'Typeable' instance for things of kind Symbol
-typeSymbolTypeRep :: KnownSymbol a => Proxy# a -> TypeRep
-typeSymbolTypeRep p = typeLitTypeRep (show (symbolVal' p))
-
--- TODO: what to put here?