diff options
| author | Simon Peyton Jones <simonpj@microsoft.com> | 2012-07-21 18:01:03 +0100 |
|---|---|---|
| committer | Simon Peyton Jones <simonpj@microsoft.com> | 2012-07-21 18:01:03 +0100 |
| commit | 7cf9432ad3923851e0222767432e3398f01199df (patch) | |
| tree | e499399e63fb2299dca93c44f7ef2b69363c046d /testsuite/tests/rebindable | |
| parent | 94187d0c0fadff9c57da3f78ffc67c6dd80d9619 (diff) | |
| download | haskell-7cf9432ad3923851e0222767432e3398f01199df.tar.gz | |
Test Trac #5821
Diffstat (limited to 'testsuite/tests/rebindable')
| -rw-r--r-- | testsuite/tests/rebindable/T5821.hs | 71 | ||||
| -rw-r--r-- | testsuite/tests/rebindable/all.T | 2 |
2 files changed, 73 insertions, 0 deletions
diff --git a/testsuite/tests/rebindable/T5821.hs b/testsuite/tests/rebindable/T5821.hs new file mode 100644 index 0000000000..7b4f90558f --- /dev/null +++ b/testsuite/tests/rebindable/T5821.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE
+ ExplicitForAll
+ , GADTs
+ , RebindableSyntax #-}
+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
+module T5821a
+ ( Writer
+ , runWriter
+ , execWriter
+ , WriterT
+ , runWriterT
+ , execWriterT
+ , tell
+ ) where
+
+import Control.Category (Category (id), (>>>))
+
+import Prelude hiding (Monad (..), id)
+import qualified Prelude
+
+newtype Identity a = Identity { runIdentity :: a }
+
+class Monad m where
+ (>>=) :: forall e ex x a b . m e ex a -> (a -> m ex x b) -> m e x b
+ (>>) :: forall e ex x a b . m e ex a -> m ex x b -> m e x b
+ return :: a -> m ex ex a
+ fail :: String -> m e x a
+
+ {-# INLINE (>>) #-}
+ m >> k = m >>= \ _ -> k
+ fail = error
+
+type Writer w = WriterT w Identity
+
+runWriter :: Writer w e x a -> (a, w e x)
+runWriter = runIdentity . runWriterT
+
+execWriter :: Writer w e x a -> w e x
+execWriter m = snd (runWriter m)
+
+newtype WriterT w m e x a = WriterT { runWriterT :: m (a, w e x) }
+
+execWriterT :: Prelude.Monad m => WriterT w m e x a -> m (w e x)
+execWriterT m = do
+ ~(_, w) <- runWriterT m
+ return w
+ where
+ (>>=) = (Prelude.>>=)
+ return = Prelude.return
+
+instance (Category w, Prelude.Monad m) => Monad (WriterT w m) where
+ return a = WriterT $ return (a, id)
+ where
+ return = Prelude.return
+ m >>= k = WriterT $ do
+ ~(a, w) <- runWriterT m
+ ~(b, w') <- runWriterT (k a)
+ return (b, w >>> w')
+ where
+ (>>=) = (Prelude.>>=)
+ return = Prelude.return
+ fail msg = WriterT $ fail msg
+ where
+ fail = Prelude.fail
+
+tell :: (Category w, Prelude.Monad m) => w e x -> WriterT w m e x ()
+tell w = WriterT $ return ((), w)
+ where
+ return = Prelude.return
+
+
diff --git a/testsuite/tests/rebindable/all.T b/testsuite/tests/rebindable/all.T index 7df16d4135..a2a37d7f51 100644 --- a/testsuite/tests/rebindable/all.T +++ b/testsuite/tests/rebindable/all.T @@ -29,3 +29,5 @@ test('DoRestrictedM', normal, compile, ['']) test('DoParamM', reqlib('mtl'), compile_fail, ['']) test('T5038', normal, compile_and_run, ['']) test('T4851', normal, compile, ['']) + +test('T5821', normal, compile, ['']) |