Change `Typeable` instance for type-lis to use the Known* classes.
authorIavor S. Diatchki <iavor.diatchki@gmail.com>
Sun, 21 Jun 2015 19:24:42 +0000 (12:24 -0700)
committerIavor S. Diatchki <iavor.diatchki@gmail.com>
Sun, 21 Jun 2015 19:25:24 +0000 (12:25 -0700)
This should fix T10348

compiler/deSugar/DsBinds.hs
compiler/prelude/PrelNames.hs
compiler/typecheck/TcEvidence.hs
compiler/typecheck/TcHsSyn.hs
compiler/typecheck/TcInteract.hs
compiler/typecheck/TcSMonad.hs
libraries/base/Data/Typeable/Internal.hs
testsuite/tests/typecheck/should_compile/T10348.hs

index ab3dfb9..2ab9f24 100644 (file)
@@ -47,7 +47,7 @@ import Type
 import Kind (returnsConstraintKind)
 import Coercion hiding (substCo)
 import TysWiredIn ( eqBoxDataCon, coercibleDataCon, mkListTy
-                  , mkBoxedTupleTy, stringTy )
+                  , mkBoxedTupleTy, stringTy, typeNatKind, typeSymbolKind )
 import Id
 import MkId(proxyHashId)
 import Class
@@ -908,14 +908,9 @@ dsEvTypeable ev =
                       , mkApps (Var ctr) [ e1, e2 ]
                       )
 
-          EvTypeableTyLit ty ->
-            do str <- case (isNumLitTy ty, isStrLitTy ty) of
-                        (Just n, _) -> return (show n)
-                        (_, Just n) -> return (show n)
-                        _ -> panic "dsEvTypeable: malformed TyLit evidence"
-               ctr <- dsLookupGlobalId typeLitTypeRepName
-               tag <- mkStringExpr str
-               return (ty, mkApps (Var ctr) [ tag ])
+          EvTypeableTyLit t ->
+            do e <- tyLitRep t
+               return (snd t, e)
 
      -- TyRep -> Typeable t
      -- see also: Note [Memoising typeOf]
@@ -942,6 +937,18 @@ dsEvTypeable ev =
            proxy  = mkTyApps (Var proxyHashId) [typeKind t, t]
        return (mkApps method [proxy])
 
+  -- KnownNat t -> TyRep      (also used for KnownSymbol)
+  tyLitRep (ev,t) =
+    do dict <- dsEvTerm ev
+       fun  <- dsLookupGlobalId $
+               case typeKind t of
+                 k | eqType k typeNatKind    -> typeNatTypeRepName
+                   | eqType k typeSymbolKind -> typeSymbolTypeRepName
+                   | otherwise -> panic "dsEvTypeable: unknown type lit kind"
+       let finst  = mkTyApps (Var fun) [t]
+           proxy  = mkTyApps (Var proxyHashId) [typeKind t, t]
+       return (mkApps finst [ dict, proxy ])
+
   -- This part could be cached
   tyConRep dflags mkTyCon tc =
     do pkgStr  <- mkStringExprFS pkg_fs
index 8b60088..7a6c87e 100644 (file)
@@ -212,7 +212,8 @@ basicKnownKeyNames
         mkTyConName,
         mkPolyTyConAppName,
         mkAppTyName,
-        typeLitTypeRepName,
+        typeNatTypeRepName,
+        typeSymbolTypeRepName,
 
         -- Dynamic
         toDynName,
@@ -1021,14 +1022,17 @@ typeableClassName
   , mkTyConName
   , mkPolyTyConAppName
   , mkAppTyName
-  , typeLitTypeRepName
+  , typeNatTypeRepName
+  , typeSymbolTypeRepName
   :: Name
 typeableClassName     = clsQual tYPEABLE_INTERNAL (fsLit "Typeable")       typeableClassKey
 typeRepTyConName      = tcQual  tYPEABLE_INTERNAL (fsLit "TypeRep")        typeRepTyConKey
 mkTyConName           = varQual tYPEABLE_INTERNAL (fsLit "mkTyCon")        mkTyConKey
 mkPolyTyConAppName    = varQual tYPEABLE_INTERNAL (fsLit "mkPolyTyConApp") mkPolyTyConAppKey
 mkAppTyName           = varQual tYPEABLE_INTERNAL (fsLit "mkAppTy")        mkAppTyKey
