Revert "Typeable: Allow App to match arrow types"
authorHerbert Valerio Riedel <hvr@gnu.org>
Sun, 24 Sep 2017 06:54:28 +0000 (08:54 +0200)
committerHerbert Valerio Riedel <hvr@gnu.org>
Sun, 24 Sep 2017 07:30:59 +0000 (09:30 +0200)
This reverts commit cc6be3a2f23c9b2e04f9f491099149e1e1d4d20b.
because it caused the regression #14270 which according to
Richard probably doesn't have an easy fix. So this one goes
back to the drawning board.

This reopens #14236

libraries/base/Data/Typeable/Internal.hs
libraries/base/changelog.md
testsuite/tests/typecheck/should_run/T14236.hs [deleted file]
testsuite/tests/typecheck/should_run/T14236.stdout [deleted file]
testsuite/tests/typecheck/should_run/all.T

index f97a804..ff53921 100644 (file)
@@ -175,17 +175,11 @@ 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@.
     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@. 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
@@ -273,13 +267,6 @@ 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
@@ -289,39 +276,17 @@ mkTrApp a b = TrApp fpr a b
 -- | A type application.
 --
 -- For instance,
---
 -- @
 -- typeRep \@(Maybe Int) === App (typeRep \@Maybe) (typeRep \@Int)
 -- @
---
--- 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)@.
+-- Note that this will never match a function type (e.g. @Int -> Char@).
 --
 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 <- (splitApp -> Just (IsApp f x))
+pattern App f x <- TrApp _ 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
@@ -356,7 +321,6 @@ 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' #-}
 
@@ -393,7 +357,7 @@ typeRepKind :: TypeRep (a :: k) -> TypeRep k
 typeRepKind (TrTyCon _ tc args)
   = unsafeCoerceRep $ tyConKind tc args
 typeRepKind (TrApp _ f _)
-  | TrFun _ _ res <- typeRepKind f
+  | Fun _ res <- typeRepKind f
   = res
   | otherwise
   = error ("Ill-kinded type application: " ++ show (typeRepKind f))
@@ -423,9 +387,9 @@ instantiateKindRep vars = go
     go (KindRepVar var)
       = vars A.! var
     go (KindRepApp f a)
-      = SomeTypeRep $ mkTrApp (unsafeCoerceRep $ go f) (unsafeCoerceRep $ go a)
+      = SomeTypeRep $ App (unsafeCoerceRep $ go f) (unsafeCoerceRep $ go a)
     go (KindRepFun a b)
-      = SomeTypeRep $ mkTrFun (unsafeCoerceRep $ go a) (unsafeCoerceRep $ go b)
+      = SomeTypeRep $ Fun (unsafeCoerceRep $ go a) (unsafeCoerceRep $ go b)
     go (KindRepTYPE r) = unkindedTypeRep $ tYPE `kApp` runtimeRepTypeRep r
     go (KindRepTypeLitS sort s)
       = mkTypeLitFromString sort (unpackCStringUtf8# s)
@@ -448,7 +412,7 @@ kApp :: SomeKindedTypeRep (k -> k')
      -> SomeKindedTypeRep k
      -> SomeKindedTypeRep k'
 kApp (SomeKindedTypeRep f) (SomeKindedTypeRep a) =
-    SomeKindedTypeRep (mkTrApp f a)
+    SomeKindedTypeRep (App f a)
 
 kindedTypeRep :: forall (a :: k). Typeable a => SomeKindedTypeRep k
 kindedTypeRep = SomeKindedTypeRep (typeRep @a)
@@ -514,32 +478,6 @@ 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
index 6c15a98..5b1e147 100644 (file)
@@ -47,8 +47,6 @@
 
   * 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
deleted file mode 100644 (file)
index c08682b..0000000
+++ /dev/null
@@ -1,14 +0,0 @@
-{-# 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
deleted file mode 100644 (file)
index a168ea8..0000000
+++ /dev/null
@@ -1,3 +0,0 @@
-((->) 'LiftedRep 'LiftedRep Int,Char)
-((->) 'IntRep 'LiftedRep Int#,Char)
-Int# -> [Char]
index 1958001..3fc1928 100755 (executable)
@@ -123,4 +123,3 @@ test('TypeableEq', normal, compile_and_run, [''])
 test('T13435', normal, compile_and_run, [''])
 test('T11715', exit_code(1), compile_and_run, [''])
 test('T13594a', normal, ghci_script, ['T13594a.script'])
-test('T14236', normal, compile_and_run, [''])