objective 0.4 → 0.5

raw patch · 8 files changed

+106/−178 lines, 8 filesdep +elevatordep +profunctors

Dependencies added: elevator, profunctors

Files

objective.cabal +10/−4
src/Control/Monad/Objective.hs +5/−2
src/Control/Monad/Objective/Class.hs +19/−124
src/Control/Monad/Objective/IO.hs +6/−7
src/Control/Monad/Objective/ST.hs +32/−0
src/Control/Object.hs +2/−41
src/Data/Functor/PushPull.hs +14/−0
src/Data/Functor/Request.hs +18/−0

objective.cabal view

@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/
 
 name:                objective
-version:             0.4
+version:             0.5
 synopsis:            Extensible objects
 description:         Stateful effect transducer
 homepage:            https://github.com/fumieval/objective
@@ -17,10 +17,16 @@ cabal-version:       >=1.10
 
 library
-  exposed-modules:     Control.Object, Control.Monad.Objective.Class, Control.Monad.Objective.IO, Control.Monad.Objective
+  exposed-modules:     Control.Object
+                     , Control.Monad.Objective
+                     , Control.Monad.Objective.Class
+                     , Control.Monad.Objective.IO
+                     , Control.Monad.Objective.ST
+                     , Data.Functor.Request
+                     , Data.Functor.PushPull
   -- other-modules:       
   other-extensions:    MultiParamTypeClasses, KindSignatures, TypeFamilies
-  build-depends:       base >=4.5 && <5, transformers >= 0.3 && <0.5, free >= 4.0 && <5, clean-unions < 0.2
+  build-depends:       base >=4.5 && <5, transformers >= 0.3 && <0.5, free >= 4.0 && <5, clean-unions < 0.2, profunctors > 4.0 && <5, elevator
   ghc-options: -Wall
   hs-source-dirs:      src
-  default-language:    Haskell2010+  default-language:    Haskell2010

src/Control/Monad/Objective.hs view

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

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

@@ -3,142 +3,37 @@ {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE CPP #-}
 
 module Control.Monad.Objective.Class where
 import Control.Object
 
-#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
-import Control.Monad.Free
-import Data.OpenUnion1.Clean
+import Control.Elevator
 
-infix 3 .-
-infix 3 .&
-infix 3 .|-
-infix 3 .^>
+type Instance' e m = Instance e m m
 
 class Monad m => MonadObjective m where
-
-  data Address (e :: * -> *) (m :: * -> *)
-  type Residence (m :: * -> *) :: * -> *
-  -- Control e f = Control e (Base f)
+  data Instance (e :: * -> *) (n :: * -> *) m
   -- | Send a message to the pointed one.
-  (.-) :: Address e m -> e a -> m a
+  invoke :: Monad n => Instance e n m -> e a -> m (n (m a))
   -- | Add an object to the environment.
-  new :: Object e (Residence m) -> m (Address e m)
-
-(.&) :: (MonadObjective m, Lift (Strict.State s) f) => Address f m -> Strict.StateT s m a -> m a
-c .& m = do
-  s <- c .- get_
-  (a, s') <- Strict.runStateT m s
-  c .- put_ s'
-  return a
-
--- | like 'sequential', but it allows ad-hoc use of 'Free'.
-(.|-) :: MonadObjective m => Address e m -> Free e a -> m a
-_ .|- Pure a = return a
-c .|- Free f = c .- f >>= (c .|-)
-
-(.^>) :: (MonadObjective m, f ∈ u) => Address (Union u) m -> f a -> m a
-c .^> f = c .- liftU f
-
-(.<<) :: (MonadObjective m, Lift (Request a b) f) => Address f m -> a -> m b 
-c .<< a = c .- request 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)
-  new = liftM WrapReaderT . lift . new
-
-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)
-  new = liftM WrapLazyRWST . lift . new
-
-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)
-  new = liftM WrapStrictRWST . lift . new
-
-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)
-  new = liftM WrapContT . lift . new
-
-#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)
-  new = liftM WrapExceptT . lift . new
-#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)
-  new = liftM WrapErrorT . lift . new
-#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)
-  new = liftM WrapIdentityT . lift . new
-
-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)
-  new = liftM WrapListT . lift . new
-
-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)
-  new = liftM WrapMaybeT . lift . new
+  new :: Object e n -> m (Instance e n m)
 
-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)
-  new = liftM WrapLazyStateT . lift . new
+(.-) :: (Monad n
+  , Elevate n m
+  , MonadObjective m
+  , Elevate m f) => Instance e n m -> e a -> f a
+a .- e = elevate $ invoke a e >>= join . elevate
 
-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)
-  new = liftM WrapStrictStateT . lift . new
+infix 3 .-
 
-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)
-  new = liftM WrapLazyWriterT . lift . new
+(.^) :: (Elevate e f
+  , Monad n
+  , Elevate n m
+  , MonadObjective m
+  , Elevate m g) => Instance f n m -> e a -> g a
+a .^ e = a .- elevate e
 
