Commit 4854fcea authored by Iavor S. Diatchki's avatar Iavor S. Diatchki

Change `Typeable` instance for type-lis to use the Known* classes.

This should fix T10348
parent 13ba87f8
......@@ -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
......
......@@ -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
{-
************************************************************************
......
......@@ -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)
----------------------------------------------------------------------
......
......@@ -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
......
......@@ -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]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......
......@@ -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
......
......@@ -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
......
......@@ -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
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment