objective 0.0.2 → 0.1

raw patch · 5 files changed

+153/−13 lines, 5 files

Files

objective.cabal +2/−2
src/Control/Monad/Objective.hs +4/−0
src/Control/Monad/Objective/Class.hs +112/−10
src/Control/Monad/Objective/IO.hs +33/−0
src/Control/Object.hs +2/−1

objective.cabal view

@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/
 
 name:                objective
-version:             0.0.2
+version:             0.1
 synopsis:            Extensible objects
 description:         Stateful effect transducer
 homepage:            https://github.com/fumieval/objective
@@ -17,7 +17,7 @@ cabal-version:       >=1.10
 
 library
-  exposed-modules:     Control.Object, Control.Monad.Objective.Class
+  exposed-modules:     Control.Object, Control.Monad.Objective.Class, Control.Monad.Objective.IO, Control.Monad.Objective
   -- other-modules:       
   other-extensions:    MultiParamTypeClasses, KindSignatures, TypeFamilies
   build-depends:       base >=4.5 && <5, trivia, comonad, transformers >= 0.3 && <0.5

+ src/Control/Monad/Objective.hs view

@@ -0,0 +1,4 @@+module Control.Monad.Objective (module Control.Monad.Objective.Class, module Control.Monad.Objective.IO) where
+
+import Control.Monad.Objective.Class
+import Control.Monad.Objective.IO

src/Control/Monad/Objective/Class.hs view

