Repository : ssh://git@git.haskell.org/ghc
On branch : master
Link : http://ghc.haskell.org/trac/ghc/changeset/88d94524f46df7c99214cde7e2952aacdd3fb6cc/ghc
>---------------------------------------------------------------
commit 88d94524f46df7c99214cde7e2952aacdd3fb6cc
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date: Tue Mar 25 14:34:44 2014 +0000
Test Trac #8848
>---------------------------------------------------------------
88d94524f46df7c99214cde7e2952aacdd3fb6cc
testsuite/tests/simplCore/should_compile/T8848.hs | 26 ++++++++++++++++++++
.../tests/simplCore/should_compile/T8848.stderr | 17 +++++++++++++
testsuite/tests/simplCore/should_compile/T8848a.hs | 19 ++++++++++++++
.../tests/simplCore/should_compile/T8848a.stderr | 8 ++++++
testsuite/tests/simplCore/should_compile/all.T | 2 ++
5 files changed, 72 insertions(+)
diff --git a/testsuite/tests/simplCore/should_compile/T8848.hs b/testsuite/tests/simplCore/should_compile/T8848.hs
new file mode 100644
index 0000000..1ddfe94
--- /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 0000000..1a62868
--- /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 0000000..81e757f
--- /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 0000000..781d537
--- /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 9e77926..5f8ddd9 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'])