1{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} 2{-# OPTIONS_GHC -fno-warn-name-shadowing #-} 3{-# LANGUAGE 4 ExplicitForAll 5 , GADTs 6 , RebindableSyntax #-} 7module T5908 8 ( Writer 9 , runWriter 10 , execWriter 11 , WriterT 12 , runWriterT 13 , execWriterT 14 , tell 15 ) where 16 17import Control.Category (Category (id), (>>>)) 18 19import Prelude hiding (Monad (..), id) 20import qualified Prelude 21 22newtype Identity a = Identity { runIdentity :: a } 23 24class Monad m where 25 (>>=) :: forall e ex x a b . m e ex a -> (a -> m ex x b) -> m e x b 26 (>>) :: forall e ex x a b . m e ex a -> m ex x b -> m e x b 27 return :: a -> m ex ex a 28 fail :: String -> m e x a 29 30 {-# INLINE (>>) #-} 31 m >> k = m >>= \ _ -> k 32 fail = error 33 34type Writer w = WriterT w Identity 35 36runWriter :: Writer w e x a -> (a, w e x) 37runWriter = runIdentity . runWriterT 38 39execWriter :: Writer w e x a -> w e x 40execWriter m = snd (runWriter m) 41 42newtype WriterT w m e x a = WriterT { runWriterT :: m (a, w e x) } 43 44execWriterT :: Prelude.Monad m => WriterT w m e x a -> m (w e x) 45execWriterT m = do 46 ~(_, w) <- runWriterT m 47 return w 48 where 49 (>>=) = (Prelude.>>=) 50 return = Prelude.return 51 52instance (Category w, Prelude.Monad m) => Monad (WriterT w m) where 53 return a = WriterT $ return (a, id) 54 where 55 return = Prelude.return 56 m >>= k = WriterT $ do 57 ~(a, w) <- runWriterT m 58 ~(b, w') <- runWriterT (k a) 59 return (b, w >>> w') 60 where 61 (>>=) = (Prelude.>>=) 62 return = Prelude.return 63 fail msg = WriterT $ fail msg 64 where 65 fail = Prelude.fail 66 67tell :: (Category w, Prelude.Monad m) => w e x -> WriterT w m e x () 68tell w = WriterT $ return ((), w) 69 where 70 return = Prelude.return 71 72 73