[commit: ghc] master: Test Trac #9662 (ed57ea4)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/ed57ea499958824e82c111bd53a69129a8178659/ghc

>---------------------------------------------------------------

commit ed57ea499958824e82c111bd53a69129a8178659
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Tue Nov 11 11:35:48 2014 +0000

    Test Trac #9662


>---------------------------------------------------------------

ed57ea499958824e82c111bd53a69129a8178659
 .../tests/indexed-types/should_compile/T9662.hs    | 53 ++++++++++++++++++++++
 testsuite/tests/indexed-types/should_fail/T9662.hs | 53 ++++++++++++++++++++++
 testsuite/tests/indexed-types/should_fail/all.T    |  1 +
 3 files changed, 107 insertions(+)

diff --git a/testsuite/tests/indexed-types/should_compile/T9662.hs b/testsuite/tests/indexed-types/should_compile/T9662.hs
new file mode 100644
index 0000000..2972eca
--- /dev/null
+++ b/testsuite/tests/indexed-types/should_compile/T9662.hs
@@ -0,0 +1,53 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+module T9662 where
+
+data Exp a = Exp
+data (a:.b) = a:.b
+
+type family Plain e :: *
+type instance Plain (Exp a) = a
+type instance Plain (a:.b) = Plain a :. Plain b
+
+class (Plain (Unlifted pattern) ~ Tuple pattern) => Unlift pattern where
+   type Unlifted pattern
+   type Tuple pattern
+
+modify :: (Unlift pattern) =>
+   pattern ->
+   (Unlifted pattern -> a) ->
+   Exp (Tuple pattern) -> Exp (Plain a)
+modify p f = undefined
+
+
+data Atom a = Atom
+
+atom :: Atom a
+atom = Atom
+
+
+instance (Unlift pa, int ~ Atom Int) => Unlift (pa :. int) where
+   type Unlifted (pa :. int) = Unlifted pa :. Exp Int
+   type Tuple (pa :. int) = Tuple pa :. Int
+
+
+data Shape sh = Shape
+
+backpermute ::
+   (Exp sh -> Exp sh') ->
+   (Exp sh' -> Exp sh) ->
+   Shape sh -> Shape sh'
+backpermute = undefined
+
+test :: Shape (sh:.k:.m:.n) -> Shape (sh:.m:.n:.k)
+test =
+   backpermute
+      (modify (atom:.atom:.atom:.atom)
+         (\(sh:.k:.m:.n) -> (sh:.m:.n:.k)))
+      id
+
+-- With this arg instead of just 'id', it worked
+--    (modify (atom:.atom:.atom:.atom)
+--       (\(ix:.m:.n:.k) -> (ix:.k:.m:.n)))
diff --git a/testsuite/tests/indexed-types/should_fail/T9662.hs b/testsuite/tests/indexed-types/should_fail/T9662.hs
new file mode 100644
index 0000000..2972eca
--- /dev/null
+++ b/testsuite/tests/indexed-types/should_fail/T9662.hs
@@ -0,0 +1,53 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+module T9662 where
+
+data Exp a = Exp
+data (a:.b) = a:.b
+
+type family Plain e :: *
+type instance Plain (Exp a) = a
+type instance Plain (a:.b) = Plain a :. Plain b
+
+class (Plain (Unlifted pattern) ~ Tuple pattern) => Unlift pattern where
+   type Unlifted pattern
+   type Tuple pattern
+
+modify :: (Unlift pattern) =>
+   pattern ->
+   (Unlifted pattern -> a) ->
+   Exp (Tuple pattern) -> Exp (Plain a)
+modify p f = undefined
+
+
+data Atom a = Atom
+
+atom :: Atom a
+atom = Atom
+
+
+instance (Unlift pa, int ~ Atom Int) => Unlift (pa :. int) where
+   type Unlifted (pa :. int) = Unlifted pa :. Exp Int
+   type Tuple (pa :. int) = Tuple pa :. Int
+
+
+data Shape sh = Shape
+
+backpermute ::
+   (Exp sh -> Exp sh') ->
+   (Exp sh' -> Exp sh) ->
+   Shape sh -> Shape sh'
+backpermute = undefined
+
+test :: Shape (sh:.k:.m:.n) -> Shape (sh:.m:.n:.k)
+test =
+   backpermute
+      (modify (atom:.atom:.atom:.atom)
+         (\(sh:.k:.m:.n) -> (sh:.m:.n:.k)))
+      id
+
+-- With this arg instead of just 'id', it worked
+--    (modify (atom:.atom:.atom:.atom)
+--       (\(ix:.m:.n:.k) -> (ix:.k:.m:.n)))
diff --git a/testsuite/tests/indexed-types/should_fail/all.T b/testsuite/tests/indexed-types/should_fail/all.T
index f06060e..0fbee70 100644
--- a/testsuite/tests/indexed-types/should_fail/all.T
+++ b/testsuite/tests/indexed-types/should_fail/all.T
@@ -129,4 +129,5 @@ test('T9371', normal, compile_fail, [''])
 test('T9433', normal, compile_fail, [''])
 test('BadSock', normal, compile_fail, [''])
 test('T9580', normal, multimod_compile_fail, ['T9580', ''])
+test('T9662', normal, compile_fail, [''])