diff --git a/Control/Monad/Cont.hs b/Control/Monad/Cont.hs new file mode 100644 --- /dev/null +++ b/Control/Monad/Cont.hs @@ -0,0 +1,123 @@ +{-# OPTIONS -fallow-undecidable-instances #-} +-- Search for -fallow-undecidable-instances to see why this is needed + +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Cont +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable (multi-parameter type classes) +-- +-- Continuation monads. +-- +----------------------------------------------------------------------------- + +module Control.Monad.Cont ( + MonadCont(..), + Cont(..), + mapCont, + withCont, + ContT(..), + mapContT, + withContT, + module Control.Monad, + module Control.Monad.Trans, + ) where + +import Prelude + +import Control.Monad +import Control.Monad.Trans +import Control.Monad.Reader +import Control.Monad.Writer +import Control.Monad.State +import Control.Monad.RWS + +class (Monad m) => MonadCont m where + callCC :: ((a -> m b) -> m a) -> m a + +-- --------------------------------------------------------------------------- +-- Our parameterizable continuation monad + +newtype Cont r a = Cont { runCont :: (a -> r) -> r } + +instance Functor (Cont r) where + fmap f m = Cont $ \c -> runCont m (c . f) + +instance Monad (Cont r) where + return a = Cont ($ a) + m >>= k = Cont $ \c -> runCont m $ \a -> runCont (k a) c + +instance MonadCont (Cont r) where + callCC f = Cont $ \c -> runCont (f (\a -> Cont $ \_ -> c a)) c + +mapCont :: (r -> r) -> Cont r a -> Cont r a +mapCont f m = Cont $ f . runCont m + +withCont :: ((b -> r) -> (a -> r)) -> Cont r a -> Cont r b +withCont f m = Cont $ runCont m . f + +-- --------------------------------------------------------------------------- +-- Our parameterizable continuation monad, with an inner monad + +newtype ContT r m a = ContT { runContT :: (a -> m r) -> m r } + +instance (Monad m) => Functor (ContT r m) where + fmap f m = ContT $ \c -> runContT m (c . f) + +instance (Monad m) => Monad (ContT r m) where + return a = ContT ($ a) + m >>= k = ContT $ \c -> runContT m (\a -> runContT (k a) c) + +instance (Monad m) => MonadCont (ContT r m) where + callCC f = ContT $ \c -> runContT (f (\a -> ContT $ \_ -> c a)) c + +instance MonadTrans (ContT r) where + lift m = ContT (m >>=) + +instance (MonadIO m) => MonadIO (ContT r m) where + liftIO = lift . liftIO + +-- Needs -fallow-undecidable-instances +instance (MonadReader r' m) => MonadReader r' (ContT r m) where + ask = lift ask + local f m = ContT $ \c -> do + r <- ask + local f (runContT m (local (const r) . c)) + +-- Needs -fallow-undecidable-instances +instance (MonadState s m) => MonadState s (ContT r m) where + get = lift get + put = lift . put + +-- ----------------------------------------------------------------------------- +-- MonadCont instances for other monad transformers + +instance (MonadCont m) => MonadCont (ReaderT r m) where + callCC f = ReaderT $ \r -> + callCC $ \c -> + runReaderT (f (\a -> ReaderT $ \_ -> c a)) r + +instance (MonadCont m) => MonadCont (StateT s m) where + callCC f = StateT $ \s -> + callCC $ \c -> + runStateT (f (\a -> StateT $ \s' -> c (a, s'))) s + +instance (Monoid w, MonadCont m) => MonadCont (WriterT w m) where + callCC f = WriterT $ + callCC $ \c -> + runWriterT (f (\a -> WriterT $ c (a, mempty))) + +instance (Monoid w, MonadCont m) => MonadCont (RWST r w s m) where + callCC f = RWST $ \r s -> + callCC $ \c -> + runRWST (f (\a -> RWST $ \_ s' -> c (a, s', mempty))) r s + +mapContT :: (m r -> m r) -> ContT r m a -> ContT r m a +mapContT f m = ContT $ f . runContT m + +withContT :: ((b -> m r) -> (a -> m r)) -> ContT r m a -> ContT r m b +withContT f m = ContT $ runContT m . f diff --git a/Control/Monad/Error.hs b/Control/Monad/Error.hs new file mode 100644 --- /dev/null +++ b/Control/Monad/Error.hs @@ -0,0 +1,221 @@ +{-# OPTIONS -fallow-undecidable-instances #-} +-- Needed for the same reasons as in Reader, State etc + +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Error +-- Copyright : (c) Michael Weber , 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable (multi-parameter type classes) +-- +-- The Error monad. +-- +-- Rendered by Michael Weber , +-- inspired by the Haskell Monad Template Library from +-- Andy Gill () +-- +----------------------------------------------------------------------------- + +module Control.Monad.Error ( + Error(..), + MonadError(..), + ErrorT(..), + mapErrorT, + module Control.Monad, + module Control.Monad.Fix, + module Control.Monad.Trans, + ) where + +import Prelude + +import Control.Monad +import Control.Monad.Fix +import Control.Monad.Trans +import Control.Monad.Reader +import Control.Monad.Writer +import Control.Monad.State +import Control.Monad.RWS +import Control.Monad.Cont + +import Control.Monad.Instances () +import System.IO + +-- --------------------------------------------------------------------------- +-- class MonadError +-- +-- throws an exception inside the monad and thus interrupts +-- normal execution order, until an error handler is reached} +-- +-- catches an exception inside the monad (that was previously +-- thrown by throwError + +class Error a where + noMsg :: a + strMsg :: String -> a + + noMsg = strMsg "" + strMsg _ = noMsg + +instance Error [Char] where + noMsg = "" + strMsg = id + +instance Error IOError where + strMsg = userError + +class (Monad m) => MonadError e m | m -> e where + throwError :: e -> m a + catchError :: m a -> (e -> m a) -> m a + +instance MonadPlus IO where + mzero = ioError (userError "mzero") + m `mplus` n = m `catch` \_ -> n + +instance MonadError IOError IO where + throwError = ioError + catchError = catch + +-- --------------------------------------------------------------------------- +-- Our parameterizable error monad + +instance (Error e) => Monad (Either e) where + return = Right + Left l >>= _ = Left l + Right r >>= k = k r + fail msg = Left (strMsg msg) + +instance (Error e) => MonadPlus (Either e) where + mzero = Left noMsg + Left _ `mplus` n = n + m `mplus` _ = m + +instance (Error e) => MonadFix (Either e) where + mfix f = let + a = f $ case a of + Right r -> r + _ -> error "empty mfix argument" + in a + +instance (Error e) => MonadError e (Either e) where + throwError = Left + Left l `catchError` h = h l + Right r `catchError` _ = Right r + +-- --------------------------------------------------------------------------- +-- Our parameterizable error monad, with an inner monad + +newtype ErrorT e m a = ErrorT { runErrorT :: m (Either e a) } + +-- The ErrorT Monad structure is parameterized over two things: +-- * e - The error type. +-- * m - The inner monad. + +-- Here are some examples of use: +-- +-- type ErrorWithIO e a = ErrorT e IO a +-- ==> ErrorT (IO (Either e a)) +-- +-- type ErrorAndStateWithIO e s a = ErrorT e (StateT s IO) a +-- ==> ErrorT (StateT s IO (Either e a)) +-- ==> ErrorT (StateT (s -> IO (Either e a,s))) +-- + +instance (Monad m) => Functor (ErrorT e m) where + fmap f m = ErrorT $ do + a <- runErrorT m + case a of + Left l -> return (Left l) + Right r -> return (Right (f r)) + +instance (Monad m, Error e) => Monad (ErrorT e m) where + return a = ErrorT $ return (Right a) + m >>= k = ErrorT $ do + a <- runErrorT m + case a of + Left l -> return (Left l) + Right r -> runErrorT (k r) + fail msg = ErrorT $ return (Left (strMsg msg)) + +instance (Monad m, Error e) => MonadPlus (ErrorT e m) where + mzero = ErrorT $ return (Left noMsg) + m `mplus` n = ErrorT $ do + a <- runErrorT m + case a of + Left _ -> runErrorT n + Right r -> return (Right r) + +instance (MonadFix m, Error e) => MonadFix (ErrorT e m) where + mfix f = ErrorT $ mfix $ \a -> runErrorT $ f $ case a of + Right r -> r + _ -> error "empty mfix argument" + +instance (Monad m, Error e) => MonadError e (ErrorT e m) where + throwError l = ErrorT $ return (Left l) + m `catchError` h = ErrorT $ do + a <- runErrorT m + case a of + Left l -> runErrorT (h l) + Right r -> return (Right r) + +instance (Error e) => MonadTrans (ErrorT e) where + lift m = ErrorT $ do + a <- m + return (Right a) + +instance (Error e, MonadIO m) => MonadIO (ErrorT e m) where + liftIO = lift . liftIO + +instance (Error e, MonadReader r m) => MonadReader r (ErrorT e m) where + ask = lift ask + local f m = ErrorT $ local f (runErrorT m) + +instance (Error e, MonadWriter w m) => MonadWriter w (ErrorT e m) where + tell = lift . tell + listen m = ErrorT $ do + (a, w) <- listen (runErrorT m) + return $ case a of + Left l -> Left l + Right r -> Right (r, w) + pass m = ErrorT $ pass $ do + a <- runErrorT m + return $ case a of + Left l -> (Left l, id) + Right (r, f) -> (Right r, f) + +instance (Error e, MonadState s m) => MonadState s (ErrorT e m) where + get = lift get + put = lift . put + +instance (Error e, MonadCont m) => MonadCont (ErrorT e m) where + callCC f = ErrorT $ + callCC $ \c -> + runErrorT (f (\a -> ErrorT $ c (Right a))) + +mapErrorT :: (m (Either e a) -> n (Either e' b)) -> ErrorT e m a -> ErrorT e' n b +mapErrorT f m = ErrorT $ f (runErrorT m) + +-- --------------------------------------------------------------------------- +-- MonadError instances for other monad transformers + +instance (MonadError e m) => MonadError e (ReaderT r m) where + throwError = lift . throwError + m `catchError` h = ReaderT $ \r -> runReaderT m r + `catchError` \e -> runReaderT (h e) r + +instance (Monoid w, MonadError e m) => MonadError e (WriterT w m) where + throwError = lift . throwError + m `catchError` h = WriterT $ runWriterT m + `catchError` \e -> runWriterT (h e) + +instance (MonadError e m) => MonadError e (StateT s m) where + throwError = lift . throwError + m `catchError` h = StateT $ \s -> runStateT m s + `catchError` \e -> runStateT (h e) s + +instance (Monoid w, MonadError e m) => MonadError e (RWST r w s m) where + throwError = lift . throwError + m `catchError` h = RWST $ \r s -> runRWST m r s + `catchError` \e -> runRWST (h e) r s diff --git a/Control/Monad/Identity.hs b/Control/Monad/Identity.hs new file mode 100644 --- /dev/null +++ b/Control/Monad/Identity.hs @@ -0,0 +1,60 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Identity +-- Copyright : (c) Andy Gill 2001, +-- (c) Oregon Graduate Institute of Science and Technology, 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- The Identity monad. +-- +-- Inspired by the paper +-- /Functional Programming with Overloading and +-- Higher-Order Polymorphism/, +-- Mark P Jones () +-- Advanced School of Functional Programming, 1995. +-- +----------------------------------------------------------------------------- + +module Control.Monad.Identity ( + Identity(..), + module Control.Monad, + module Control.Monad.Fix, + ) where + +import Prelude + +import Control.Monad +import Control.Monad.Fix + +-- --------------------------------------------------------------------------- +-- Identity wrapper +-- +-- Abstraction for wrapping up a object. +-- If you have an monadic function, say: +-- +-- example :: Int -> IdentityMonad Int +-- example x = return (x*x) +-- +-- you can "run" it, using +-- +-- Main> runIdentity (example 42) +-- 1764 :: Int + +newtype Identity a = Identity { runIdentity :: a } + +-- --------------------------------------------------------------------------- +-- Identity instances for Functor and Monad + +instance Functor Identity where + fmap f m = Identity (f (runIdentity m)) + +instance Monad Identity where + return a = Identity a + m >>= k = k (runIdentity m) + +instance MonadFix Identity where + mfix f = Identity (fix (runIdentity . f)) diff --git a/Control/Monad/List.hs b/Control/Monad/List.hs new file mode 100644 --- /dev/null +++ b/Control/Monad/List.hs @@ -0,0 +1,87 @@ +{-# OPTIONS -fallow-undecidable-instances #-} +-- Needed for the same reasons as in Reader, State etc + +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.List +-- Copyright : (c) Andy Gill 2001, +-- (c) Oregon Graduate Institute of Science and Technology, 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable (multi-parameter type classes) +-- +-- The List monad. +-- +----------------------------------------------------------------------------- + +module Control.Monad.List ( + ListT(..), + mapListT, + module Control.Monad, + module Control.Monad.Trans, + ) where + +import Prelude + +import Control.Monad +import Control.Monad.Trans +import Control.Monad.Reader +import Control.Monad.State +import Control.Monad.Cont +import Control.Monad.Error + +-- --------------------------------------------------------------------------- +-- Our parameterizable list monad, with an inner monad + +newtype ListT m a = ListT { runListT :: m [a] } + +instance (Monad m) => Functor (ListT m) where + fmap f m = ListT $ do + a <- runListT m + return (map f a) + +instance (Monad m) => Monad (ListT m) where + return a = ListT $ return [a] + m >>= k = ListT $ do + a <- runListT m + b <- mapM (runListT . k) a + return (concat b) + fail _ = ListT $ return [] + +instance (Monad m) => MonadPlus (ListT m) where + mzero = ListT $ return [] + m `mplus` n = ListT $ do + a <- runListT m + b <- runListT n + return (a ++ b) + +instance MonadTrans ListT where + lift m = ListT $ do + a <- m + return [a] + +instance (MonadIO m) => MonadIO (ListT m) where + liftIO = lift . liftIO + +instance (MonadReader s m) => MonadReader s (ListT m) where + ask = lift ask + local f m = ListT $ local f (runListT m) + +instance (MonadState s m) => MonadState s (ListT m) where + get = lift get + put = lift . put + +instance (MonadCont m) => MonadCont (ListT m) where + callCC f = ListT $ + callCC $ \c -> + runListT (f (\a -> ListT $ c [a])) + +instance (MonadError e m) => MonadError e (ListT m) where + throwError = lift . throwError + m `catchError` h = ListT $ runListT m + `catchError` \e -> runListT (h e) + +mapListT :: (m [a] -> n [b]) -> ListT m a -> ListT n b +mapListT f m = ListT $ f (runListT m) diff --git a/Control/Monad/RWS.hs b/Control/Monad/RWS.hs new file mode 100644 --- /dev/null +++ b/Control/Monad/RWS.hs @@ -0,0 +1,161 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.RWS +-- Copyright : (c) Andy Gill 2001, +-- (c) Oregon Graduate Institute of Science and Technology, 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable (multi-param classes, functional dependencies) +-- +-- Declaration of the MonadRWS class. +-- +-- Inspired by the paper +-- /Functional Programming with Overloading and +-- Higher-Order Polymorphism/, +-- Mark P Jones () +-- Advanced School of Functional Programming, 1995. +----------------------------------------------------------------------------- + +module Control.Monad.RWS ( + RWS(..), + evalRWS, + execRWS, + mapRWS, + withRWS, + RWST(..), + evalRWST, + execRWST, + mapRWST, + withRWST, + module Control.Monad.Reader, + module Control.Monad.Writer, + module Control.Monad.State, + ) where + +import Prelude + +import Control.Monad +import Control.Monad.Fix +import Control.Monad.Trans +import Control.Monad.Reader +import Control.Monad.Writer +import Control.Monad.State +import Data.Monoid + +newtype RWS r w s a = RWS { runRWS :: r -> s -> (a, s, w) } + +instance Functor (RWS r w s) where + fmap f m = RWS $ \r s -> let + (a, s', w) = runRWS m r s + in (f a, s', w) + +instance (Monoid w) => Monad (RWS r w s) where + return a = RWS $ \_ s -> (a, s, mempty) + m >>= k = RWS $ \r s -> let + (a, s', w) = runRWS m r s + (b, s'', w') = runRWS (k a) r s' + in (b, s'', w `mappend` w') + +instance (Monoid w) => MonadFix (RWS r w s) where + mfix f = RWS $ \r s -> let (a, s', w) = runRWS (f a) r s in (a, s', w) + +instance (Monoid w) => MonadReader r (RWS r w s) where + ask = RWS $ \r s -> (r, s, mempty) + local f m = RWS $ \r s -> runRWS m (f r) s + +instance (Monoid w) => MonadWriter w (RWS r w s) where + tell w = RWS $ \_ s -> ((), s, w) + listen m = RWS $ \r s -> let + (a, s', w) = runRWS m r s + in ((a, w), s', w) + pass m = RWS $ \r s -> let + ((a, f), s', w) = runRWS m r s + in (a, s', f w) + +instance (Monoid w) => MonadState s (RWS r w s) where + get = RWS $ \_ s -> (s, s, mempty) + put s = RWS $ \_ _ -> ((), s, mempty) + + +evalRWS :: RWS r w s a -> r -> s -> (a, w) +evalRWS m r s = let + (a, _, w) = runRWS m r s + in (a, w) + +execRWS :: RWS r w s a -> r -> s -> (s, w) +execRWS m r s = let + (_, s', w) = runRWS m r s + in (s', w) + +mapRWS :: ((a, s, w) -> (b, s, w')) -> RWS r w s a -> RWS r w' s b +mapRWS f m = RWS $ \r s -> f (runRWS m r s) + +withRWS :: (r' -> s -> (r, s)) -> RWS r w s a -> RWS r' w s a +withRWS f m = RWS $ \r s -> uncurry (runRWS m) (f r s) + + +newtype RWST r w s m a = RWST { runRWST :: r -> s -> m (a, s, w) } + +instance (Monad m) => Functor (RWST r w s m) where + fmap f m = RWST $ \r s -> do + (a, s', w) <- runRWST m r s + return (f a, s', w) + +instance (Monoid w, Monad m) => Monad (RWST r w s m) where + return a = RWST $ \_ s -> return (a, s, mempty) + m >>= k = RWST $ \r s -> do + (a, s', w) <- runRWST m r s + (b, s'',w') <- runRWST (k a) r s' + return (b, s'', w `mappend` w') + fail msg = RWST $ \_ _ -> fail msg + +instance (Monoid w, MonadPlus m) => MonadPlus (RWST r w s m) where + mzero = RWST $ \_ _ -> mzero + m `mplus` n = RWST $ \r s -> runRWST m r s `mplus` runRWST n r s + +instance (Monoid w, MonadFix m) => MonadFix (RWST r w s m) where + mfix f = RWST $ \r s -> mfix $ \ ~(a, _, _) -> runRWST (f a) r s + +instance (Monoid w, Monad m) => MonadReader r (RWST r w s m) where + ask = RWST $ \r s -> return (r, s, mempty) + local f m = RWST $ \r s -> runRWST m (f r) s + +instance (Monoid w, Monad m) => MonadWriter w (RWST r w s m) where + tell w = RWST $ \_ s -> return ((),s,w) + listen m = RWST $ \r s -> do + (a, s', w) <- runRWST m r s + return ((a, w), s', w) + pass m = RWST $ \r s -> do + ((a, f), s', w) <- runRWST m r s + return (a, s', f w) + +instance (Monoid w, Monad m) => MonadState s (RWST r w s m) where + get = RWST $ \_ s -> return (s, s, mempty) + put s = RWST $ \_ _ -> return ((), s, mempty) + +instance (Monoid w) => MonadTrans (RWST r w s) where + lift m = RWST $ \_ s -> do + a <- m + return (a, s, mempty) + +instance (Monoid w, MonadIO m) => MonadIO (RWST r w s m) where + liftIO = lift . liftIO + + +evalRWST :: (Monad m) => RWST r w s m a -> r -> s -> m (a, w) +evalRWST m r s = do + (a, _, w) <- runRWST m r s + return (a, w) + +execRWST :: (Monad m) => RWST r w s m a -> r -> s -> m (s, w) +execRWST m r s = do + (_, s', w) <- runRWST m r s + return (s', w) + +mapRWST :: (m (a, s, w) -> n (b, s, w')) -> RWST r w s m a -> RWST r w' s n b +mapRWST f m = RWST $ \r s -> f (runRWST m r s) + +withRWST :: (r' -> s -> (r, s)) -> RWST r w s m a -> RWST r' w s m a +withRWST f m = RWST $ \r s -> uncurry (runRWST m) (f r s) diff --git a/Control/Monad/Reader.hs b/Control/Monad/Reader.hs new file mode 100644 --- /dev/null +++ b/Control/Monad/Reader.hs @@ -0,0 +1,129 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Reader +-- Copyright : (c) Andy Gill 2001, +-- (c) Oregon Graduate Institute of Science and Technology, 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable (multi-param classes, functional dependencies) +-- +-- Declaration of the Monoid class,and instances for list and functions +-- +-- Inspired by the paper +-- /Functional Programming with Overloading and +-- Higher-Order Polymorphism/, +-- Mark P Jones () +-- Advanced School of Functional Programming, 1995. +----------------------------------------------------------------------------- + +module Control.Monad.Reader ( + MonadReader(..), + asks, + Reader(..), + mapReader, + withReader, + ReaderT(..), + mapReaderT, + withReaderT, + module Control.Monad, + module Control.Monad.Fix, + module Control.Monad.Trans, + ) where + +import Prelude + +import Control.Monad +import Control.Monad.Fix +import Control.Monad.Trans +import Control.Monad.Instances () + +-- ---------------------------------------------------------------------------- +-- class MonadReader +-- asks for the internal (non-mutable) state. + +class (Monad m) => MonadReader r m | m -> r where + ask :: m r + local :: (r -> r) -> m a -> m a + +-- This allows you to provide a projection function. + +asks :: (MonadReader r m) => (r -> a) -> m a +asks f = do + r <- ask + return (f r) + +-- ---------------------------------------------------------------------------- +-- The partially applied function type is a simple reader monad + +instance MonadReader r ((->) r) where + ask = id + local f m = m . f + +-- --------------------------------------------------------------------------- +-- Our parameterizable reader monad + +newtype Reader r a = Reader { runReader :: r -> a } + +instance Functor (Reader r) where + fmap f m = Reader $ \r -> f (runReader m r) + +instance Monad (Reader r) where + return a = Reader $ \_ -> a + m >>= k = Reader $ \r -> runReader (k (runReader m r)) r + +instance MonadFix (Reader r) where + mfix f = Reader $ \r -> let a = runReader (f a) r in a + +instance MonadReader r (Reader r) where + ask = Reader id + local f m = Reader $ runReader m . f + +mapReader :: (a -> b) -> Reader r a -> Reader r b +mapReader f m = Reader $ f . runReader m + +-- This is a more general version of local. + +withReader :: (r' -> r) -> Reader r a -> Reader r' a +withReader f m = Reader $ runReader m . f + +-- --------------------------------------------------------------------------- +-- Our parameterizable reader monad, with an inner monad + +newtype ReaderT r m a = ReaderT { runReaderT :: r -> m a } + +instance (Monad m) => Functor (ReaderT r m) where + fmap f m = ReaderT $ \r -> do + a <- runReaderT m r + return (f a) + +instance (Monad m) => Monad (ReaderT r m) where + return a = ReaderT $ \_ -> return a + m >>= k = ReaderT $ \r -> do + a <- runReaderT m r + runReaderT (k a) r + fail msg = ReaderT $ \_ -> fail msg + +instance (MonadPlus m) => MonadPlus (ReaderT r m) where + mzero = ReaderT $ \_ -> mzero + m `mplus` n = ReaderT $ \r -> runReaderT m r `mplus` runReaderT n r + +instance (MonadFix m) => MonadFix (ReaderT r m) where + mfix f = ReaderT $ \r -> mfix $ \a -> runReaderT (f a) r + +instance (Monad m) => MonadReader r (ReaderT r m) where + ask = ReaderT return + local f m = ReaderT $ \r -> runReaderT m (f r) + +instance MonadTrans (ReaderT r) where + lift m = ReaderT $ \_ -> m + +instance (MonadIO m) => MonadIO (ReaderT r m) where + liftIO = lift . liftIO + +mapReaderT :: (m a -> n b) -> ReaderT w m a -> ReaderT w n b +mapReaderT f m = ReaderT $ f . runReaderT m + +withReaderT :: (r' -> r) -> ReaderT r m a -> ReaderT r' m a +withReaderT f m = ReaderT $ runReaderT m . f diff --git a/Control/Monad/State.hs b/Control/Monad/State.hs new file mode 100644 --- /dev/null +++ b/Control/Monad/State.hs @@ -0,0 +1,338 @@ +{-# OPTIONS -fallow-undecidable-instances #-} +-- Search for -fallow-undecidable-instances to see why this is needed + +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.State +-- Copyright : (c) Andy Gill 2001, +-- (c) Oregon Graduate Institute of Science and Technology, 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable (multi-param classes, functional dependencies) +-- +-- State monads. +-- +-- This module is inspired by the paper +-- /Functional Programming with Overloading and +-- Higher-Order Polymorphism/, +-- Mark P Jones () +-- Advanced School of Functional Programming, 1995. +-- +-- See below for examples. + +----------------------------------------------------------------------------- + +module Control.Monad.State ( + -- * MonadState class + MonadState(..), + modify, + gets, + -- * The State Monad + State(..), + evalState, + execState, + mapState, + withState, + -- * The StateT Monad + StateT(..), + evalStateT, + execStateT, + mapStateT, + withStateT, + module Control.Monad, + module Control.Monad.Fix, + module Control.Monad.Trans, + -- * Examples + -- $examples + ) where + +import Prelude + +import Control.Monad +import Control.Monad.Fix +import Control.Monad.Trans +import Control.Monad.Reader +import Control.Monad.Writer + +-- --------------------------------------------------------------------------- +-- | /get/ returns the state from the internals of the monad. +-- +-- /put/ replaces the state inside the monad. + +class (Monad m) => MonadState s m | m -> s where + get :: m s + put :: s -> m () + +-- | Monadic state transformer. +-- +-- Maps an old state to a new state inside a state monad. +-- The old state is thrown away. +-- +-- > Main> :t modify ((+1) :: Int -> Int) +-- > modify (...) :: (MonadState Int a) => a () +-- +-- This says that @modify (+1)@ acts over any +-- Monad that is a member of the @MonadState@ class, +-- with an @Int@ state. + +modify :: (MonadState s m) => (s -> s) -> m () +modify f = do + s <- get + put (f s) + +-- | Gets specific component of the state, using a projection function +-- supplied. + +gets :: (MonadState s m) => (s -> a) -> m a +gets f = do + s <- get + return (f s) + +-- --------------------------------------------------------------------------- +-- | A parameterizable state monad where /s/ is the type of the state +-- to carry and /a/ is the type of the /return value/. + +newtype State s a = State { runState :: s -> (a, s) } + +-- The State Monad structure is parameterized over just the state. + +instance Functor (State s) where + fmap f m = State $ \s -> let + (a, s') = runState m s + in (f a, s') + +instance Monad (State s) where + return a = State $ \s -> (a, s) + m >>= k = State $ \s -> let + (a, s') = runState m s + in runState (k a) s' + +instance MonadFix (State s) where + mfix f = State $ \s -> let (a, s') = runState (f a) s in (a, s') + +instance MonadState s (State s) where + get = State $ \s -> (s, s) + put s = State $ \_ -> ((), s) + +-- |Evaluate this state monad with the given initial state,throwing +-- away the final state. Very much like @fst@ composed with +-- @runstate@. + +evalState :: State s a -- ^The state to evaluate + -> s -- ^An initial value + -> a -- ^The return value of the state application +evalState m s = fst (runState m s) + +-- |Execute this state and return the new state, throwing away the +-- return value. Very much like @snd@ composed with +-- @runstate@. + +execState :: State s a -- ^The state to evaluate + -> s -- ^An initial value + -> s -- ^The new state +execState m s = snd (runState m s) + +-- |Map a stateful computation from one (return value, state) pair to +-- another. For instance, to convert numberTree from a function that +-- returns a tree to a function that returns the sum of the numbered +-- tree (see the Examples section for numberTree and sumTree) you may +-- write: +-- +-- > sumNumberedTree :: (Eq a) => Tree a -> State (Table a) Int +-- > sumNumberedTree = mapState (\ (t, tab) -> (sumTree t, tab)) . numberTree + +mapState :: ((a, s) -> (b, s)) -> State s a -> State s b +mapState f m = State $ f . runState m + +-- |Apply this function to this state and return the resulting state. +withState :: (s -> s) -> State s a -> State s a +withState f m = State $ runState m . f + +-- --------------------------------------------------------------------------- +-- | A parameterizable state monad for encapsulating an inner +-- monad. +-- +-- The StateT Monad structure is parameterized over two things: +-- +-- * s - The state. +-- +-- * m - The inner monad. +-- +-- Here are some examples of use: +-- +-- (Parser from ParseLib with Hugs) +-- +-- > type Parser a = StateT String [] a +-- > ==> StateT (String -> [(a,String)]) +-- +-- For example, item can be written as: +-- +-- > item = do (x:xs) <- get +-- > put xs +-- > return x +-- > +-- > type BoringState s a = StateT s Indentity a +-- > ==> StateT (s -> Identity (a,s)) +-- > +-- > type StateWithIO s a = StateT s IO a +-- > ==> StateT (s -> IO (a,s)) +-- > +-- > type StateWithErr s a = StateT s Maybe a +-- > ==> StateT (s -> Maybe (a,s)) + +newtype StateT s m a = StateT { runStateT :: s -> m (a,s) } + +instance (Monad m) => Functor (StateT s m) where + fmap f m = StateT $ \s -> do + (x, s') <- runStateT m s + return (f x, s') + +instance (Monad m) => Monad (StateT s m) where + return a = StateT $ \s -> return (a, s) + m >>= k = StateT $ \s -> do + (a, s') <- runStateT m s + runStateT (k a) s' + fail str = StateT $ \_ -> fail str + +instance (MonadPlus m) => MonadPlus (StateT s m) where + mzero = StateT $ \_ -> mzero + m `mplus` n = StateT $ \s -> runStateT m s `mplus` runStateT n s + +instance (MonadFix m) => MonadFix (StateT s m) where + mfix f = StateT $ \s -> mfix $ \ ~(a, _) -> runStateT (f a) s + +instance (Monad m) => MonadState s (StateT s m) where + get = StateT $ \s -> return (s, s) + put s = StateT $ \_ -> return ((), s) + +instance MonadTrans (StateT s) where + lift m = StateT $ \s -> do + a <- m + return (a, s) + +instance (MonadIO m) => MonadIO (StateT s m) where + liftIO = lift . liftIO + +-- Needs -fallow-undecidable-instances +instance (MonadReader r m) => MonadReader r (StateT s m) where + ask = lift ask + local f m = StateT $ \s -> local f (runStateT m s) + +-- Needs -fallow-undecidable-instances +instance (MonadWriter w m) => MonadWriter w (StateT s m) where + tell = lift . tell + listen m = StateT $ \s -> do + ((a, s'), w) <- listen (runStateT m s) + return ((a, w), s') + pass m = StateT $ \s -> pass $ do + ((a, f), s') <- runStateT m s + return ((a, s'), f) + +-- |Similar to 'evalState' +evalStateT :: (Monad m) => StateT s m a -> s -> m a +evalStateT m s = do + (a, _) <- runStateT m s + return a + +-- |Similar to 'execState' +execStateT :: (Monad m) => StateT s m a -> s -> m s +execStateT m s = do + (_, s') <- runStateT m s + return s' + +-- |Similar to 'mapState' +mapStateT :: (m (a, s) -> n (b, s)) -> StateT s m a -> StateT s n b +mapStateT f m = StateT $ f . runStateT m + +-- |Similar to 'withState' +withStateT :: (s -> s) -> StateT s m a -> StateT s m a +withStateT f m = StateT $ runStateT m . f + +-- --------------------------------------------------------------------------- +-- MonadState instances for other monad transformers + +-- Needs -fallow-undecidable-instances +instance (MonadState s m) => MonadState s (ReaderT r m) where + get = lift get + put = lift . put + +-- Needs -fallow-undecidable-instances +instance (Monoid w, MonadState s m) => MonadState s (WriterT w m) where + get = lift get + put = lift . put + +-- --------------------------------------------------------------------------- +-- $examples +-- A function to increment a counter. Taken from the paper +-- /Generalising Monads to Arrows/, John +-- Hughes (), November 1998: +-- +-- > tick :: State Int Int +-- > tick = do n <- get +-- > put (n+1) +-- > return n +-- +-- Add one to the given number using the state monad: +-- +-- > plusOne :: Int -> Int +-- > plusOne n = execState tick n +-- +-- A contrived addition example. Works only with positive numbers: +-- +-- > plus :: Int -> Int -> Int +-- > plus n x = execState (sequence $ replicate n tick) x +-- +-- An example from /The Craft of Functional Programming/, Simon +-- Thompson (), +-- Addison-Wesley 1999: \"Given an arbitrary tree, transform it to a +-- tree of integers in which the original elements are replaced by +-- natural numbers, starting from 0. The same element has to be +-- replaced by the same number at every occurrence, and when we meet +-- an as-yet-unvisited element we have to find a \'new\' number to match +-- it with:\" +-- +-- > data Tree a = Nil | Node a (Tree a) (Tree a) deriving (Show, Eq) +-- > type Table a = [a] +-- +-- > numberTree :: Eq a => Tree a -> State (Table a) (Tree Int) +-- > numberTree Nil = return Nil +-- > numberTree (Node x t1 t2) +-- > = do num <- numberNode x +-- > nt1 <- numberTree t1 +-- > nt2 <- numberTree t2 +-- > return (Node num nt1 nt2) +-- > where +-- > numberNode :: Eq a => a -> State (Table a) Int +-- > numberNode x +-- > = do table <- get +-- > (newTable, newPos) <- return (nNode x table) +-- > put newTable +-- > return newPos +-- > nNode:: (Eq a) => a -> Table a -> (Table a, Int) +-- > nNode x table +-- > = case (findIndexInList (== x) table) of +-- > Nothing -> (table ++ [x], length table) +-- > Just i -> (table, i) +-- > findIndexInList :: (a -> Bool) -> [a] -> Maybe Int +-- > findIndexInList = findIndexInListHelp 0 +-- > findIndexInListHelp _ _ [] = Nothing +-- > findIndexInListHelp count f (h:t) +-- > = if (f h) +-- > then Just count +-- > else findIndexInListHelp (count+1) f t +-- +-- numTree applies numberTree with an initial state: +-- +-- > numTree :: (Eq a) => Tree a -> Tree Int +-- > numTree t = evalState (numberTree t) [] +-- +-- > testTree = Node "Zero" (Node "One" (Node "Two" Nil Nil) (Node "One" (Node "Zero" Nil Nil) Nil)) Nil +-- > numTree testTree => Node 0 (Node 1 (Node 2 Nil Nil) (Node 1 (Node 0 Nil Nil) Nil)) Nil +-- +-- sumTree is a little helper function that does not use the State monad: +-- +-- > sumTree :: (Num a) => Tree a -> a +-- > sumTree Nil = 0 +-- > sumTree (Node e t1 t2) = e + (sumTree t1) + (sumTree t2) diff --git a/Control/Monad/Trans.hs b/Control/Monad/Trans.hs new file mode 100644 --- /dev/null +++ b/Control/Monad/Trans.hs @@ -0,0 +1,44 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Trans +-- Copyright : (c) Andy Gill 2001, +-- (c) Oregon Graduate Institute of Science and Technology, 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- The MonadTrans class. +-- +-- Inspired by the paper +-- /Functional Programming with Overloading and +-- Higher-Order Polymorphism/, +-- Mark P Jones () +-- Advanced School of Functional Programming, 1995. +----------------------------------------------------------------------------- + +module Control.Monad.Trans ( + MonadTrans(..), + MonadIO(..), + ) where + +import Prelude + +import System.IO + +-- --------------------------------------------------------------------------- +-- MonadTrans class +-- +-- Monad to facilitate stackable Monads. +-- Provides a way of digging into an outer +-- monad, giving access to (lifting) the inner monad. + +class MonadTrans t where + lift :: Monad m => m a -> t m a + +class (Monad m) => MonadIO m where + liftIO :: IO a -> m a + +instance MonadIO IO where + liftIO = id diff --git a/Control/Monad/Writer.hs b/Control/Monad/Writer.hs new file mode 100644 --- /dev/null +++ b/Control/Monad/Writer.hs @@ -0,0 +1,172 @@ +{-# OPTIONS -fallow-undecidable-instances #-} +-- Search for -fallow-undecidable-instances to see why this is needed + +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Writer +-- Copyright : (c) Andy Gill 2001, +-- (c) Oregon Graduate Institute of Science and Technology, 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable (multi-param classes, functional dependencies) +-- +-- The MonadWriter class. +-- +-- Inspired by the paper +-- /Functional Programming with Overloading and +-- Higher-Order Polymorphism/, +-- Mark P Jones () +-- Advanced School of Functional Programming, 1995. +----------------------------------------------------------------------------- + +module Control.Monad.Writer ( + MonadWriter(..), + listens, + censor, + Writer(..), + execWriter, + mapWriter, + WriterT(..), + execWriterT, + mapWriterT, + module Control.Monad, + module Control.Monad.Fix, + module Control.Monad.Trans, + module Data.Monoid, + ) where + +import Prelude + +import Control.Monad +import Control.Monad.Fix +import Control.Monad.Trans +import Control.Monad.Reader +import Data.Monoid + +-- --------------------------------------------------------------------------- +-- MonadWriter class +-- +-- tell is like tell on the MUD's it shouts to monad +-- what you want to be heard. The monad carries this 'packet' +-- upwards, merging it if needed (hence the Monoid requirement)} +-- +-- listen listens to a monad acting, and returns what the monad "said". +-- +-- pass lets you provide a writer transformer which changes internals of +-- the written object. + +class (Monoid w, Monad m) => MonadWriter w m | m -> w where + tell :: w -> m () + listen :: m a -> m (a, w) + pass :: m (a, w -> w) -> m a + +listens :: (MonadWriter w m) => (w -> b) -> m a -> m (a, b) +listens f m = do + (a, w) <- listen m + return (a, f w) + +censor :: (MonadWriter w m) => (w -> w) -> m a -> m a +censor f m = pass $ do + a <- m + return (a, f) + +-- --------------------------------------------------------------------------- +-- Our parameterizable writer monad + +newtype Writer w a = Writer { runWriter :: (a, w) } + + +instance Functor (Writer w) where + fmap f m = Writer $ let (a, w) = runWriter m in (f a, w) + +instance (Monoid w) => Monad (Writer w) where + return a = Writer (a, mempty) + m >>= k = Writer $ let + (a, w) = runWriter m + (b, w') = runWriter (k a) + in (b, w `mappend` w') + +instance (Monoid w) => MonadFix (Writer w) where + mfix m = Writer $ let (a, w) = runWriter (m a) in (a, w) + +instance (Monoid w) => MonadWriter w (Writer w) where + tell w = Writer ((), w) + listen m = Writer $ let (a, w) = runWriter m in ((a, w), w) + pass m = Writer $ let ((a, f), w) = runWriter m in (a, f w) + + +execWriter :: Writer w a -> w +execWriter m = snd (runWriter m) + +mapWriter :: ((a, w) -> (b, w')) -> Writer w a -> Writer w' b +mapWriter f m = Writer $ f (runWriter m) + +-- --------------------------------------------------------------------------- +-- Our parameterizable writer monad, with an inner monad + +newtype WriterT w m a = WriterT { runWriterT :: m (a, w) } + + +instance (Monad m) => Functor (WriterT w m) where + fmap f m = WriterT $ do + (a, w) <- runWriterT m + return (f a, w) + +instance (Monoid w, Monad m) => Monad (WriterT w m) where + return a = WriterT $ return (a, mempty) + m >>= k = WriterT $ do + (a, w) <- runWriterT m + (b, w') <- runWriterT (k a) + return (b, w `mappend` w') + fail msg = WriterT $ fail msg + +instance (Monoid w, MonadPlus m) => MonadPlus (WriterT w m) where + mzero = WriterT mzero + m `mplus` n = WriterT $ runWriterT m `mplus` runWriterT n + +instance (Monoid w, MonadFix m) => MonadFix (WriterT w m) where + mfix m = WriterT $ mfix $ \ ~(a, _) -> runWriterT (m a) + +instance (Monoid w, Monad m) => MonadWriter w (WriterT w m) where + tell w = WriterT $ return ((), w) + listen m = WriterT $ do + (a, w) <- runWriterT m + return ((a, w), w) + pass m = WriterT $ do + ((a, f), w) <- runWriterT m + return (a, f w) + +instance (Monoid w) => MonadTrans (WriterT w) where + lift m = WriterT $ do + a <- m + return (a, mempty) + +instance (Monoid w, MonadIO m) => MonadIO (WriterT w m) where + liftIO = lift . liftIO + +-- This instance needs -fallow-undecidable-instances, because +-- it does not satisfy the coverage condition +instance (Monoid w, MonadReader r m) => MonadReader r (WriterT w m) where + ask = lift ask + local f m = WriterT $ local f (runWriterT m) + + +execWriterT :: Monad m => WriterT w m a -> m w +execWriterT m = do + (_, w) <- runWriterT m + return w + +mapWriterT :: (m (a, w) -> n (b, w')) -> WriterT w m a -> WriterT w' n b +mapWriterT f m = WriterT $ f (runWriterT m) + +-- --------------------------------------------------------------------------- +-- MonadWriter instances for other monad transformers + +-- This instance needs -fallow-undecidable-instances, because +-- it does not satisfy the coverage condition +instance (MonadWriter w m) => MonadWriter w (ReaderT r m) where + tell = lift . tell + listen m = ReaderT $ \w -> listen (runReaderT m w) + pass m = ReaderT $ \w -> pass (runReaderT m w) diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,31 @@ +The Glasgow Haskell Compiler License + +Copyright 2004, The University Court of the University of Glasgow. +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +- Redistributions of source code must retain the above copyright notice, +this list of conditions and the following disclaimer. + +- Redistributions in binary form must reproduce the above copyright notice, +this list of conditions and the following disclaimer in the documentation +and/or other materials provided with the distribution. + +- Neither name of the University nor the names of its contributors may be +used to endorse or promote products derived from this software without +specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF +GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, +INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE +UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH +DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/mtl.cabal b/mtl.cabal new file mode 100644 --- /dev/null +++ b/mtl.cabal @@ -0,0 +1,25 @@ +name: mtl +version: 1.0 +license: BSD3 +license-file: LICENSE +author: Andy Gill +maintainer: libraries@haskell.org +category: Control +synopsis: Monad transformer library +description: + A monad transformer library, inspired by the paper "Functional + Programming with Overloading and Higher-Order Polymorphism", + by Mark P Jones (), Advanced School + of Functional Programming, 1995. +exposed-modules: + Control.Monad.Error, + Control.Monad.Cont, + Control.Monad.Identity, + Control.Monad.List, + Control.Monad.RWS, + Control.Monad.Reader, + Control.Monad.State, + Control.Monad.Trans, + Control.Monad.Writer +build-depends: base +extensions: MultiParamTypeClasses, FunctionalDependencies