@@ -1,25 +1,127 @@-{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE CPP #-}
 
 module Control.Monad.Objective.Class where
 import Control.Object
-import Control.Monad.Trans.State
 
+#if MIN_VERSION_transformers(0,4,0)
+import Control.Monad.Trans.Except
+#else
+import Control.Monad.Trans.Error
+#endif
+import Control.Monad.Trans.Identity
+import Control.Monad.Trans.List
+import Control.Monad.Trans.Maybe
+import Control.Monad.Trans.Class
+import Control.Monad.Trans.Cont
+import Control.Monad.Trans.Reader
+import Control.Monad.Trans.State.Lazy as Lazy
+import Control.Monad.Trans.State.Strict as Strict
+import Control.Monad.Trans.Writer.Lazy as Lazy
+import Control.Monad.Trans.Writer.Strict as Strict
+import qualified Control.Monad.Trans.RWS.Lazy as LazyRWS
+import qualified Control.Monad.Trans.RWS.Strict as StrictRWS
+import Data.Monoid
+import Control.Monad
+
 infix 3 .-
 infix 3 .&
 
-class Monad m => MonadObjective s m where
-  type Base m :: * -> *
-  data Control s (e :: * -> *)
+class Monad m => MonadObjective m where
+
+  data Address (e :: * -> *) (m :: * -> *)
+  type Residence (m :: * -> *) :: * -> *
+  -- Control e f = Control e (Base f)
   -- | Send a message to the pointed one.
-  (.-) :: Control s e -> e a -> m a
+  (.-) :: Address e m -> e a -> m a
   -- | Add an object to the environment.
-  invoke :: Object e (Base m) -> m (Control s e)
+  invoke :: Object e (Residence m) -> m (Address e m)
 
-(.&) :: (MonadObjective k m, Stateful s e) => Control k e -> StateT s m a -> m a
+(.&) :: (MonadObjective m, Stateful s e) => Address e m -> Strict.StateT s m a -> m a
 c .& m = do
   s <- c .- get_
-  (a, s') <- runStateT m s
+  (a, s') <- Strict.runStateT m s
   c .- put_ s'
-  return a+  return a
+
+instance MonadObjective m => MonadObjective (ReaderT r m) where
+  data Address e (ReaderT r m) = WrapReaderT (Address e m)
+  type Residence (ReaderT r m) = Residence m
+  WrapReaderT c .- e = lift (c .- e)
+  invoke = liftM WrapReaderT . lift . invoke
+
+instance (Monoid w, MonadObjective m) => MonadObjective (LazyRWS.RWST r w s m) where
+  data Address e (LazyRWS.RWST r w s m) = WrapLazyRWST (Address e m)
+  type Residence (LazyRWS.RWST r w s m) = Residence m
+  WrapLazyRWST c .- e = lift (c .- e)
+  invoke = liftM WrapLazyRWST . lift . invoke
+
+instance (Monoid w, MonadObjective m) => MonadObjective (StrictRWS.RWST r w s m) where
+  data Address e (StrictRWS.RWST r w s m) = WrapStrictRWST (Address e m)
+  type Residence (StrictRWS.RWST r w s m) = Residence m
+  WrapStrictRWST c .- e = lift (c .- e)
+  invoke = liftM WrapStrictRWST . lift . invoke
+
+instance MonadObjective m => MonadObjective (ContT r m) where
+  data Address e (ContT r m) = WrapContT (Address e m)
+  type Residence (ContT r m) = Residence m
+  WrapContT c .- e = lift (c .- e)
+  invoke = liftM WrapContT . lift . invoke
+
+#if MIN_VERSION_transformers(0,4,0)
+instance MonadObjective m => MonadObjective (ExceptT er m) where
+  data Address e (ExceptT er m) = WrapExceptT (Address e m)
+  type Residence (ExceptT er m) = Residence m
+  WrapExceptT c .- e = lift (c .- e)
+  invoke = liftM WrapExceptT . lift . invoke
+#else
+instance (Error er, MonadObjective m) => MonadObjective (ErrorT er m) where
+  data Address e (ErrorT er m) = WrapErrorT (Address e m)
+  type Residence (ErrorT er m) = Residence m
+  WrapErrorT c .- e = lift (c .- e)
+  invoke = liftM WrapErrorT . lift . invoke
+#endif
+
+instance MonadObjective m => MonadObjective (IdentityT m) where
+  data Address e (IdentityT m) = WrapIdentityT (Address e m)
+  type Residence (IdentityT m) = Residence m
+  WrapIdentityT c .- e = lift (c .- e)
+  invoke = liftM WrapIdentityT . lift . invoke
+
+instance MonadObjective m => MonadObjective (ListT m) where
+  data Address e (ListT m) = WrapListT (Address e m)
+  type Residence (ListT m) = Residence m
+  WrapListT c .- e = lift (c .- e)
+  invoke = liftM WrapListT . lift . invoke
+
+instance MonadObjective m => MonadObjective (MaybeT m) where
+  data Address e (MaybeT m) = WrapMaybeT (Address e m)
+  type Residence (MaybeT m) = Residence m
+  WrapMaybeT c .- e = lift (c .- e)
+  invoke = liftM WrapMaybeT . lift . invoke
+
+instance MonadObjective m => MonadObjective (Lazy.StateT s m) where
+  data Address e (Lazy.StateT s m) = WrapLazyStateT (Address e m)
+  type Residence (Lazy.StateT s m) = Residence m
+  WrapLazyStateT c .- e = lift (c .- e)
+  invoke = liftM WrapLazyStateT . lift . invoke
+
+instance MonadObjective m => MonadObjective (Strict.StateT s m) where
+  data Address e (Strict.StateT s m) = WrapStrictStateT (Address e m)
+  type Residence (Strict.StateT s m) = Residence m
+  WrapStrictStateT c .- e = lift (c .- e)
+  invoke = liftM WrapStrictStateT . lift . invoke
+
+instance (Monoid w, MonadObjective m) => MonadObjective (Lazy.WriterT w m) where
+  data Address e (Lazy.WriterT w m) = WrapLazyWriterT (Address e m)
+  type Residence (Lazy.WriterT w m) = Residence m
+  WrapLazyWriterT c .- e = lift (c .- e)
+  invoke = liftM WrapLazyWriterT . lift . invoke
+
+instance (Monoid w, MonadObjective m) => MonadObjective (Strict.WriterT w m) where
+  data Address e (Strict.WriterT w m) = WrapStrictWriterT (Address e m)
+  type Residence (Strict.WriterT w m) = Residence m
+  WrapStrictWriterT c .- e = lift (c .- e)
+  invoke = liftM WrapStrictWriterT . lift . invoke

+ src/Control/Monad/Objective/IO.hs view

@@ -0,0 +1,33 @@+{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, FlexibleInstances  #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Control.Monad.Objective.IO
+-- Copyright   :  (c) Fumiaki Kinoshita 2014
+-- License     :  BSD3
+--
+-- Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+-- 'MonadObjective' 'IO' using MVar
+--
+-----------------------------------------------------------------------------
+module Control.Monad.Objective.IO  where
+import GHC.Base
+import Control.Monad.Objective.Class
+import Control.Concurrent
+import Control.Object
+
+instance MonadObjective IO where
+
+  type Residence IO = IO
+  data Address e IO = Address (MVar (Object e IO))
+
+  Address m .- e = do
+      c <- takeMVar m
+      (a, c') <- runObject c e
+      putMVar m c'
+      return a
+  invoke v = do
+      m <- newMVar v
+      return (Address m)

src/Control/Object.hs view

@@ -1,5 +1,6 @@ {-# LANGUAGE Rank2Types, MultiParamTypeClasses, FlexibleInstances #-}
 {-# LANGUAGE DeriveFunctor, DeriveDataTypeable #-}
+{-# LANGUAGE FunctionalDependencies #-}
 module Control.Object where
 
 import Control.Comonad.Zero
@@ -50,7 +51,7 @@ {-# INLINE stateful #-}
 
 -- | Like 'MonadState', but doesn't require 'Monad' as a prerequisite.
-class Stateful s f where
+class Stateful s f | f -> s where
   get_ :: f s
   put_ :: s -> f ()