[project @ 2003-06-03 22:26:44 by diatchki]
authordiatchki <unknown>
Tue, 3 Jun 2003 22:26:50 +0000 (22:26 +0000)
committerdiatchki <unknown>
Tue, 3 Jun 2003 22:26:50 +0000 (22:26 +0000)
Added a first version of the new monad library (experimental).
Hopefully one day the "X" will disappear.

34 files changed:
Control/Monad/X/Cont.hs [new file with mode: 0644]
Control/Monad/X/ContT.hs [new file with mode: 0644]
Control/Monad/X/Error.hs [new file with mode: 0644]
Control/Monad/X/ErrorT.hs [new file with mode: 0644]
Control/Monad/X/Fix.hs [new file with mode: 0644]
Control/Monad/X/Identity.hs [new file with mode: 0644]
Control/Monad/X/Monads.hs [new file with mode: 0644]
Control/Monad/X/Nondet.hs [new file with mode: 0644]
Control/Monad/X/NondetT.hs [new file with mode: 0644]
Control/Monad/X/README [new file with mode: 0644]
Control/Monad/X/Reader.hs [new file with mode: 0644]
Control/Monad/X/ReaderT.hs [new file with mode: 0644]
Control/Monad/X/Resume.hs [new file with mode: 0644]
Control/Monad/X/ResumeT.hs [new file with mode: 0644]
Control/Monad/X/State.hs [new file with mode: 0644]
Control/Monad/X/StateT.hs [new file with mode: 0644]
Control/Monad/X/Trans.hs [new file with mode: 0644]
Control/Monad/X/Transformers.hs [new file with mode: 0644]
Control/Monad/X/Types.hs [new file with mode: 0644]
Control/Monad/X/Utils.hs [new file with mode: 0644]
Control/Monad/X/Writer.hs [new file with mode: 0644]
Control/Monad/X/WriterT.hs [new file with mode: 0644]
Control/Monad/X/laws/Prop.hs [new file with mode: 0644]
Control/Monad/X/laws/Reader.hs [new file with mode: 0644]
Control/Monad/X/laws/Writer.hs [new file with mode: 0644]
Control/Monad/X/tests/ContTests.hs [new file with mode: 0644]
Control/Monad/X/tests/Error.hs [new file with mode: 0644]
Control/Monad/X/tests/ExceptionTests.hs [new file with mode: 0644]
Control/Monad/X/tests/Nondet.hs [new file with mode: 0644]
Control/Monad/X/tests/Reader.hs [new file with mode: 0644]
Control/Monad/X/tests/ReaderNondet.hs [new file with mode: 0644]
Control/Monad/X/tests/State.hs [new file with mode: 0644]
Control/Monad/X/tests/Writer.hs [new file with mode: 0644]
Control/Monad/X/tests/testNondet.hs [new file with mode: 0644]

diff --git a/Control/Monad/X/Cont.hs b/Control/Monad/X/Cont.hs
new file mode 100644 (file)
index 0000000..7cd9e02
--- /dev/null
@@ -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 (file)
index 0000000..0eeed6b
--- /dev/null
@@ -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 (file)
index 0000000..64da3d7
--- /dev/null
@@ -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 (file)
index 0000000..fd714eb
--- /dev/null
@@ -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 (file)
index 0000000..addeedb
--- /dev/null
@@ -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 (file)
index 0000000..1df1b49
--- /dev/null
@@ -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 (<http://www.cse.ogi.edu/~mpj/>)
+--               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 (file)
index 0000000..fa4d275
--- /dev/null
@@ -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 (file)
index 0000000..016944e
--- /dev/null
@@ -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 (file)
index 0000000..45738cc
--- /dev/null
@@ -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 (file)
index 0000000..e2c3fd5
--- /dev/null
@@ -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 <mailto:diatchki@cse.ogi.edu>
+based upon the original by: Andy Gill <mailto:andy@cse.ogi.edu>
+the ErrorT in the original library was rendered by: Michael Weber <mailto:michael.weber@post.rwth-aachen.de>
+the initial version of the NondetT code in CPS style was from: Andrew J Bromage <mailto:ajb@spamcop.net>
+
+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 (file)
index 0000000..5667699
--- /dev/null
@@ -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 (file)
index 0000000..64fb538
--- /dev/null
@@ -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 (<http://www.cse.ogi.edu/~mpj/>)
+--               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 (file)
index 0000000..fa5753a
--- /dev/null
@@ -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 (file)
index 0000000..b8f9f25
--- /dev/null
@@ -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 (file)
index 0000000..8c605c8
--- /dev/null
@@ -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 (file)
index 0000000..c370a98
--- /dev/null
@@ -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 (<http://www.cse.ogi.edu/~mpj/>)
+--               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 (file)
index 0000000..20e8140
--- /dev/null
@@ -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 (file)
index 0000000..02ea934
--- /dev/null
@@ -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 (file)
index 0000000..21056d1
--- /dev/null
@@ -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 (file)
index 0000000..805271e
--- /dev/null
@@ -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 (file)
index 0000000..d233a25
--- /dev/null
@@ -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 (file)
index 0000000..2ac6497
--- /dev/null
@@ -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 (<http://www.cse.ogi.edu/~mpj/>)
+--               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 (file)
index 0000000..9d5fcf3
--- /dev/null
@@ -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 (file)
index 0000000..3ee7587
--- /dev/null
@@ -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 (file)
index 0000000..fce2c65
--- /dev/null
@@ -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 (file)
index 0000000..2dd6473
--- /dev/null
@@ -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 (file)
index 0000000..a33dd95
--- /dev/null
@@ -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 (file)
index 0000000..a087c24
--- /dev/null
@@ -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 (file)
index 0000000..530174b
--- /dev/null
@@ -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 (file)
index 0000000..fa66ba5
--- /dev/null
@@ -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 (file)
index 0000000..ca59c6b
--- /dev/null
@@ -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 (file)
index 0000000..d7c4a86
--- /dev/null
@@ -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 (file)
index 0000000..954ef5f
--- /dev/null
@@ -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 (file)
index 0000000..eef4c05
--- /dev/null
@@ -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
+
+
+