[commit: ghc] master: Test Trac #13750 (ef07010)

[git at git.haskell.org]

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

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

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

commit ef07010cf4f480d9f595a71cf5b009884522a75e
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Wed Jun 7 15:15:37 2017 +0100

    Test Trac #13750


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

ef07010cf4f480d9f595a71cf5b009884522a75e
 testsuite/tests/simplCore/should_run/T13750.hs     | 47 +++++++++++++++++++
 .../tests/simplCore/should_run/T13750.stdout       |  0
 testsuite/tests/simplCore/should_run/T13750a.hs    | 54 ++++++++++++++++++++++
 testsuite/tests/simplCore/should_run/all.T         |  1 +
 4 files changed, 102 insertions(+)

diff --git a/testsuite/tests/simplCore/should_run/T13750.hs b/testsuite/tests/simplCore/should_run/T13750.hs
new file mode 100644
index 0000000..7e3b9c0
--- /dev/null
+++ b/testsuite/tests/simplCore/should_run/T13750.hs
@@ -0,0 +1,47 @@
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE UndecidableSuperClasses #-}
+{-# LANGUAGE PolyKinds #-}
+module Main where
+
+import T13750a
+
+import GHC.Exts (Constraint)
+import Unsafe.Coerce
+import Data.Proxy
+
+class MyShow a where
+  myShow :: a -> String
+
+instance MyShow Char where
+  myShow a = [a]
+
+gshowS :: (All2 MyShow xss) => NS xss -> String
+gshowS (Z xs)  = gshowP xs
+gshowS (S xss) = gshowS xss
+
+gshowP :: (All MyShow xs) => NP xs -> String
+gshowP (x :* Nil) = myShow x
+
+class (AllF c xs) => All (c :: k -> Constraint) (xs :: [k])
+  -- where foo :: Proxy c     -- This makes it not seg-fault
+
+instance All c '[]
+instance (c x, All c xs) => All c (x ': xs)
+
+type family AllF (c :: k -> Constraint) (xs :: [k]) :: Constraint
+type instance AllF _c '[]       = ()
+type instance AllF  c (x ': xs) = (c x, All c xs)
+
+type All2 f = All (All f)
+
+main :: IO ()
+main = do
+  let t = 'x' :* Nil
+  print (gshowS (Z ('x' :* Nil) :: NS '[ '[ Char ] ]))
diff --git a/libraries/base/tests/take001.stdout b/testsuite/tests/simplCore/should_run/T13750.stdout
similarity index 100%
copy from libraries/base/tests/take001.stdout
copy to testsuite/tests/simplCore/should_run/T13750.stdout
diff --git a/testsuite/tests/simplCore/should_run/T13750a.hs b/testsuite/tests/simplCore/should_run/T13750a.hs
new file mode 100644
index 0000000..7ed72ca
--- /dev/null
+++ b/testsuite/tests/simplCore/should_run/T13750a.hs
@@ -0,0 +1,54 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE ViewPatterns #-}
+module T13750a where
+
+import Unsafe.Coerce
+
+type family AnyT :: * where {}
+type family AnyList :: [*] where {}
+
+newtype NP (xs :: [*]) = NP [AnyT]
+
+data IsNP (xs :: [*]) where
+  IsNil  :: IsNP '[]
+  IsCons :: x -> NP xs -> IsNP (x ': xs)
+
+isNP :: NP xs -> IsNP xs
+isNP (NP xs) =
+  if null xs
+    then unsafeCoerce IsNil
+    else unsafeCoerce (IsCons (head xs) (NP (tail xs)))
+
+pattern Nil :: () => (xs ~ '[]) => NP xs
+pattern Nil <- (isNP -> IsNil)
+  where
+    Nil = NP []
+
+pattern (:*) :: () => (xs' ~ (x ': xs)) => x -> NP xs -> NP xs'
+pattern x :* xs <- (isNP -> IsCons x xs)
+  where
+    x :* NP xs = NP (unsafeCoerce x : xs)
+infixr 5 :*
+
+data NS (xs :: [[*]]) = NS !Int (NP AnyList)
+
+data IsNS (xs :: [[*]]) where
+  IsZ :: NP x -> IsNS (x ': xs)
+  IsS :: NS xs -> IsNS (x ': xs)
+
+isNS :: NS xs -> IsNS xs
+isNS (NS i x)
+  | i == 0    = unsafeCoerce (IsZ (unsafeCoerce x))
+  | otherwise = unsafeCoerce (IsS (NS (i - 1) x))
+
+pattern Z :: () => (xs' ~ (x ': xs)) => NP x -> NS xs'
+pattern Z x <- (isNS -> IsZ x)
+  where
+    Z x = NS 0 (unsafeCoerce x)
+
+pattern S :: () => (xs' ~ (x ': xs)) => NS xs -> NS xs'
+pattern S p <- (isNS -> IsS p)
diff --git a/testsuite/tests/simplCore/should_run/all.T b/testsuite/tests/simplCore/should_run/all.T
index bf9686e..75ff431 100644
--- a/testsuite/tests/simplCore/should_run/all.T
+++ b/testsuite/tests/simplCore/should_run/all.T
@@ -76,3 +76,4 @@ test('T13227', normal, compile_and_run, [''])
 test('T13733', expect_broken(13733), compile_and_run, [''])
 test('T13429', normal, compile_and_run, [''])
 test('T13429_2', normal, compile_and_run, [''])
+test('T13750', normal, compile_and_run, [''])