[commit: testsuite] master: Test Trac #5303 (8eda816)

[Simon Peyton Jones]

Repository : ssh://darcs.haskell.org//srv/darcs/testsuite

On branch  : master

http://hackage.haskell.org/trac/ghc/changeset/8eda81625507181c93b7ddf953b1e3770a82b971

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

commit 8eda81625507181c93b7ddf953b1e3770a82b971
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Fri Jul 22 17:40:29 2011 +0100

    Test Trac #5303

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

 tests/simplCore/should_compile/T5303.hs |   44 +++++++++++++++++++++++++++++++
 tests/simplCore/should_compile/all.T    |    1 +
 2 files changed, 45 insertions(+), 0 deletions(-)

diff --git a/tests/simplCore/should_compile/T5303.hs b/tests/simplCore/should_compile/T5303.hs
new file mode 100644
index 0000000..b19eb22
--- /dev/null
+++ b/tests/simplCore/should_compile/T5303.hs
@@ -0,0 +1,44 @@
+{-# LANGUAGE KindSignatures, GADTs, TypeFamilies, MultiParamTypeClasses,  FlexibleContexts, ScopedTypeVariables, TypeSynonymInstances,  FlexibleInstances #-}  
+module T5303( showContextSeries ) where
+
+import Control.Monad.State.Strict( StateT )  
+import Control.Monad.Trans ( lift )
+
+data Tree m = Tree {}
+
+data FL (a :: * -> * -> *) x z where
+    (:>:) :: a x y -> FL a y z -> FL a x z
+    NilFL :: FL a x x
+
+class (Functor m, Monad m) => ApplyMonad m (state :: (* -> *) -> *)
+
+class Apply (p :: * -> * -> *) where
+    type ApplyState p :: (* -> *) -> *
+    apply :: ApplyMonad m (ApplyState p) => p x y -> m ()
+
+class (Functor m, Monad m, ApplyMonad (ApplyMonadOver m state) state)
+      => ApplyMonadTrans m (state :: (* -> *) -> *) where
+  type ApplyMonadOver m state :: * -> *
+  runApplyMonad :: (ApplyMonadOver m state) x -> state m -> m (x, state m)
+
+instance (Functor m, Monad m) => ApplyMonadTrans m Tree where
+  type ApplyMonadOver m Tree = TreeMonad m
+  runApplyMonad = virtualTreeMonad
+
+instance (Functor m, Monad m) => ApplyMonad (TreeMonad m) Tree
+
+-- | Internal state of the 'TreeIO' monad. Keeps track of the current Tree
+-- content, unsync'd changes and a current working directory (of the  monad).
+data TreeState m = TreeState { tree :: !(Tree m) }  
+type TreeMonad m = StateT (TreeState m) m  
+type TreeIO = TreeMonad IO
+
+virtualTreeMonad :: (Functor m, Monad m) => TreeMonad m a -> Tree m -> m  (a, Tree m)  
+virtualTreeMonad action t = undefined
+
+applyToState :: forall p m x y. (Apply p, ApplyMonadTrans m (ApplyState p))
+             => p x y -> (ApplyState p) m -> m ((ApplyState p) m)  
+applyToState _ _ = snd `fmap` runApplyMonad undefined undefined
+
+showContextSeries :: (Apply p, ApplyState p ~ Tree) => FL p x y -> TreeIO ()
+showContextSeries (p:>:_) = (undefined >>= lift . applyToState p) >>  return ()
diff --git a/tests/simplCore/should_compile/all.T b/tests/simplCore/should_compile/all.T
index 2705d8f..28be9d4 100644
--- a/tests/simplCore/should_compile/all.T
+++ b/tests/simplCore/should_compile/all.T
@@ -123,3 +123,4 @@ test('T5168',
      ['$MAKE -s --no-print-directory T5168'])
 
 test('T5329', normal, compile, [''])
+test('T5303', reqlib('mtl'), compile, [''])   # Coercion-optimiation test