Test Trac #8848

5 files changed, 72 insertions, 0 deletions

diff --git a/testsuite/tests/simplCore/should_compile/T8848.hs b/testsuite/tests/simplCore/should_compile/T8848.hs
new file mode 100644
index 0000000000..1ddfe94596
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T8848.hs
@@ -0,0 +1,26 @@
+{-# LANGUAGE KindSignatures, GADTs, DataKinds, FlexibleInstances, FlexibleContexts #-}
+{-# OPTIONS_GHC -fno-warn-missing-methods #-}
+
+module T8848 where
+
+import qualified Control.Applicative as A
+import qualified Data.Functor as Fun
+
+data Nat = S Nat  | Z
+
+data Shape (rank :: Nat) a where
+    Nil  :: Shape Z a
+    (:*) ::  a -> Shape r a -> Shape  (S r) a
+
+instance A.Applicative (Shape Z) where
+instance A.Applicative (Shape r)=> A.Applicative (Shape (S r)) where
+instance Fun.Functor (Shape Z) where
+instance (Fun.Functor (Shape r)) => Fun.Functor (Shape (S r)) where
+
+map2 :: (A.Applicative (Shape r))=> (a->b ->c) -> (Shape r a) -> (Shape r b) -> (Shape r c )
+map2 = \f l r -> A.pure f A.<*>  l  A.<*> r
+
+{-# SPECIALIZE map2 :: (a->b->c)-> (Shape (S (S Z)) a )-> Shape (S (S Z)) b -> Shape (S (S Z)) c #-}
+
+map3 :: (a->b->c)-> (Shape (S (S Z)) a )-> Shape (S (S Z)) b -> Shape (S (S Z)) c 
+map3 x y z = map2 x y z
\ No newline at end of file
diff --git a/testsuite/tests/simplCore/should_compile/T8848.stderr b/testsuite/tests/simplCore/should_compile/T8848.stderr
new file mode 100644
index 0000000000..1a6286882e
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T8848.stderr
@@ -0,0 +1,17 @@
+Rule fired: Class op fmap
+Rule fired: Class op fmap
+Rule fired: Class op pure
+Rule fired: Class op <*>
+Rule fired: Class op <*>
+Rule fired: SPEC T8848.map2
+Rule fired: Class op $p1Applicative
+Rule fired: Class op <*>
+Rule fired: Class op $p1Applicative
+Rule fired: Class op <*>
+Rule fired: Class op $p1Applicative
+Rule fired: Class op fmap
+Rule fired: Class op <*>
+Rule fired: Class op $p1Applicative
+Rule fired: Class op fmap
+Rule fired: Class op <*>
+Rule fired: SPEC T8848.$fFunctorShape ['T8848.Z]
diff --git a/testsuite/tests/simplCore/should_compile/T8848a.hs b/testsuite/tests/simplCore/should_compile/T8848a.hs
new file mode 100644
index 0000000000..81e757f8c2
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T8848a.hs
@@ -0,0 +1,19 @@
+module T8848a where
+
+f :: Ord a => b -> a -> a
+f y x = x
+
+{-# SPECIALISE f :: b -> [Int] -> [Int] #-}
+
+{- Specialised badly:
+
+"SPEC Spec.f" [ALWAYS]
+    forall (@ b_aX7).
+      Spec.f @ b_aX7
+             @ [GHC.Types.Int]
+             (GHC.Classes.$fOrd[]
+                @ GHC.Types.Int
+                (GHC.Classes.$fEq[] @ GHC.Types.Int GHC.Classes.$fEqInt)
+                GHC.Classes.$fOrdInt)
+      = Spec.f_$sf @ b_aX7
+-}
\ No newline at end of file
diff --git a/testsuite/tests/simplCore/should_compile/T8848a.stderr b/testsuite/tests/simplCore/should_compile/T8848a.stderr
new file mode 100644
index 0000000000..781d537e68
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T8848a.stderr
@@ -0,0 +1,8 @@
+
+==================== Tidy Core rules ====================
+"SPEC T8848a.f" [ALWAYS]
+    forall (@ b) ($dOrd :: GHC.Classes.Ord [GHC.Types.Int]).
+      T8848a.f @ b @ [GHC.Types.Int] $dOrd
+      = T8848a.f_$sf @ b
+
+
diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T
index 9e779264ab..5f8ddd985a 100644
--- a/testsuite/tests/simplCore/should_compile/all.T
+++ b/testsuite/tests/simplCore/should_compile/all.T
@@ -202,3 +202,5 @@ test('T8832',
      extra_clean(['T8832.hi', 'T8832a.o']),
      run_command,
      ['$MAKE -s --no-print-directory T8832'])
+test('T8848', only_ways(['optasm']), compile, ['-ddump-rule-firings'])
+test('T8848a', only_ways(['optasm']), compile, ['-ddump-rules'])