-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)
-  new = liftM WrapStrictWriterT . lift . new
+infix 3 .^

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

@@ -20,12 +20,11 @@ 
 instance MonadObjective IO where
 
-  type Residence IO = IO
-  data Address e IO = Address (MVar (Object e IO))
+  data Instance e m IO = InstanceIO (MVar (Object e m))
 
-  Address m .- e = do
-      c <- takeMVar m
+  InstanceIO m `invoke` e = do
+    c <- takeMVar m
+    return $ do
       (a, c') <- runObject c e
-      putMVar m c'
-      return a
-  new v = Address `fmap` newMVar v+      return (putMVar m c' >> return a)
+  new v = InstanceIO `fmap` newMVar v

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

@@ -0,0 +1,32 @@+{-# LANGUAGE TypeFamilies #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Control.Monad.Objective.ST
+-- Copyright   :  (c) Corbin Simpson, Google Inc. 2014
+-- License     :  BSD3
+--
+-- Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>
+-- Stability   :  experimental
+-- Portability :  non-portable (ST)
+--
+-- 'MonadObjective' 'ST' using 'STRef'
+--
+-----------------------------------------------------------------------------
+module Control.Monad.Objective.ST where
+
+import Control.Monad.Objective.Class
+import Control.Monad.ST
+import Control.Object
+import Data.STRef
+
+instance MonadObjective (ST s) where
+  data Instance e m (ST s) = InstanceST (STRef s (Object e m))
+
+  InstanceST ref `invoke` e = do
+      o <- readSTRef ref
+      return $ do
+        (a, o') <- runObject o e
+        return $ writeSTRef ref o' >> return a
+  new o = InstanceST `fmap` newSTRef o

src/Control/Object.hs view

@@ -18,16 +18,7 @@   -- * Extensible objects
   loner,
   (.|>.),
-  sharing,
-  -- * Utilitites
-  Request(..),
-  request,
-  accept,
-  acceptM,
-  Lift(..),
-  get_,
-  modify_,
-  put_,
+  sharing
   )
 where
 
@@ -106,34 +97,4 @@ (.|>.) :: Functor m => Object f m -> Object (Union s) m -> Object (f |> Union s) m
 p .|>. q = Object $ fmap (fmap (.|>.q)) . runObject p ||> fmap (fmap (p .|>.)) . runObject q
 
-data Request a b r = Request a (b -> r)
-
-class Lift f g | g -> f where
-  lift_ :: f a -> g a
-
-instance Lift (Request a b) (Request a b) where
-  lift_ = id
-
-instance (f ∈ u) => Lift f (Union u) where
-  lift_ = liftU
-
-instance Lift (StateT s m) (StateT s m) where
-  lift_ = id
-
-get_ :: (Monad m, Lift (StateT s m) f) => f s
-get_ = lift_ get
-
-modify_ :: (Monad m, Lift (StateT s m) f) => (s -> s) -> f ()
-modify_ f = lift_ (modify f)
-
-put_ :: (Monad m, Lift (StateT s m) f) => s -> f ()
-put_ s = lift_ (put s)
-
-request :: (Lift (Request a b) f) => a -> f b
-request a = lift_ (Request a id)
-
-accept :: Functor f => (a -> f b) -> Request a b r -> f r
-accept f (Request a br) = fmap br (f a)
-
-acceptM :: Monad m => (a -> m b) -> Request a b r -> m r
-acceptM f (Request a br) = liftM br (f a)
+infixr 3 .|>.

+ src/Data/Functor/PushPull.hs view

@@ -0,0 +1,14 @@+{-# LANGUAGE DeriveFunctor, DeriveDataTypeable, ConstraintKinds, FlexibleContexts #-}
+module Data.Functor.PushPull where
+import Data.Typeable
+import Control.Elevator
+
+data PushPull a b r = Push a r | Pull (b -> r) deriving (Functor, Typeable)
+
+instance Tower (PushPull a b)
+
+push :: (Elevate (PushPull a b) f) => a -> f ()
+push a = elevate (Push a ())
+
+pull :: (Elevate (PushPull a b) f) => f b
+pull = elevate (Pull id)

+ src/Data/Functor/Request.hs view

@@ -0,0 +1,18 @@+{-# LANGUAGE DeriveFunctor, DeriveDataTypeable, ConstraintKinds, FlexibleContexts #-}
+module Data.Functor.Request where
+import Data.Typeable
+import Control.Elevator
+import Control.Monad
+
+data Request a b r = Request a (b -> r) deriving (Functor, Typeable)
+
+instance Tower (Request a b)
+
+request :: (Elevate (Request a b) f) => a -> f b
+request a = elevate (Request a id)
+
+accept :: Functor f => (a -> f b) -> Request a b r -> f r
+accept f (Request a br) = fmap br (f a)
+
+acceptM :: Monad m => (a -> m b) -> Request a b r -> m r
+acceptM f (Request a br) = liftM br (f a)