From ec61b893cef9578457201bda1e159bd3dc076ec9 Mon Sep 17 00:00:00 2001 From: diatchki Date: Tue, 3 Jun 2003 22:26:50 +0000 Subject: [PATCH] [project @ 2003-06-03 22:26:44 by diatchki] Added a first version of the new monad library (experimental). Hopefully one day the "X" will disappear. --- Control/Monad/X/Cont.hs | 12 ++ Control/Monad/X/ContT.hs | 90 ++++++++++++ Control/Monad/X/Error.hs | 12 ++ Control/Monad/X/ErrorT.hs | 86 +++++++++++ Control/Monad/X/Fix.hs | 103 +++++++++++++ Control/Monad/X/Identity.hs | 56 +++++++ Control/Monad/X/Monads.hs | 13 ++ Control/Monad/X/Nondet.hs | 16 ++ Control/Monad/X/NondetT.hs | 98 +++++++++++++ Control/Monad/X/README | 80 ++++++++++ Control/Monad/X/Reader.hs | 12 ++ Control/Monad/X/ReaderT.hs | 119 +++++++++++++++ Control/Monad/X/Resume.hs | 12 ++ Control/Monad/X/ResumeT.hs | 83 +++++++++++ Control/Monad/X/State.hs | 14 ++ Control/Monad/X/StateT.hs | 124 ++++++++++++++++ Control/Monad/X/Trans.hs | 241 +++++++++++++++++++++++++++++++ Control/Monad/X/Transformers.hs | 13 ++ Control/Monad/X/Types.hs | 16 ++ Control/Monad/X/Utils.hs | 52 +++++++ Control/Monad/X/Writer.hs | 12 ++ Control/Monad/X/WriterT.hs | 106 ++++++++++++++ Control/Monad/X/laws/Prop.hs | 8 + Control/Monad/X/laws/Reader.hs | 14 ++ Control/Monad/X/laws/Writer.hs | 9 ++ Control/Monad/X/tests/ContTests.hs | 74 ++++++++++ Control/Monad/X/tests/Error.hs | 14 ++ Control/Monad/X/tests/ExceptionTests.hs | 11 ++ Control/Monad/X/tests/Nondet.hs | 5 + Control/Monad/X/tests/Reader.hs | 16 ++ Control/Monad/X/tests/ReaderNondet.hs | 21 +++ Control/Monad/X/tests/State.hs | 14 ++ Control/Monad/X/tests/Writer.hs | 18 +++ Control/Monad/X/tests/testNondet.hs | 35 +++++ 34 files changed, 1609 insertions(+) create mode 100644 Control/Monad/X/Cont.hs create mode 100644 Control/Monad/X/ContT.hs create mode 100644 Control/Monad/X/Error.hs create mode 100644 Control/Monad/X/ErrorT.hs create mode 100644 Control/Monad/X/Fix.hs create mode 100644 Control/Monad/X/Identity.hs create mode 100644 Control/Monad/X/Monads.hs create mode 100644 Control/Monad/X/Nondet.hs create mode 100644 Control/Monad/X/NondetT.hs create mode 100644 Control/Monad/X/README create mode 100644 Control/Monad/X/Reader.hs create mode 100644 Control/Monad/X/ReaderT.hs create mode 100644 Control/Monad/X/Resume.hs create mode 100644 Control/Monad/X/ResumeT.hs create mode 100644 Control/Monad/X/State.hs create mode 100644 Control/Monad/X/StateT.hs create mode 100644 Control/Monad/X/Trans.hs create mode 100644 Control/Monad/X/Transformers.hs create mode 100644 Control/Monad/X/Types.hs create mode 100644 Control/Monad/X/Utils.hs create mode 100644 Control/Monad/X/Writer.hs create mode 100644 Control/Monad/X/WriterT.hs create mode 100644 Control/Monad/X/laws/Prop.hs create mode 100644 Control/Monad/X/laws/Reader.hs create mode 100644 Control/Monad/X/laws/Writer.hs create mode 100644 Control/Monad/X/tests/ContTests.hs create mode 100644 Control/Monad/X/tests/Error.hs create mode 100644 Control/Monad/X/tests/ExceptionTests.hs create mode 100644 Control/Monad/X/tests/Nondet.hs create mode 100644 Control/Monad/X/tests/Reader.hs create mode 100644 Control/Monad/X/tests/ReaderNondet.hs create mode 100644 Control/Monad/X/tests/State.hs create mode 100644 Control/Monad/X/tests/Writer.hs create mode 100644 Control/Monad/X/tests/testNondet.hs diff --git a/Control/Monad/X/Cont.hs b/Control/Monad/X/Cont.hs new file mode 100644 index 0000000..7cd9e02 --- /dev/null +++ b/Control/Monad/X/Cont.hs @@ -0,0 +1,12 @@ +module Control.Monad.X.Cont (Cont,runCont,module T) where + +import Control.Monad.X.Identity +import qualified Control.Monad.X.ContT as C +import Control.Monad.X.Trans as T + +type Cont r = C.ContT r Identity + +runCont :: Cont a a -> a +runCont m = runIdentity (C.runCont m) + + diff --git a/Control/Monad/X/ContT.hs b/Control/Monad/X/ContT.hs new file mode 100644 index 0000000..0eeed6b --- /dev/null +++ b/Control/Monad/X/ContT.hs @@ -0,0 +1,90 @@ +----------------------------------------------------------------------------- +-- | +-- 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.X.ContT ( + ContT, + runCont, + runContT, + mapContT, + withContT, + module T + ) where + +import Prelude (Functor(..),Monad(..),(.),fst,error) +import Control.Monad(liftM,MonadPlus(..)) + +import Control.Monad.X.Trans as T +import Control.Monad.X.Utils +import Control.Monad.X.Types(ContT(..)) + + +-- unfiinished + + +instance MonadTrans (ContT r) where + lift m = C (m >>=) + +instance HasBaseMonad m n => HasBaseMonad (ContT r m) n where + inBase = inBase' + +instance (Monad m) => Functor (ContT r m) where + fmap = liftM + +instance (Monad m) => Monad (ContT r m) where + return = return' + m >>= k = C (\c -> m $$ (\a -> k a $$ c)) + + +runCont :: Monad m => ContT r m r -> m r +runCont m = m $$ return + +runContT = ($$) + +mapContT :: (m r -> m r) -> ContT r m a -> ContT r m a +mapContT f m = C (f . (m $$)) + +withContT :: ((b -> m r) -> (a -> m r)) -> ContT r m a -> ContT r m b +withContT f m = C ((m $$) . f) + +($$) = unC + +-- (a -> (e -> m a)) -> e -> m a + +instance (MonadReader r' m) => MonadReader r' (ContT r m) where + ask = ask' + local f m = C (\k -> do r <- ask + local f (m $$ (\a -> localSet r (k a)))) + + +instance (MonadWriter w m) => MonadWriter w (ContT r m) where + tell = tell' + listen = error "listen: continuations after writer not implemenetd (yet?)" + +instance (MonadState s m) => MonadState s (ContT r m) where + get = get' + put = put' + +instance (MonadError e m) => MonadError e (ContT r m) where + throwError = throwError' + catchError = catchError2' C ($$) + +instance MonadPlus m => MonadPlus (ContT r m) where + mzero = mzero + mplus = mplus2' C ($$) + +instance (Monad m) => MonadCont (ContT r m) where + callCC f = C (\c -> f (\a -> C (\_ -> c a)) $$ c) + + + diff --git a/Control/Monad/X/Error.hs b/Control/Monad/X/Error.hs new file mode 100644 index 0000000..64da3d7 --- /dev/null +++ b/Control/Monad/X/Error.hs @@ -0,0 +1,12 @@ +module Control.Monad.X.Error (Error, runError, module T) where + +import Control.Monad.X.Identity +import qualified Control.Monad.X.ErrorT as E +import Control.Monad.X.Trans as T + +type Error e = E.ErrorT e Identity + +runError :: Error e a -> Either e a +runError m = runIdentity (E.runError m) + + diff --git a/Control/Monad/X/ErrorT.hs b/Control/Monad/X/ErrorT.hs new file mode 100644 index 0000000..fd714eb --- /dev/null +++ b/Control/Monad/X/ErrorT.hs @@ -0,0 +1,86 @@ +module Control.Monad.X.ErrorT ( + ErrorT, + runError, + runErrorT, + mapErrorT, + module T + ) where + +import Prelude(Functor(..),Monad(..),Either(..),either,(.),id,error) + +import Control.Monad(MonadPlus(..),liftM) + +import Control.Monad.X.Trans as T +import Control.Monad.X.Utils +import Control.Monad.X.Types(ErrorT(..)) + + +instance MonadTrans (ErrorT e) where + lift m = E (liftM Right m) + +instance HasBaseMonad m n => HasBaseMonad (ErrorT e m) n where + inBase = inBase' + +instance (Monad m) => Functor (ErrorT e m) where + fmap = liftM + +instance (Monad m) => Monad (ErrorT e m) where + return = return' + m >>= k = E (do a <- unE m + case a of + Left l -> return (Left l) + Right r -> unE (k r)) + fail = fail' -- use 'throwErorr' to throw errors. + + +-------------------------------------------------------------------------------- + +runError = unE +runErrorT = unE + +mapErrorT :: (m (Either e a) -> n (Either e' b)) -> ErrorT e m a -> ErrorT e' n b +mapErrorT f m = E (f (unE m)) + +-------------------------------------------------------------------------------- + +instance (MonadReader r m) => MonadReader r (ErrorT e m) where + ask = ask' + local = local' mapErrorT + +instance (MonadWriter w m) => MonadWriter w (ErrorT e m) where + tell = tell' + listen = listen1' E unE (\w -> either Left (\r -> Right (r,w))) + +instance (MonadState s m) => MonadState s (ErrorT e m) where + get = get' + put = put' + +instance (Monad m) => MonadError e (ErrorT e m) where + throwError = E . return . Left + m `catchError` h = E (do a <- unE m + case a of + Left l -> unE (h l) + Right r -> return (Right r)) + +-- MonadPlus is used for Nondet, these should be moved in the nondet class +instance MonadPlus m => MonadPlus (ErrorT e m) where + mzero = mzero' + mplus = mplus1' E unE + +-- `findAll` is like catMaybes, it will aways succeed, but will only return +-- results that didn't raise an exception. +-- if all results a required, use handle to turn the failures into (tagged) successes. +instance MonadNondet m => MonadNondet (ErrorT e m) where + findAll = mapErrorT (liftM res . findAll) + where res xs = Right [ x | Right x <- xs ] + commit = mapErrorT commit + +instance MonadResume m => MonadResume (ErrorT e m) where + delay = mapErrorT delay + force = mapErrorT force + +instance (MonadCont m) => MonadCont (ErrorT e m) where + callCC = callCC1' E unE Right + + + diff --git a/Control/Monad/X/Fix.hs b/Control/Monad/X/Fix.hs new file mode 100644 index 0000000..addeedb --- /dev/null +++ b/Control/Monad/X/Fix.hs @@ -0,0 +1,103 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Fix +-- Copyright : (c) Andy Gill 2001, +-- (c) Oregon Graduate Institute of Science and Technology, 2002 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- A class for monadic (value) recursion and its implementation. +-- For details: +-- Levent Erkök. Value recursion in Monadic Computations. +-- Oregon Graduate Institute, OHSU. Portland, Oregon. October 2002. +-- http://www.cse.ogi.edu/~erkok/rmb/ +----------------------------------------------------------------------------- + +module Control.Monad.X.Fix ( + MonadFix( + mfix -- :: (a -> m a) -> m a + ), + fix -- :: (a -> a) -> a + ) where + +import Prelude +import System.IO +import Monad(liftM) + +import Control.Monad.X.Trans +import Control.Monad.X.Identity +import Control.Monad.X.Types +import Control.Monad.X.ReaderT +import Control.Monad.X.WriterT +import Control.Monad.X.StateT +import Control.Monad.X.ErrorT +import Control.Monad.X.NondetT + +fix :: (a -> a) -> a +fix f = let x = f x in x + +class (Monad m) => MonadFix m where + mfix :: (a -> m a) -> m a + + + + +instance MonadFix Maybe where + mfix f = let a = f (unJust a) in a + where unJust (Just x) = x + +instance MonadFix [] where + mfix f = case fix (f . head) of + [] -> [] + (x:_) -> x : mfix (tail . f) + +instance MonadFix IO where + mfix = fixIO + +instance MonadFix Identity where + mfix f = return (fix (runIdentity . f)) + +instance (MonadFix m) => MonadFix (ReaderT r m) where + mfix f = R (\r -> mfix (\a -> unR (f a) r)) + +instance (Monoid w, MonadFix m) => MonadFix (WriterT w m) where + mfix m = W (mfix (\ ~(a, _) -> unW (m a))) + +instance (MonadFix m) => MonadFix (StateT s m) where + mfix f = S (\s -> mfix (\ ~(a, _) -> unS (f a) s)) + +instance (MonadFix m) => MonadFix (ErrorT e m) where + mfix f = E (mfix (unE . f . either (error "ErrorT: mfix looped") id)) + +-- is that right? +instance MonadFix m => MonadFix (NondetT m) where + mfix f = N (do x <- mfix (unN . f . hd) + case x of + Empty -> return Empty + Cons a _ -> return (Cons a (mfix (tl . f)))) + where hd (Cons a _) = a + hd _ = error "NondetT: mfix looped (hd)" + tl m = N (do x <- unN m + case x of + Cons _ m -> unN m + _ -> error "NondetT: mfix looped (tl)") + + +{- +instance MonadFix m => MonadFix (NondetT m) where + mfix f = Re (do x <- mfix (unRe . f . hd) + case x of + Value a -> return (Value a) + Delay m -> return (Delay (mfix (tl . f))) + where hd (Value a) = a + hd _ = error "ResumeT: mfix looped (hd)" + tl m = Re (do x <- unRe m + case x of + + Cons _ m -> unN m + _ -> error "NondetT: mfix looped (tl)") +-} + diff --git a/Control/Monad/X/Identity.hs b/Control/Monad/X/Identity.hs new file mode 100644 index 0000000..1df1b49 --- /dev/null +++ b/Control/Monad/X/Identity.hs @@ -0,0 +1,56 @@ +----------------------------------------------------------------------------- +-- | +-- 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.X.Identity ( + Identity, + runIdentity + ) where + +import Prelude(Functor(..),Monad(..)) +import Monad(liftM) + + +-- --------------------------------------------------------------------------- +-- Identity wrapper +-- +-- Abstraction for wrapping up a object. +-- If you have an monadic function, say: +-- +-- example :: Int -> Identity Int +-- example x = return (x*x) +-- +-- you can "run" it, using +-- +-- Main> runIdentity (example 42) +-- 1764 :: Int + + +newtype Identity a = I { unI :: a } + +instance Functor Identity where + fmap = liftM + +instance Monad Identity where + return = I + m >>= k = k (unI m) + +runIdentity = unI + diff --git a/Control/Monad/X/Monads.hs b/Control/Monad/X/Monads.hs new file mode 100644 index 0000000..fa4d275 --- /dev/null +++ b/Control/Monad/X/Monads.hs @@ -0,0 +1,13 @@ +module Monads where + +-- imports everything in the library + +import Control.Monad.X.Reader +import Control.Monad.X.Writer +import Control.Monad.X.State +import Control.Monad.X.Error +import Control.Monad.X.Nondet +import Control.Monad.X.Resume +import Control.Monad.X.Cont +import Control.Monad.X.Fix + diff --git a/Control/Monad/X/Nondet.hs b/Control/Monad/X/Nondet.hs new file mode 100644 index 0000000..016944e --- /dev/null +++ b/Control/Monad/X/Nondet.hs @@ -0,0 +1,16 @@ +module Control.Monad.X.Nondet (Nondet,runNondet,runNondets,module T) where + +import Control.Monad.X.Identity +import qualified Control.Monad.X.NondetT as N +import Control.Monad.X.Trans as T + + +-- this is simply list +type Nondet = N.NondetT Identity + +runNondet :: Nondet a -> Maybe a +runNondet m = runIdentity (N.runNondet m) + +runNondets :: Nondet a -> [a] +runNondets m = runIdentity (N.runNondets m) + diff --git a/Control/Monad/X/NondetT.hs b/Control/Monad/X/NondetT.hs new file mode 100644 index 0000000..45738cc --- /dev/null +++ b/Control/Monad/X/NondetT.hs @@ -0,0 +1,98 @@ +module Control.Monad.X.NondetT + (NondetT, + runNondet, + runNondets, + mapNondetT, + MonadPlus(..), + module T + ) where + +import Prelude +import Monad(liftM,MonadPlus(..)) + +import Control.Monad.X.Trans as T +import Control.Monad.X.Utils +import Control.Monad.X.Types(NondetT(..),T(..)) + + +instance MonadTrans NondetT where + lift m = N (liftM single m) + +instance Monad m => Functor (NondetT m) where + fmap = liftM + +instance Monad m => Monad (NondetT m) where + return = return' + m >>= f = N (do x <- unN m + case x of + Empty -> return Empty + Cons a xs -> unN (mplus (f a) (xs >>= f))) + +instance HasBaseMonad m n => HasBaseMonad (NondetT m) n where + inBase = inBase' + + +-- misc functions +instance Monad m => Functor (T m) where + fmap f Empty = Empty + fmap f (Cons a m) = Cons (f a) (fmap f m) + + +single x = Cons x mzero + +flatten :: Monad m => T m a -> m [a] +flatten Empty = return [] +flatten (Cons a m) = liftM (a :) (runNondets m) + + +runNondet m = do t <- unN m + case t of + Empty -> return Nothing + Cons a _ -> return (Just a) + +runNondets m = flatten =<< unN m + +mapNondetT f (N m) = N (f m) + + +-- other features. + +instance MonadReader r m => MonadReader r (NondetT m) where + ask = ask' + local = local' mapNondetT + +instance MonadWriter w m => MonadWriter w (NondetT m) where + tell = tell' + listen = listen1' N unN (\w -> fmap (\a -> (a,w))) + +instance MonadState s m => MonadState s (NondetT m) where + get = get' + put = put' + +instance MonadError e m => MonadError e (NondetT m) where + throwError = throwError' + catchError = catchError1' N unN + +instance Monad m => MonadPlus (NondetT m) where + mzero = N (return Empty) + mplus m n = N (do x <- unN m + case x of + Empty -> unN n + Cons a m' -> return (Cons a (mplus m' n))) + +instance Monad m => MonadNondet (NondetT m) where + findAll m = lift (runNondets m) + commit m = N (do x <- unN m + case x of + Empty -> return Empty + Cons a _ -> return (single a)) + +-- ergh, what does this do? +instance (MonadCont m) => MonadCont (NondetT m) where + callCC = callCC1' N unN single + + + + + + diff --git a/Control/Monad/X/README b/Control/Monad/X/README new file mode 100644 index 0000000..e2c3fd5 --- /dev/null +++ b/Control/Monad/X/README @@ -0,0 +1,80 @@ +This is an experimental replacement for the current monad library. +(at some point the .X. part of the names should disappear) + +It is mostly complete, but some more work is needed in places, +in particular the interaction of continuations with other features. +also a lot more tests/laws are need. and of course documentation. + +Resumptions are very new and not well tested. Also the nonstandard +morphisms for them are not fixed. + +Changes from the original library +================================= + +General: + * the monads are implemented in terms of the transformers + - the transformer files end in "T" + - the monad files have no "T" at the end + - a monad file defines a type synonym, and redefines the "run" functions. + * The file Transformers imports all transformers + * The file Monads imports all monads and fix, and so everything in the library + (it is note very useful except for compiling the library) + * Currently there is no ListT, instead we have NondetT, + which is (kind of) based on what's in Ralf Hinze's + "Deriving Monad Transformers" paper. + * there is no RWS transformer + * NondetT transformer is new + * ResumeT is new + * New class HasBaseMonad to perform computations in the "heart" of the monad + * structural changes in the code + - tried to capture common patterns in definitions + - the library is currently in "column" format, i.e. + a file for a transformer contains: + - basic instances (Functor, Monad, HasBaseMonad) + - arbitrary functions (mostly from old library) things like "run" etc. + - liftings of all features only for this transformer + + - the file "Fix" is in "row" format, i.e. it implements "mfix" for all transformers. + * MonadPlus is used for backtracking and _not_ error handling + * none of the transformers implement "fail" it is just passed along to the base monad, + thus: fail x = inBase (fail x) + - reason for that is that there seems to be no reasonable way to implement it + + +Specific: + +Reader: new function runReader (like runReadrT with swapped arguments) +Writer: * new function runWriter (same as runWriterT) + * new behavior for "listen": it does not produce any output + thus: oldListen m = do (a,w) <- listen m + tell w + * moved "pass" out of the class (implemented in terms of the other functions) +State: * new functions runState (like evalState with swapped arguments) + runStateS (like runStateT with swapped arguments) +Error: * new function runError (same as runErrorT) + * removed Error class, now errors can be of any type + * fail "" does _not_ cause an error to be thrown (see comments above) + * mzero does _not_ cause an error to be thrown (see comments above) + * mplus does _not_ handle errors (see comments above) +Nondet: new +Resume: new +Cont: unfinished + - how to do "local" (current seems reasonable, but deviates from "standard" definitions) + - how to do "listen" + - understand better interaction with other control transformers + (exceptions, resumptions, nondeterminism) + + +People +====== + +discussions etc should probably be sent to: +libraries@haskell.org + +author of current version: Iavor S. Diatchki +based upon the original by: Andy Gill +the ErrorT in the original library was rendered by: Michael Weber +the initial version of the NondetT code in CPS style was from: Andrew J Bromage + +iavor: if i forgot someone (sorry!) please send me email + diff --git a/Control/Monad/X/Reader.hs b/Control/Monad/X/Reader.hs new file mode 100644 index 0000000..5667699 --- /dev/null +++ b/Control/Monad/X/Reader.hs @@ -0,0 +1,12 @@ +module Control.Monad.X.Reader (module T, Reader, runReader) where + +import Control.Monad.X.Identity +import qualified Control.Monad.X.ReaderT as R +import Control.Monad.X.Trans as T + +type Reader r = R.ReaderT r Identity + +runReader :: r -> Reader r a -> a +runReader r m = runIdentity (R.runReader r m) + + diff --git a/Control/Monad/X/ReaderT.hs b/Control/Monad/X/ReaderT.hs new file mode 100644 index 0000000..64fb538 --- /dev/null +++ b/Control/Monad/X/ReaderT.hs @@ -0,0 +1,119 @@ +----------------------------------------------------------------------------- +-- | +-- 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) +-- +-- The definition of the reader monad transformer. +-- +-- Inspired by the paper +-- /Functional Programming with Overloading and +-- Higher-Order Polymorphism/, +-- Mark P Jones () +-- Advanced School of Functional Programming, 1995. +----------------------------------------------------------------------------- + +module Control.Monad.X.ReaderT ( + ReaderT, + runReader, + runReaderT, + mapReaderT, + withReaderT, + module T, + ) where + +import Prelude (Monad(..),Functor(..),const) +import Control.Monad (MonadPlus(..),liftM) + +import Control.Monad.X.Trans as T +import Control.Monad.X.Utils +import Control.Monad.X.Types(ReaderT(..)) + + + +-- --------------------------------------------------------------------------- +-- Basic instances + +instance MonadTrans (ReaderT r) where + lift m = R (\_ -> m) + +instance HasBaseMonad m n => HasBaseMonad (ReaderT r m) n where + inBase = inBase' + +instance Monad m => Functor (ReaderT r m) where + fmap = liftM + +instance Monad m => Monad (ReaderT r m) where + fail = fail' + return = return' + m >>= f = R (\r -> (m $$ r) >>= (\a -> (f a $$ r))) + + +-- some functions + +-- | Remove a reader layer by providing a specific value for the +-- environment. +runReader :: r -> ReaderT r m a -> m a +runReader r m = m $$ r + +-- | Same as 'runReader' but with the arguments the other way around. +-- For backwards compatability. +runReaderT :: ReaderT r m a -> r -> m a +runReaderT = ($$) + +-- | Apply a function to underlying monad. +-- NOTE: SHOULD THIS BE EXPORTED? +mapReaderT :: (m a -> n b) -> ReaderT w m a -> ReaderT w n b +mapReaderT f m = R (\r -> f (m $$ r)) + +-- | A more general version of 'local' when the reader is the +-- outermost layer. +withReaderT :: (r' -> r) -> ReaderT r m a -> ReaderT r' m a +withReaderT f m = R (\r -> m $$ f r) + +-- sugar. +($$) = unR + + +-- how the features are implemented for readers + +instance (Monad m) => MonadReader r (ReaderT r m) where + ask = R return + local = withReaderT + +instance MonadWriter w m => MonadWriter w (ReaderT r m) where + tell = tell' + listen = listen2' R unR (\w a -> (a,w)) + +instance MonadState s m => MonadState s (ReaderT r m) where + get = get' + put = put' + +instance MonadError e m => MonadError e (ReaderT r m) where + throwError = throwError' + catchError = catchError2' R unR + +instance MonadPlus m => MonadPlus (ReaderT r m) where + mzero = mzero' + mplus = mplus2' R unR + +instance (MonadNondet m) => MonadNondet (ReaderT r m) where + findAll = mapReaderT findAll + commit = mapReaderT commit + +instance MonadResume m => MonadResume (ReaderT r m) where + delay = mapReaderT delay + force = mapReaderT force + +instance MonadCont m => MonadCont (ReaderT r m) where + callCC = callCC2' R unR const + + + + + diff --git a/Control/Monad/X/Resume.hs b/Control/Monad/X/Resume.hs new file mode 100644 index 0000000..fa5753a --- /dev/null +++ b/Control/Monad/X/Resume.hs @@ -0,0 +1,12 @@ +module Control.Monad.X.Resume (Resume, hyper, module T) where + +import Control.Monad.X.Identity +import qualified Control.Monad.X.ResumeT as R +import Control.Monad.X.Trans as T + +type Resume = R.ResumeT Identity + +hyper :: Resume a -> a +hyper m = runIdentity (R.hyper m) + + diff --git a/Control/Monad/X/ResumeT.hs b/Control/Monad/X/ResumeT.hs new file mode 100644 index 0000000..b8f9f25 --- /dev/null +++ b/Control/Monad/X/ResumeT.hs @@ -0,0 +1,83 @@ +module Control.Monad.X.ResumeT + (ResumeT, + hyper, + module T + ) where + +import Prelude(Functor(..),Monad(..),error) +import Control.Monad(liftM,MonadPlus(..)) + +import Control.Monad.X.Trans as T +import Control.Monad.X.Utils +import Control.Monad.X.Types (ResumeT(..), Res(..)) + +-- resumptions: +-- a transformer for explicit "lazyness" + + +instance MonadTrans ResumeT where + lift m = Re (liftM Value m) + +instance Monad m => Functor (ResumeT m) where + fmap = liftM + +instance Monad m => Monad (ResumeT m) where + return = return' + m >>= f = Re (do x <- unRe m + case x of + Value a -> unRe (f a) + Delay m -> return (Delay (m >>= f))) + +instance HasBaseMonad m n => HasBaseMonad (ResumeT m) n where + inBase = inBase' + +instance Monad m => Functor (Res m) where + fmap f (Value a) = Value (f a) + fmap f (Delay m) = Delay (liftM f m) + + + +hyper :: Monad m => ResumeT m a -> m a +hyper m = do x <- unRe m + case x of + Value a -> return a + Delay m -> hyper m + +mapResumeT f m = Re (f (unRe m)) + +instance MonadReader r m => MonadReader r (ResumeT m) where + ask = ask' + local = local' mapResumeT + +instance MonadWriter w m => MonadWriter w (ResumeT m) where + tell = tell' + listen = listen1' Re unRe (\w -> fmap (\a -> (a,w))) + +instance MonadState s m => MonadState s (ResumeT m) where + get = get' + put = put' + +instance MonadError e m => MonadError e (ResumeT m) where + throwError = throwError' + catchError = catchError1' Re unRe + +instance MonadPlus m => MonadPlus (ResumeT m) where + mzero = mzero' + mplus = mplus1' Re unRe + +instance MonadNondet m => MonadNondet (ResumeT m) where + findAll = error "findAll ResumeT TODO" + commit = mapResumeT commit + +instance Monad m => MonadResume (ResumeT m) where + delay m = Re (return (Delay m)) + force m = Re (do x <- unRe m + case x of + Value a -> return (Value a) + Delay m' -> unRe m') + +instance MonadCont m => MonadCont (ResumeT m) where + callCC = callCC1' Re unRe Value + + + diff --git a/Control/Monad/X/State.hs b/Control/Monad/X/State.hs new file mode 100644 index 0000000..8c605c8 --- /dev/null +++ b/Control/Monad/X/State.hs @@ -0,0 +1,14 @@ +module Control.Monad.X.State (State, runState, runStateS, module T) where + +import Control.Monad.X.Identity +import qualified Control.Monad.X.StateT as S +import Control.Monad.X.Trans as T + +type State s = S.StateT s Identity + +runState :: s -> State s a -> a +runState s m = runIdentity (S.runState s m) + +runStateS :: s -> State s a -> (a,s) +runStateS s m = runIdentity (S.runStateS s m) + diff --git a/Control/Monad/X/StateT.hs b/Control/Monad/X/StateT.hs new file mode 100644 index 0000000..c370a98 --- /dev/null +++ b/Control/Monad/X/StateT.hs @@ -0,0 +1,124 @@ +----------------------------------------------------------------------------- +-- | +-- 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.X.StateT ( + StateT, + runState, + runStateS, + runStateT, + evalStateT, + execStateT, + mapStateT, + withStateT, + module T + ) where + +import Prelude (Functor(..),Monad(..),(.),fst) + +import Control.Monad +import Control.Monad.X.Trans as T +import Control.Monad.X.Utils +import Control.Monad.X.Types(StateT(..)) + +instance MonadTrans (StateT s) where + lift m = S (\s -> liftM (\a -> (a,s)) m) + +instance HasBaseMonad m n => HasBaseMonad (StateT s m) n where + inBase = inBase' + +instance (Monad m) => Functor (StateT s m) where + fmap = liftM + +instance (Monad m) => Monad (StateT s m) where + return = return' + m >>= k = S (\s -> do (a, s') <- m $$ s + k a $$ s') + fail = fail' + + +runState :: Monad m => s -> StateT s m a -> m a +runState s m = liftM fst (runStateS s m) + +runStateS :: s -> StateT s m a -> m (a,s) +runStateS s m = m $$ s + + +runStateT :: StateT s m a -> s -> m (a,s) +runStateT = ($$) + +evalStateT :: (Monad m) => StateT s m a -> s -> m a +evalStateT m s = do + (a, _) <- m $$ s + return a + +execStateT :: (Monad m) => StateT s m a -> s -> m s +execStateT m s = do + (_, s') <- m $$ s + return s' + +mapStateT :: (m (a, s) -> n (b, s)) -> StateT s m a -> StateT s n b +mapStateT f m = S (f . (m $$)) + +withStateT :: (s -> s) -> StateT s m a -> StateT s m a +withStateT f m = S ((m $$) . f) + +($$) = unS + + +instance (MonadReader r m) => MonadReader r (StateT s m) where + ask = ask' + local = local' mapStateT + +instance (MonadWriter w m) => MonadWriter w (StateT s m) where + tell = tell' + listen = listen2' S unS (\w (a,s) -> ((a,w),s)) + +instance (Monad m) => MonadState s (StateT s m) where + get = S (\s -> return (s, s)) + put s = S (\_ -> return ((), s)) + +instance (MonadError e m) => MonadError e (StateT s m) where + throwError = throwError' + catchError = catchError2' S ($$) + +instance (MonadPlus m) => MonadPlus (StateT s m) where + mzero = mzero' + mplus = mplus2' S ($$) + +-- 'findAll' does not affect the state +-- if interested in the state as well as the result, use +-- `get` before `findAll`. +-- e.g. findAllSt m = findAll (do x <- m; y <- get; reutrn (x,y)) +instance MonadNondet m => MonadNondet (StateT s m) where + findAll m = S (\s -> liftM (\xs -> (fmap fst xs,s)) (findAll (m $$ s))) + commit = mapStateT commit + +instance MonadResume m => MonadResume (StateT s m) where + delay = mapStateT delay + force = mapStateT force + +-- jumping undoes changes to the state state +instance MonadCont m => MonadCont (StateT s m) where + callCC = callCC2' S unS (\a s -> (a,s)) + + diff --git a/Control/Monad/X/Trans.hs b/Control/Monad/X/Trans.hs new file mode 100644 index 0000000..20e8140 --- /dev/null +++ b/Control/Monad/X/Trans.hs @@ -0,0 +1,241 @@ +module Control.Monad.X.Trans + ( -- * General transformer classes + MonadTrans(..), + HasBaseMonad(..), + + -- * Plumbing transformers + -- $PlumbingDoc + + -- ** Reader + MonadReader(..), + -- $MonadReaderDoc + asks, + localSet, + + -- ** Writer + MonadWriter(..), + -- $MonadWriterDoc + listens, + censor, + pass, + + -- ** State + MonadState(..), + -- $MonadStateDoc + gets, + modify, + + -- * Control transformers + -- $ControlDoc + + -- ** Exceptions + MonadError(..), + -- $MonadErrorDoc + + -- ** Non-determinism + MonadNondet(..), + -- $MonadNondetDoc + + -- ** Resumptions + MonadResume(..), + -- $MonadResumeDoc + + -- ** Continuations + MonadCont(..), + -- $MonadContDoc + ) + where + +import Prelude (Monad(..),(.),const,IO,Maybe,id) +import Control.Monad(MonadPlus,liftM) + +import Data.Monoid(Monoid) + + + +-------------------------------------------------------------------------------- +-- | Provides a way of going across one transformer layer. + +class MonadTrans t where + lift :: Monad m => m a -> t m a + -- ^ Provides a way of going across one transformer layer. + + +-------------------------------------------------------------------------------- +-- | The predicate @HasBaseMonad m n@ indicates that 'm' is a monad +-- built by applying a number of transformers to 'n'. + +class (Monad m, Monad n) => HasBaseMonad m n | m -> n where + inBase :: n a -> m a + -- ^ Provides a way of going across multiple transformer layers, + -- all the way to the innermost atomic monad. + + +-- Move me somewhere else. +instance HasBaseMonad IO IO where inBase = id +instance HasBaseMonad [] [] where inBase = id +instance HasBaseMonad Maybe Maybe where inBase = id + + + + +{- $PlumbingDoc + /Plumbing transformers/ take care of propagating information around in a computation. +They all commute with each other. This means that it doesn't meter +in what order they are added to a computation, the final effect is the same. +-} + +-- | A reader monad has the ability to propagate around a read-only environment. +-- One can think of the environment as a special read only variable that can +-- be accessed via the methods of the class. + +class (Monad m) => MonadReader r m | m -> r where + ask :: m r + -- ^ Read the value of the variable. + + local :: (r -> r) -> m a -> m a + -- ^ The method @local f m@ uses @f@ to change the value of the variable + -- for the duration of a computation @m@. After @m@ completes its execution + -- the original value of the variable is restored. + +{- $MonadReaderDoc + Read-only variables are useful when some information needs to be carried +around, but is not used all the time. Such a situation may occur when a deeply nested +function call needs the information, but most of the functions involved in +a computation will not use it and simply pass it around. Read-only variables +are very closely related to /implicit parameters/ <...>. +See also `MonadWriter'. +-} + + +-- | Gets specific component of the environment, using the projection function +-- supplied. +asks :: (MonadReader r m) => (r -> a) -> m a +asks f = liftM f ask + + +-- | Temporarily sets the value of the read-only variable. One can think of +-- @localSet x m@ as a @let@ construct. +localSet :: MonadReader r m => r -> m a -> m a +localSet = local . const + + +-- | A writer monad has the ability to collect a number of outputs generated +-- during a computation. It is like carrying around a buffer that can be +-- manipulated with the methods of the class. The 'Monoid' class specifies +-- how to make an empty buffer, and how to join two buffers together. +class (Monoid w, Monad m) => MonadWriter w m | m -> w where + tell :: w -> m () + -- ^ @tell w@ appends the new information @w@ to the buffer. + + listen :: m a -> m (a, w) + -- ^ @listen m@ moves the contents of the buffer of computation @m@ to its result. + -- The resulting computation has an empty buffer. + +{- $MonadWriterDoc + Buffer variables are often useful when one needs to collect some +information, for example while traversing a data structure. In a sense, +they are the dual of read-only variables, as they propagate outputs +of functions, rather then their inputs. +-} + + +-- | Gets specific component of the output, using the projection function supplied. +listens :: (MonadWriter w m) => (w -> b) -> m a -> m (a, b) +listens f m = liftM (\ ~(a,w) -> (a,f w)) (listen m) + + +-- | @censor f m@ behaves like @m@ except its output is modified by @f@. +censor :: MonadWriter w m => (w -> w) -> m a -> m a +censor f m = do (a,w) <- listen m + tell (f w) -- the media :-) + return a + +-- | NOTE: SHOULD THIS BE IN THE LIBRARY? +-- Does what the type suggests. +pass :: (MonadWriter w m) => m (a, w -> w) -> m a +pass m = do ((a,f),w) <- listen m + tell (f w) + return a + + + +-- | A state monad carries around a piece of state. It is just like +-- having a read-write variable in an imperative language. + +class (Monad m) => MonadState s m | m -> s where + get :: m s + -- ^ reads the value of the variable + + put :: s -> m () + -- ^ @put s@ permanently changes the value of the variable to @s@. + +-- $MonadStateDoc +-- + +-- | Gets specific component of the state, using the projection function supplied. +gets :: (MonadState s m) => (s -> a) -> m a +gets f = liftM f get + +-- | Update the state with a function. +modify :: (MonadState s m) => (s -> s) -> m () +modify f = get >>= put . f + + +-- $ControlDoc +-- /Control transformers/ are used to manipulate the control flow in a program. +-- In general they do not commute between themselves and with other transformers. +-- This means that it is important in what order they are added on top of a monad. +-- Different orders yield monads with different behavior. See "FeatureInteract.hs". + + + +-- | An error (or exception) monad is aware that computations may fail. +-- The type @e@ specifies what errors may occur in a computation. +class (Monad m) => MonadError e m | m -> e where + throwError :: e -> m a + -- ^ The method @throwError e@ raises exception @e@. + -- It never returns a value. + + catchError :: m a -> (e -> m a) -> m a + -- ^ The method @catchError m h@ uses the handler @h@ to handle exceptions + -- raised in computation @m@. If no exceptions are + -- raised, the final computation behaves as @m@. It is possible + -- for the handler itself to throw an exception. + +-- $ErrorDoc + +-- | A nondeterminism (or backtracking) monad supports computations that +-- may fail and backtrack or produce multiple results. +-- +-- Currently some of the methods in this class are inherited from +-- the class 'MonadPlus' defined in module "Control.Monad". +-- 'mzero' is used to indicate no results. +-- 'mplus' is used to indicate alternatives. +-- +-- Since the use of 'MonadPlus' is somewhat overloaded in Haskell +-- (it is also used for exception handling) +-- in the future 'mzero' and 'mplus' may be added explicitly to this class +-- (with different names). +class (MonadPlus m) => MonadNondet m where + findAll :: m a -> m [a] + -- ^ @findAll m@ is analogous to the construct found in logic languages + -- (e.g. Prolog, Curry). It produces all possible results of @m@. + commit :: m a -> m a + -- ^ @commit m@ behaves like @m@ except it will produce at most one result. + -- Thus, it resembles the /cut/ operator of Prolog. + -- (VERIFY) @findAll (commit m)@ should never produce a list with more than one element. + +class Monad m => MonadResume m where + delay :: m a -> m a + force :: m a -> m a + +-- | TODO. +class (Monad m) => MonadCont m where + callCC :: ((a -> m b) -> m a) -> m a + + + + + + diff --git a/Control/Monad/X/Transformers.hs b/Control/Monad/X/Transformers.hs new file mode 100644 index 0000000..02ea934 --- /dev/null +++ b/Control/Monad/X/Transformers.hs @@ -0,0 +1,13 @@ +module Control.Monad.X.Transformers + ( module R, module W, module S, module E, module N, module Re {- , module C-} ) + where + +import Control.Monad.X.ReaderT as R +import Control.Monad.X.WriterT as W +import Control.Monad.X.StateT as S +import Control.Monad.X.ErrorT as E +import Control.Monad.X.NondetT as N +import Control.Monad.X.ResumeT as Re +-- import Control.Monad.X.ContT as C + + diff --git a/Control/Monad/X/Types.hs b/Control/Monad/X/Types.hs new file mode 100644 index 0000000..21056d1 --- /dev/null +++ b/Control/Monad/X/Types.hs @@ -0,0 +1,16 @@ +module Control.Monad.X.Types where + +import Control.Monad(MonadPlus(..)) + +newtype ReaderT r m a = R { unR :: r -> m a } +newtype WriterT w m a = W { unW :: m (a, w) } +newtype StateT s m a = S { unS :: s -> m (a,s) } +newtype ErrorT e m a = E { unE :: m (Either e a) } +newtype NondetT m a = N { unN :: m (T m a) } +newtype ResumeT m a = Re { unRe :: m (Res m a) } +newtype ContT r m a = C { unC :: (a -> m r) -> m r } + +data T m a = Empty | Cons a (NondetT m a) +data Res m a = Value a | Delay (ResumeT m a) + + diff --git a/Control/Monad/X/Utils.hs b/Control/Monad/X/Utils.hs new file mode 100644 index 0000000..805271e --- /dev/null +++ b/Control/Monad/X/Utils.hs @@ -0,0 +1,52 @@ +module Control.Monad.X.Utils where + +-- | This is a private module and is not to be imported +-- directly by non-library modules. + + +import Prelude(return,fail,(.)) +import Control.Monad(MonadPlus(..)) +import Control.Monad.X.Trans + +-- has base +inBase' m = lift (inBase m) + +-- monad +return' x = lift (return x) +fail' msg = lift (fail msg) + +-- reader +ask' :: (MonadTrans t, MonadReader r m) => t m r +ask' = lift ask +local' map f = map (local f) + +-- writer +tell' w = lift (tell w) +listen1' mk unmk add m = mk (do (x,w) <- listen (unmk m) + return (add w x)) +listen2' mk unmk add m = mk (\s -> do (x,w) <- listen (unmk m s) + return (add w x)) + +-- state +get' :: (MonadTrans t, MonadState s m) => t m s +get' = lift get +put' s = lift (put s) + +-- error +throwError' e = lift (throwError e) +catchError1' mk unmk m h = mk (catchError (unmk m) (unmk . h)) +catchError2' mk unmk m h = mk (\y -> catchError (unmk m y) (\e -> unmk (h e) y)) + +-- mplus +mzero' :: (MonadTrans t, MonadPlus m) => t m a +mzero' = lift mzero +mplus1' mk unmk m n = mk (mplus (unmk m) (unmk n)) +mplus2' mk unmk m n = mk (\y -> unmk m y `mplus` unmk n y) + +-- cont +callCC1' mk unmk ret f = mk (callCC (\br -> unmk (f (\a -> lift (br (ret a)))))) +callCC2' mk unmk ret f = mk (\s -> callCC (\br -> unmk (f (\a -> lift (br (ret a s)))) s)) + + + + diff --git a/Control/Monad/X/Writer.hs b/Control/Monad/X/Writer.hs new file mode 100644 index 0000000..d233a25 --- /dev/null +++ b/Control/Monad/X/Writer.hs @@ -0,0 +1,12 @@ +module Control.Monad.X.Writer (Writer, runWriter, module T)where + +import Control.Monad.X.Identity +import qualified Control.Monad.X.WriterT as W +import Control.Monad.X.Trans as T + +type Writer w = W.WriterT w Identity + +runWriter :: Writer w a -> (a,w) +runWriter m = runIdentity (W.runWriter m) + + diff --git a/Control/Monad/X/WriterT.hs b/Control/Monad/X/WriterT.hs new file mode 100644 index 0000000..2ac6497 --- /dev/null +++ b/Control/Monad/X/WriterT.hs @@ -0,0 +1,106 @@ +----------------------------------------------------------------------------- +-- | +-- 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 implementation of the writer transformer. +-- +-- Inspired by the paper +-- /Functional Programming with Overloading and +-- Higher-Order Polymorphism/, +-- Mark P Jones () +-- Advanced School of Functional Programming, 1995. +----------------------------------------------------------------------------- + +module Control.Monad.X.WriterT ( + WriterT, + runWriter, + runWriterT, + execWriterT, + mapWriterT, + module T, + module Monoid, + ) where + +import Prelude(Functor(..),Monad(..),fst,snd,(.)) +import Control.Monad(liftM,MonadPlus(..)) + +import Data.Monoid as Monoid (Monoid(..)) + +import Control.Monad.X.Trans as T +import Control.Monad.X.Utils +import Control.Monad.X.Types(WriterT(..)) + + +instance (Monoid w) => MonadTrans (WriterT w) where + lift m = W (liftM (\a -> (a,mempty)) m) + +instance (Monoid w, HasBaseMonad m n) => HasBaseMonad (WriterT w m) n where + inBase = inBase' + +instance (Monoid w, Monad m) => Functor (WriterT w m) where + fmap = liftM + +instance (Monoid w, Monad m) => Monad (WriterT w m) where + return = return' + m >>= f = W (do (a, w) <- unW m + (b, w') <- unW (f a) + return (b, w `mappend` w')) + fail = fail' + + +runWriter :: WriterT w m a -> m (a,w) +runWriter = unW + +runWriterT :: WriterT w m a -> m (a,w) +runWriterT = unW + +execWriterT :: Monad m => WriterT w m a -> m w +execWriterT m = liftM snd (unW m) + +mapWriterT :: (m (a, w) -> n (b, w')) -> WriterT w m a -> WriterT w' n b +mapWriterT f m = W (f (unW m)) + + +instance (Monoid w, MonadReader r m) => MonadReader r (WriterT w m) where + ask = ask' + local = local' mapWriterT + +-- different from before, listen produces no output +instance (Monoid w, Monad m) => MonadWriter w (WriterT w m) where + tell w = W (return ((), w)) + listen = mapWriterT (liftM (\(a,w) -> ((a,w),mempty))) + +instance (Monoid w, MonadState s m) => MonadState s (WriterT w m) where + get = get' + put = put' + +instance (Monoid w, MonadError e m) => MonadError e (WriterT w m) where + throwError = throwError' + catchError = catchError1' W unW + +instance (Monoid w, MonadPlus m) => MonadPlus (WriterT w m) where + mzero = mzero' + mplus = mplus1' W unW + +-- 'findAll' does not produce output +-- if interested in the output use 'listen' before calling 'findAll'. +instance (Monoid w, MonadNondet m) => MonadNondet (WriterT w m) where + findAll = mapWriterT (liftM (\xs -> (fmap fst xs, mempty)) . findAll) + commit = mapWriterT commit + +instance (Monoid w, MonadResume m) => MonadResume (WriterT w m) where + delay = mapWriterT delay + force = mapWriterT force + +-- jumping undoes the output +instance (Monoid w, MonadCont m) => MonadCont (WriterT w m) where + callCC = callCC1' W unW (\a -> (a,mempty)) + + diff --git a/Control/Monad/X/laws/Prop.hs b/Control/Monad/X/laws/Prop.hs new file mode 100644 index 0000000..9d5fcf3 --- /dev/null +++ b/Control/Monad/X/laws/Prop.hs @@ -0,0 +1,8 @@ +module Prop where + +data Prop a + +infix 1 === +(===) :: a -> a -> Prop a +(===) = error "===" + diff --git a/Control/Monad/X/laws/Reader.hs b/Control/Monad/X/laws/Reader.hs new file mode 100644 index 0000000..3ee7587 --- /dev/null +++ b/Control/Monad/X/laws/Reader.hs @@ -0,0 +1,14 @@ +import Prop +import Control.Monad.X.ReaderT + + +local_return f x = local f (return x) === return x +local_bind f m1 m2 = (local f m1 >>= \x -> local f (m2 x)) === local f (m1 >>= m2) +local_local f g m = local f (local g m) === local (g . f) m +local_get f = local f get === fmap f get + +get_bind m = (get >> m) === m + + + + diff --git a/Control/Monad/X/laws/Writer.hs b/Control/Monad/X/laws/Writer.hs new file mode 100644 index 0000000..fce2c65 --- /dev/null +++ b/Control/Monad/X/laws/Writer.hs @@ -0,0 +1,9 @@ +import Prop +import Control.Monad.X.WriterT + +listen_return x = listen (return x) === return (x,mempty) +listen_bind m1 m2 = listen (m1 >>= m2) === (do (x,w1) <- listen m1 + (y,w2) <- listen (m2 x) + return (y, w1 `mappend` w2)) + + diff --git a/Control/Monad/X/tests/ContTests.hs b/Control/Monad/X/tests/ContTests.hs new file mode 100644 index 0000000..2dd6473 --- /dev/null +++ b/Control/Monad/X/tests/ContTests.hs @@ -0,0 +1,74 @@ +import Control.Monad.X.Transformers + +test00' _ = do a <- local (+1) ask + b <- ask + return (a,b) + + +test0' _ = do a <- callCC $ \jmp -> local (+1) ask + b <- ask + return (a,b) + +-- this illustrates an interesting phenomenon. +-- if the reader is there before continuations, +-- jumping will not undo "local" changes to the environment, +-- and they will be seen in the continuation. +-- this happens because the jump is within the scope +-- of the local. +test1' _ = do a <- callCC $ \jmp -> local (+1) (ask >>= jmp) + b <- ask + return (a,b) + + +test2' _ = callCC $ \jmp -> tell [1] >> jmp 2 + +-- what should this do? +test22' _ = do (a,w) <- callCC $ \jmp -> tell [1] >> listen (jmp (3,[])) + tell [2] + return (a,w) + + +output w = do x <- get + put (mappend x w) + +list m = do w <- get + put mempty + a <- m -- this is wrong if m jumps as it will delete all output + w' <- get + put w + return (a,w') + + +test32' _ = do (a,w) <- callCC $ \jmp -> output "1" >> {-list-} (jmp (3,"")) + output "2" + return (a,w) + +test33' _ = do (a,w) <- callCC $ \jmp -> output "1" >> list (output "7") + output "2" + return (a,w) + + + +test3' _ = callCC $ \jmp -> put 1 >> jmp 2 + + +test00 = do print =<< (runCont $ runReader 7 $ test00' ()) + print =<< (runReader 7 $ runCont $ test00' ()) + +test0 = do print =<< (runCont $ runReader 7 $ test0' ()) + print =<< (runReader 7 $ runCont $ test0' ()) + +test1 = do print =<< (runCont $ runReader 7 $ test1' ()) + print =<< (runReader 7 $ runCont $ test1' ()) + +test2 = do print =<< (runCont $ runWriter $ test2' ()) + print =<< (runWriter $ runCont $ test2' ()) + +test3 = do print =<< (runCont $ runStateS 7 $ test3' ()) + print =<< (runStateS 7 $ runCont $ test3' ()) + +test32 = do print =<< (runCont $ runStateS [] $ test32' ()) + print =<< (runStateS [] $ runCont $ test32' ()) + +test33 = do print =<< (runCont $ runStateS [] $ test33' ()) + print =<< (runStateS [] $ runCont $ test33' ()) diff --git a/Control/Monad/X/tests/Error.hs b/Control/Monad/X/tests/Error.hs new file mode 100644 index 0000000..a33dd95 --- /dev/null +++ b/Control/Monad/X/tests/Error.hs @@ -0,0 +1,14 @@ +import Control.Monad.X.Error + + +t1 = test (throwError "x") (Left "x" :: Either String Int) +t2 = test (throwError "x" >>= undefined) (Left "x" :: Either String Int) +t3 = test (throwError "x" `catchError` return) (Right "x") +t4 = test (throwError "x" `catchError` throwError) (Left "x" :: Either String Int) +t5 = test (return 3 `catchError` undefined) (Right 3:: Either String Int) + + +test m e = runError m == e + +main = print $ and [t1,t2,t3,t4,t5] + diff --git a/Control/Monad/X/tests/ExceptionTests.hs b/Control/Monad/X/tests/ExceptionTests.hs new file mode 100644 index 0000000..a087c24 --- /dev/null +++ b/Control/Monad/X/tests/ExceptionTests.hs @@ -0,0 +1,11 @@ +import Control.Monad.X.Transformers + +test2' _ = tell "1" >> throwError '2' >> return () +test3' _ = put 1 >> throwError 2 >> return () + +test2 = do print =<< (runError $ runWriter $ test2' ()) + print =<< (runWriter $ runError $ test2' ()) + +test3 = do print =<< (runError $ runStateS 7 $ test3' ()) + print =<< (runStateS 7 $ runError $ test3' ()) + diff --git a/Control/Monad/X/tests/Nondet.hs b/Control/Monad/X/tests/Nondet.hs new file mode 100644 index 0000000..530174b --- /dev/null +++ b/Control/Monad/X/tests/Nondet.hs @@ -0,0 +1,5 @@ +import Control.Monad.X.Nondet + +assoc1 a b c = (a `mplus` b) `mplus` c +assoc2 a b c = a `mplus` (b `mplus` c) + diff --git a/Control/Monad/X/tests/Reader.hs b/Control/Monad/X/tests/Reader.hs new file mode 100644 index 0000000..fa66ba5 --- /dev/null +++ b/Control/Monad/X/tests/Reader.hs @@ -0,0 +1,16 @@ +import Control.Monad.X.Reader + + +t1 = test "x" ask "x" +t2 = test "x" (local ('a':) ask) "ax" +t3 = test "x" + (do x <- ask + y <- local ('a':) ask + z <- ask + return (x,y,z)) ("x","ax","x") +t4 = test "x" (local ('a':) (local ('b':) ask)) "bax" + +test r m e = runReader r m == e + +main = print $ and [t1,t2,t3,t4] + diff --git a/Control/Monad/X/tests/ReaderNondet.hs b/Control/Monad/X/tests/ReaderNondet.hs new file mode 100644 index 0000000..ca59c6b --- /dev/null +++ b/Control/Monad/X/tests/ReaderNondet.hs @@ -0,0 +1,21 @@ +import Control.Monad.X.ReaderT +import Control.Monad.X.NondetT +import Control.Monad.X.Identity + +t0,t1,t2 :: (MonadReader String m, MonadNondet m) => m String +t0 = local ('a':) mzero +t1 = (local ('a':) mzero) `mplus` ask +t2 = local ('a':) (mzero `mplus` ask) + + +run1 m = runIdentity $ runReader "x" $ runNondet $ m +run2 m = runIdentity $ runNondet $ runReader "x" $ m + +test :: Eq a => (forall m. (MonadReader String m, MonadNondet m) => m a) -> Maybe a -> Bool +test t r = run1 t == r && run2 t == r + + +main = do print $ test t0 Nothing + print $ test t1 (Just "x") + print $ test t2 (Just "ax") + diff --git a/Control/Monad/X/tests/State.hs b/Control/Monad/X/tests/State.hs new file mode 100644 index 0000000..d7c4a86 --- /dev/null +++ b/Control/Monad/X/tests/State.hs @@ -0,0 +1,14 @@ +import Control.Monad.X.State + + +t1 = test "x" get ("x","x") +t2 = test "x" (put "y") ((),"y") +t3 = test "x" + (do x <- get + put "y" + y <- get + return (x,y)) (("x","y"),"y") + +test s m e = runStateS s m == e + +main = print $ and [t1,t2,t3] diff --git a/Control/Monad/X/tests/Writer.hs b/Control/Monad/X/tests/Writer.hs new file mode 100644 index 0000000..954ef5f --- /dev/null +++ b/Control/Monad/X/tests/Writer.hs @@ -0,0 +1,18 @@ +import Control.Monad.X.Writer + + +t1 = test (tell "x") ((),"x") +t2 = test (listen (tell "x")) (((),"x"),"") +t3 = test + (do tell "x" + (_,y) <- listen (tell "y") + tell "z" + return y) + ("y","xz") + +t4 = test (listen (listen (tell "x"))) ((((),"x"),""),"") + +test m e = runWriter m == e + +main = print $ and [t1,t2,t3,t4] + diff --git a/Control/Monad/X/tests/testNondet.hs b/Control/Monad/X/tests/testNondet.hs new file mode 100644 index 0000000..eef4c05 --- /dev/null +++ b/Control/Monad/X/tests/testNondet.hs @@ -0,0 +1,35 @@ +import Control.Monad.X.Transformers + + +pr x = inBase (putStr $ show x ++ " ") + + + + +test3' _ = pr "1" `mplus` pr "2" + +-- writer & nonedt +test4' _ = tell "1" `mplus` tell "2" +test5' _ = listen (tell "1") `mplus` (tell "2" >> return ((),"77")) +test6' _ = listen mzero `mplus` (tell "2" >> return ((),"77")) +test7' _ = do (x,w) <- listen (tell "b") + if w == "a" then mzero else return 7 + +law3' _ = (m >>= f >>= g, m >>= \x -> f x >>= g) + where m = pr "m" >> mplus (pr "1") (pr "2") + f _ = pr "f" >> mplus (pr "3") (pr "4") + g _ = pr "g" >> mplus (pr "5") (pr "6") + +law3 = do let (lhs,rhs) = law3' () + print =<< runNondets lhs + print =<< runNondets rhs + + +test8' _ = (tell "1" >> mzero) `mplus` tell "2" + +main = do -- x <- runWriter $ runNondets (test8' ()) + x <- runNondet $ runWriter $ test8' () + print x + + + -- 1.7.10.4