Test Trac #4935

2 files changed, 25 insertions, 0 deletions

diff --git a/testsuite/tests/ghc-regress/indexed-types/should_compile/T4935.hs b/testsuite/tests/ghc-regress/indexed-types/should_compile/T4935.hs
new file mode 100644
index 0000000000..2c9d16a9b8
--- /dev/null
+++ b/testsuite/tests/ghc-regress/indexed-types/should_compile/T4935.hs
@@ -0,0 +1,24 @@
+{-# LANGUAGE TypeFamilies, Rank2Types, ScopedTypeVariables #-}
+module T4935 where
+
+import Control.Applicative
+
+data TFalse
+data TTrue
+
+data Tagged b a = Tagged {at :: a}
+type At b = forall a. Tagged b a -> a
+
+class TBool b where onTBool :: (b ~ TFalse => c) -> (b ~ TTrue => c) -> Tagged b c
+instance TBool TFalse where onTBool f _ = Tagged $ f
+instance TBool TTrue where onTBool _ t = Tagged $ t
+
+type family CondV c f t
+type instance CondV TFalse f t = f
+type instance CondV TTrue f t = t
+
+newtype Cond c f a = Cond {getCond :: CondV c a (f a)}
+cond :: forall c f a g. (TBool c, Functor g) => (c ~ TFalse => g a) -> (c ~ TTrue => g (f a)) -> g (Cond c f a)
+cond f t = (at :: At c) $ onTBool (fmap Cond f) (fmap Cond t)
+condMap :: (TBool c, Functor f) => (a -> b) -> Cond c f a -> Cond c f b
+condMap g (Cond n) = cond g (fmap g) n
diff --git a/testsuite/tests/ghc-regress/indexed-types/should_compile/all.T b/testsuite/tests/ghc-regress/indexed-types/should_compile/all.T
index 4bc42ebecf..528e1f1544 100644
--- a/testsuite/tests/ghc-regress/indexed-types/should_compile/all.T
+++ b/testsuite/tests/ghc-regress/indexed-types/should_compile/all.T
@@ -166,3 +166,4 @@ test('T1769', if_compiler_lt('ghc', '7.1', expect_fail), compile, [''])
 test('T4497', normal, compile, [''])
 test('T3484', normal, compile, [''])
 test('T3460', normal, compile, [''])
+test('T4935', normal, compile, [''])