Test Trac #13750

4 files changed, 103 insertions, 0 deletions

diff --git a/testsuite/tests/simplCore/should_run/T13750.hs b/testsuite/tests/simplCore/should_run/T13750.hs
new file mode 100644
index 0000000000..7e3b9c094c
--- /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/testsuite/tests/simplCore/should_run/T13750.stdout b/testsuite/tests/simplCore/should_run/T13750.stdout
new file mode 100644
index 0000000000..92232f694a
--- /dev/null
+++ b/testsuite/tests/simplCore/should_run/T13750.stdout
@@ -0,0 +1 @@
+"x"
diff --git a/testsuite/tests/simplCore/should_run/T13750a.hs b/testsuite/tests/simplCore/should_run/T13750a.hs
new file mode 100644
index 0000000000..7ed72ca241
--- /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 bf9686e9a4..75ff431910 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, [''])