summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/deSugar/DsBinds.hs25
-rw-r--r--compiler/prelude/PrelNames.hs24
-rw-r--r--compiler/typecheck/TcEvidence.hs6
-rw-r--r--compiler/typecheck/TcHsSyn.hs2
-rw-r--r--compiler/typecheck/TcInteract.hs18
-rw-r--r--compiler/typecheck/TcSMonad.hs6
-rw-r--r--libraries/base/Data/Typeable/Internal.hs11
-rw-r--r--testsuite/tests/typecheck/should_compile/T10348.hs11
8 files changed, 72 insertions, 31 deletions
diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs
index ab3dfb90e1..2ab9f24bd7 100644
--- a/compiler/deSugar/DsBinds.hs
+++ b/compiler/deSugar/DsBinds.hs
@@ -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
diff --git a/compiler/prelude/PrelNames.hs b/compiler/prelude/PrelNames.hs
index 8b60088666..7a6c87e755 100644
--- a/compiler/prelude/PrelNames.hs
+++ b/compiler/prelude/PrelNames.hs
@@ -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
{-
************************************************************************
diff --git a/compiler/typecheck/TcEvidence.hs b/compiler/typecheck/TcEvidence.hs
index e7ab90274c..dfe8385f25 100644
--- a/compiler/typecheck/TcEvidence.hs
+++ b/compiler/typecheck/TcEvidence.hs
@@ -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)
----------------------------------------------------------------------
diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs
index 02d993f70c..c461d513e2 100644
--- a/compiler/typecheck/TcHsSyn.hs
+++ b/compiler/typecheck/TcHsSyn.hs
@@ -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
diff --git a/compiler/typecheck/TcInteract.hs b/compiler/typecheck/TcInteract.hs
index 2fccb94085..fca57d7382 100644
--- a/compiler/typecheck/TcInteract.hs
+++ b/compiler/typecheck/TcInteract.hs
@@ -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]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/compiler/typecheck/TcSMonad.hs b/compiler/typecheck/TcSMonad.hs
index d537328512..5ea20ed83d 100644
--- a/compiler/typecheck/TcSMonad.hs
+++ b/compiler/typecheck/TcSMonad.hs
@@ -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
diff --git a/libraries/base/Data/Typeable/Internal.hs b/libraries/base/Data/Typeable/Internal.hs
index 477247384d..e35d794a62 100644
--- a/libraries/base/Data/Typeable/Internal.hs
+++ b/libraries/base/Data/Typeable/Internal.hs
@@ -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
diff --git a/testsuite/tests/typecheck/should_compile/T10348.hs b/testsuite/tests/typecheck/should_compile/T10348.hs
index 213079b4b7..7380d81e09 100644
--- a/testsuite/tests/typecheck/should_compile/T10348.hs
+++ b/testsuite/tests/typecheck/should_compile/T10348.hs
@@ -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
+
+
View Lorry Controller Status