-typeLitTypeRepName    = varQual tYPEABLE_INTERNAL (fsLit "typeLitTypeRep") typeLitTypeRepKey
+typeNatTypeRepName    = varQual tYPEABLE_INTERNAL (fsLit "typeNatTypeRep") typeNatTypeRepKey
+typeSymbolTypeRepName = varQual tYPEABLE_INTERNAL (fsLit "typeSymbolTypeRep") typeSymbolTypeRepKey
+
 
 -- Dynamic
 toDynName :: Name
@@ -1874,16 +1878,18 @@ proxyHashKey = mkPreludeMiscIdUnique 502
 mkTyConKey
   , mkPolyTyConAppKey
   , mkAppTyKey
-  , typeLitTypeRepKey
+  , typeNatTypeRepKey
+  , typeSymbolTypeRepKey
   :: Unique
-mkTyConKey        = mkPreludeMiscIdUnique 503
-mkPolyTyConAppKey = mkPreludeMiscIdUnique 504
-mkAppTyKey        = mkPreludeMiscIdUnique 505
-typeLitTypeRepKey = mkPreludeMiscIdUnique 506
+mkTyConKey            = mkPreludeMiscIdUnique 503
+mkPolyTyConAppKey     = mkPreludeMiscIdUnique 504
+mkAppTyKey            = mkPreludeMiscIdUnique 505
+typeNatTypeRepKey     = mkPreludeMiscIdUnique 506
+typeSymbolTypeRepKey  = mkPreludeMiscIdUnique 507
 
 -- Dynamic
 toDynIdKey :: Unique
-toDynIdKey = mkPreludeMiscIdUnique 507
+toDynIdKey = mkPreludeMiscIdUnique 508
 
 {-
 ************************************************************************
index e7ab902..dfe8385 100644 (file)
@@ -739,7 +739,7 @@ data EvTypeable
     -- ^ Dictionary for type applications;  this is used when we have
     -- a type expression starting with a type variable (e.g., @Typeable (f a)@)
 
-  | EvTypeableTyLit Type
+  | EvTypeableTyLit (EvTerm,Type)
     -- ^ Dictionary for a type literal.
 
   deriving ( Data.Data, Data.Typeable )
@@ -1018,7 +1018,7 @@ evVarsOfTypeable ev =
   case ev of
     EvTypeableTyCon _ _    -> emptyVarSet
     EvTypeableTyApp e1 e2  -> evVarsOfTerms (map fst [e1,e2])
-    EvTypeableTyLit _      -> emptyVarSet
+    EvTypeableTyLit e      -> evVarsOfTerm (fst e)
 
 {-
 ************************************************************************
@@ -1103,7 +1103,7 @@ instance Outputable EvTypeable where
     case ev of
       EvTypeableTyCon tc ks    -> parens (ppr tc <+> sep (map ppr ks))
       EvTypeableTyApp t1 t2    -> parens (ppr (fst t1) <+> ppr (fst t2))
-      EvTypeableTyLit x        -> ppr x
+      EvTypeableTyLit x        -> ppr (fst x)
 
 
 ----------------------------------------------------------------------
index 02d993f..c461d51 100644 (file)
@@ -1256,7 +1256,7 @@ zonkEvTerm env (EvTypeable ev) =
     EvTypeableTyApp t1 t2    -> do e1 <- zonk t1
                                    e2 <- zonk t2
                                    return (EvTypeableTyApp e1 e2)
-    EvTypeableTyLit t        -> EvTypeableTyLit `fmap` zonkTcTypeToType env t
+    EvTypeableTyLit t        -> EvTypeableTyLit `fmap` zonk t
   where
   zonk (ev,t) = do ev' <- zonkEvTerm env ev
                    t'  <- zonkTcTypeToType env t
index 2fccb94..fca57d7 100644 (file)
@@ -22,6 +22,7 @@ import Var
 import TcType
 import PrelNames ( knownNatClassName, knownSymbolClassName, ipClassNameKey,
                    callStackTyConKey, typeableClassName )
+import TysWiredIn ( typeNatKind, typeSymbolKind )
 import Id( idType )
 import Class
 import TyCon
@@ -1810,7 +1811,7 @@ isCallStackIP loc cls tys
 -- | Assumes that we've checked that this is the 'Typeable' class,
 -- and it was applied to the correct argument.
 matchTypeableClass :: Class -> Kind -> Type -> TcS LookupInstResult
-matchTypeableClass clas _k t
+matchTypeableClass clas k t
 
   -- See Note [No Typeable for qualified types]
   | isForAllTy t                               = return NoInstance
@@ -1818,11 +1819,12 @@ matchTypeableClass clas _k t
   | Just (t1,_) <- splitFunTy_maybe t,
     isConstraintKind (typeKind t1)             = return NoInstance
 
+  | eqType k typeNatKind                       = doTyLit knownNatClassName
+  | eqType k typeSymbolKind                    = doTyLit knownSymbolClassName
+
   | Just (tc, ks) <- splitTyConApp_maybe t
   , all isKind ks                              = doTyCon tc ks
   | Just (f,kt)       <- splitAppTy_maybe t    = doTyApp f kt
-  | Just _            <- isNumLitTy t          = mkSimpEv (EvTypeableTyLit t)
-  | Just _            <- isStrLitTy t          = mkSimpEv (EvTypeableTyLit t)
   | otherwise                                  = return NoInstance
 
   where
@@ -1830,7 +1832,8 @@ matchTypeableClass clas _k t
   doTyCon tc ks =
     case mapM kindRep ks of
       Nothing    -> return NoInstance
-      Just kReps -> mkSimpEv (EvTypeableTyCon tc kReps)
+      Just kReps ->
+        return $ GenInst [] (\_ -> EvTypeable (EvTypeableTyCon tc kReps) ) True
 
   {- Representation for an application of a type to a type-or-kind.
   This may happen when the type expression starts with a type variable.
@@ -1858,7 +1861,12 @@ matchTypeableClass clas _k t
   -- Emit a `Typeable` constraint for the given type.
   mk_typeable_pred ty = mkClassPred clas [ typeKind ty, ty ]
 
-  mkSimpEv ev = return $ GenInst [] (\_ -> EvTypeable ev) True
+  -- Given KnownNat / KnownSymbol, generate appropriate sub-goal
+  -- and make evidence for a type-level literal.
+  doTyLit c = do clas <- tcLookupClass c
+                 let p = mkClassPred clas [ t ]
+                 return $ GenInst [p] (\[i] -> EvTypeable
+                                             $ EvTypeableTyLit (EvId i,t)) True
 
 {- Note [No Typeable for polytype or for constraints]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
index d537328..5ea20ed 100644 (file)
@@ -35,6 +35,7 @@ module TcSMonad (
     getInstEnvs, getFamInstEnvs,                -- Getting the environments
     getTopEnv, getGblEnv, getTcEvBinds, getTcLevel,
     getTcEvBindsMap,
+    tcLookupClass,
 
     -- Inerts
     InertSet(..), InertCans(..),
@@ -111,7 +112,7 @@ import FamInstEnv
 import qualified TcRnMonad as TcM
 import qualified TcMType as TcM
 import qualified TcEnv as TcM
-       ( checkWellStaged, topIdLvl, tcGetDefaultTys )
+       ( checkWellStaged, topIdLvl, tcGetDefaultTys, tcLookupClass )
 import Kind
 import TcType
 import DynFlags
@@ -2457,6 +2458,9 @@ getTopEnv = wrapTcS $ TcM.getTopEnv
 getGblEnv :: TcS TcGblEnv
 getGblEnv = wrapTcS $ TcM.getGblEnv
 
+tcLookupClass :: Name -> TcS Class
+tcLookupClass c = wrapTcS $ TcM.tcLookupClass c
+
 -- Setting names as used (used in the deriving of Coercible evidence)
 -- Too hackish to expose it to TcS? In that case somehow extract the used
 -- constructors from the result of solveInteract
index 4772473..e35d794 100644 (file)
@@ -51,12 +51,14 @@ module Data.Typeable.Internal (
     rnfTyCon,
     listTc, funTc,
     typeRepKinds,
-    typeLitTypeRep
+    typeNatTypeRep,
+    typeSymbolTypeRep
   ) where
 
 import GHC.Base
 import GHC.Word
 import GHC.Show
+import GHC.TypeLits
 import Data.Proxy
 
 import GHC.Fingerprint.Type
@@ -330,6 +332,13 @@ funTc :: TyCon
 funTc = typeRepTyCon (typeRep (Proxy :: Proxy (->)))
 
 
+-- | 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))
 
 -- | An internal function, to make representations for type literals.
 typeLitTypeRep :: String -> TypeRep
index 213079b..7380d81 100644 (file)
@@ -15,9 +15,16 @@ data T t where
 
 deriving instance Show (T n)
 
-hey :: (Typeable n, KnownNat n) => T (Foo n)
--- SHOULD BE: hey :: KnownNat n => T (Foo n)
+hey :: KnownNat n => T (Foo n)
 hey = T Hey
 
 ho :: T (Foo 42)
 ho = T Hey
+
+f1 :: KnownNat a => Proxy a -> TypeRep
+f1 = typeRep
+
+g2 :: KnownSymbol a => Proxy a -> TypeRep
+g2 = typeRep
+
+