[commit: ghc] master: Re-apply "Typeable: Allow App to match arrow types" (3de788c)
git at git.haskell.org
git at git.haskell.org
Thu Oct 12 11:53:51 UTC 2017
Repository : ssh://git@git.haskell.org/ghc
On branch : master
Link : http://ghc.haskell.org/trac/ghc/changeset/3de788c4eaa0592165bf1fb9e9a6d5b8e2c27554/ghc
>---------------------------------------------------------------
commit 3de788c4eaa0592165bf1fb9e9a6d5b8e2c27554
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date: Thu Oct 5 17:45:20 2017 +0100
Re-apply "Typeable: Allow App to match arrow types"
This re-applies
commit cc6be3a2f23c9b2e04f9f491099149e1e1d4d20b
Author: Ben Gamari <bgamari.foss at gmail.com>
Date: Tue Sep 19 18:57:38 2017 -0400
Typeable: Allow App to match arrow types
which was reverted because of Trac #14270. Now the latter is
fixed we can re-apply it.
The original ticket was Trac #14236
>---------------------------------------------------------------
3de788c4eaa0592165bf1fb9e9a6d5b8e2c27554
libraries/base/Data/Typeable/Internal.hs | 74 ++++++++++++++++++++--
libraries/base/changelog.md | 2 +
testsuite/tests/typecheck/should_run/T14236.hs | 14 ++++
testsuite/tests/typecheck/should_run/T14236.stdout | 3 +
testsuite/tests/typecheck/should_run/all.T | 1 +
5 files changed, 88 insertions(+), 6 deletions(-)
diff --git a/libraries/base/Data/Typeable/Internal.hs b/libraries/base/Data/Typeable/Internal.hs
index d876a2b..24ab515 100644
--- a/libraries/base/Data/Typeable/Internal.hs
+++ b/libraries/base/Data/Typeable/Internal.hs
@@ -180,11 +180,17 @@ rnfTyCon (TyCon _ _ m n _ k) = rnfModule m `seq` rnfTrName n `seq` rnfKindRep k
data TypeRep (a :: k) where
TrTyCon :: {-# UNPACK #-} !Fingerprint -> !TyCon -> [SomeTypeRep]
-> TypeRep (a :: k)
+
+ -- | Invariant: Saturated arrow types (e.g. things of the form @a -> b@)
+ -- are represented with @'TrFun' a b@, not @TrApp (TrApp funTyCon a) b at .
TrApp :: forall k1 k2 (a :: k1 -> k2) (b :: k1).
{-# UNPACK #-} !Fingerprint
-> TypeRep (a :: k1 -> k2)
-> TypeRep (b :: k1)
-> TypeRep (a b)
+
+ -- | @TrFun fpr a b@ represents a function type @a -> b at . We use this for
+ -- the sake of efficiency as functions are quite ubiquitous.
TrFun :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep)
(a :: TYPE r1) (b :: TYPE r2).
{-# UNPACK #-} !Fingerprint
@@ -272,6 +278,13 @@ mkTrApp :: forall k1 k2 (a :: k1 -> k2) (b :: k1).
TypeRep (a :: k1 -> k2)
-> TypeRep (b :: k1)
-> TypeRep (a b)
+mkTrApp rep@(TrApp _ (TrTyCon _ con _) (x :: TypeRep x)) (y :: TypeRep y)
+ | con == funTyCon -- cheap check first
+ , Just (IsTYPE (rx :: TypeRep rx)) <- isTYPE (typeRepKind x)
+ , Just (IsTYPE (ry :: TypeRep ry)) <- isTYPE (typeRepKind y)
+ , Just HRefl <- withTypeable x $ withTypeable rx $ withTypeable ry
+ $ typeRep @((->) x :: TYPE ry -> Type) `eqTypeRep` rep
+ = mkTrFun x y
mkTrApp a b = TrApp fpr a b
where
fpr_a = typeRepFingerprint a
@@ -281,17 +294,39 @@ mkTrApp a b = TrApp fpr a b
-- | A type application.
--
-- For instance,
+--
-- @
-- typeRep \@(Maybe Int) === App (typeRep \@Maybe) (typeRep \@Int)
-- @
--- Note that this will never match a function type (e.g. @Int -> Char@).
+--
+-- Note that this will also match a function type,
+--
+-- @
+-- typeRep \@(Int# -> Char)
+-- ===
+-- App (App arrow (typeRep \@Int#)) (typeRep \@Char)
+-- @
+--
+-- where @arrow :: TypeRep ((->) :: TYPE IntRep -> Type -> Type)@.
--
pattern App :: forall k2 (t :: k2). ()
=> forall k1 (a :: k1 -> k2) (b :: k1). (t ~ a b)
=> TypeRep a -> TypeRep b -> TypeRep t
-pattern App f x <- TrApp _ f x
+pattern App f x <- (splitApp -> Just (IsApp f x))
where App f x = mkTrApp f x
+data IsApp (a :: k) where
+ IsApp :: forall k k' (f :: k' -> k) (x :: k'). ()
+ => TypeRep f -> TypeRep x -> IsApp (f x)
+
+splitApp :: forall k (a :: k). ()
+ => TypeRep a
+ -> Maybe (IsApp a)
+splitApp (TrApp _ f x) = Just (IsApp f x)
+splitApp rep@(TrFun _ a b) = Just (IsApp (mkTrApp arr a) b)
+ where arr = bareArrow rep
+splitApp (TrTyCon{}) = Nothing
+
-- | Use a 'TypeRep' as 'Typeable' evidence.
withTypeable :: forall (a :: k) (r :: TYPE rep). ()
=> TypeRep a -> (Typeable a => r) -> r
@@ -326,6 +361,7 @@ pattern Con con <- TrTyCon _ con _
pattern Con' :: forall k (a :: k). TyCon -> [SomeTypeRep] -> TypeRep a
pattern Con' con ks <- TrTyCon _ con ks
+-- TODO: Remove Fun when #14253 is fixed
{-# COMPLETE Fun, App, Con #-}
{-# COMPLETE Fun, App, Con' #-}
@@ -362,7 +398,7 @@ typeRepKind :: TypeRep (a :: k) -> TypeRep k
typeRepKind (TrTyCon _ tc args)
= unsafeCoerceRep $ tyConKind tc args
typeRepKind (TrApp _ f _)
- | Fun _ res <- typeRepKind f
+ | TrFun _ _ res <- typeRepKind f
= res
| otherwise
= error ("Ill-kinded type application: " ++ show (typeRepKind f))
@@ -392,9 +428,9 @@ instantiateKindRep vars = go
go (KindRepVar var)
= vars A.! var
go (KindRepApp f a)
- = SomeTypeRep $ App (unsafeCoerceRep $ go f) (unsafeCoerceRep $ go a)
+ = SomeTypeRep $ mkTrApp (unsafeCoerceRep $ go f) (unsafeCoerceRep $ go a)
go (KindRepFun a b)
- = SomeTypeRep $ Fun (unsafeCoerceRep $ go a) (unsafeCoerceRep $ go b)
+ = SomeTypeRep $ mkTrFun (unsafeCoerceRep $ go a) (unsafeCoerceRep $ go b)
go (KindRepTYPE r) = unkindedTypeRep $ tYPE `kApp` runtimeRepTypeRep r
go (KindRepTypeLitS sort s)
= mkTypeLitFromString sort (unpackCStringUtf8# s)
@@ -417,7 +453,7 @@ kApp :: SomeKindedTypeRep (k -> k')
-> SomeKindedTypeRep k
-> SomeKindedTypeRep k'
kApp (SomeKindedTypeRep f) (SomeKindedTypeRep a) =
- SomeKindedTypeRep (App f a)
+ SomeKindedTypeRep (mkTrApp f a)
kindedTypeRep :: forall (a :: k). Typeable a => SomeKindedTypeRep k
kindedTypeRep = SomeKindedTypeRep (typeRep @a)
@@ -483,6 +519,32 @@ vecElemTypeRep e =
rep :: forall (a :: VecElem). Typeable a => SomeKindedTypeRep VecElem
rep = kindedTypeRep @VecElem @a
+bareArrow :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep)
+ (a :: TYPE r1) (b :: TYPE r2). ()
+ => TypeRep (a -> b)
+ -> TypeRep ((->) :: TYPE r1 -> TYPE r2 -> Type)
+bareArrow (TrFun _ a b) =
+ mkTrCon funTyCon [SomeTypeRep rep1, SomeTypeRep rep2]
+ where
+ rep1 = getRuntimeRep $ typeRepKind a :: TypeRep r1
+ rep2 = getRuntimeRep $ typeRepKind b :: TypeRep r2
+bareArrow _ = error "Data.Typeable.Internal.bareArrow: impossible"
+
+data IsTYPE (a :: Type) where
+ IsTYPE :: forall (r :: RuntimeRep). TypeRep r -> IsTYPE (TYPE r)
+
+-- | Is a type of the form @TYPE rep@?
+isTYPE :: TypeRep (a :: Type) -> Maybe (IsTYPE a)
+isTYPE (TrApp _ f r)
+ | Just HRefl <- f `eqTypeRep` typeRep @TYPE
+ = Just (IsTYPE r)
+isTYPE _ = Nothing
+
+getRuntimeRep :: forall (r :: RuntimeRep). TypeRep (TYPE r) -> TypeRep r
+getRuntimeRep (TrApp _ _ r) = r
+getRuntimeRep _ = error "Data.Typeable.Internal.getRuntimeRep: impossible"
+
+
-------------------------------------------------------------
--
-- The Typeable class and friends
diff --git a/libraries/base/changelog.md b/libraries/base/changelog.md
index 2f42e22..7c521f9 100644
--- a/libraries/base/changelog.md
+++ b/libraries/base/changelog.md
@@ -50,6 +50,8 @@
* Make `zipWith` and `zipWith3` inlinable (#14224)
+ * `Type.Reflection.App` now matches on function types (fixes #14236)
+
* `Type.Reflection.withTypeable` is now polymorphic in the `RuntimeRep` of
its result.
diff --git a/testsuite/tests/typecheck/should_run/T14236.hs b/testsuite/tests/typecheck/should_run/T14236.hs
new file mode 100644
index 0000000..c08682b
--- /dev/null
+++ b/testsuite/tests/typecheck/should_run/T14236.hs
@@ -0,0 +1,14 @@
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE MagicHash #-}
+import GHC.Exts
+import Type.Reflection
+
+main = do
+ case typeRep @(Int -> Char) of
+ App a b -> print (a, b)
+
+ case typeRep @(Int# -> Char) of
+ App a b -> print (a, b)
+
+ case typeRep @(Int# -> Char) of
+ App a b -> print $ App a (typeRep @String)
diff --git a/testsuite/tests/typecheck/should_run/T14236.stdout b/testsuite/tests/typecheck/should_run/T14236.stdout
new file mode 100644
index 0000000..a168ea8
--- /dev/null
+++ b/testsuite/tests/typecheck/should_run/T14236.stdout
@@ -0,0 +1,3 @@
+((->) 'LiftedRep 'LiftedRep Int,Char)
+((->) 'IntRep 'LiftedRep Int#,Char)
+Int# -> [Char]
diff --git a/testsuite/tests/typecheck/should_run/all.T b/testsuite/tests/typecheck/should_run/all.T
index 3d1aa36..2907612 100755
--- a/testsuite/tests/typecheck/should_run/all.T
+++ b/testsuite/tests/typecheck/should_run/all.T
@@ -124,3 +124,4 @@ test('T13435', normal, compile_and_run, [''])
test('T11715', exit_code(1), compile_and_run, [''])
test('T13594a', normal, ghci_script, ['T13594a.script'])
test('T14218', normal, compile_and_run, [''])
+test('T14236', normal, compile_and_run, [''])
More information about the ghc-commits
mailing list