objective 0.3 → 0.4

raw patch · 4 files changed

+103/−49 lines, 4 filesdep +clean-unionsdep −comonaddep −trivia

Dependencies added: clean-unions

Dependencies removed: comonad, trivia

Files

objective.cabal +3/−2
src/Control/Monad/Objective/Class.hs +12/−6
src/Control/Monad/Objective/IO.hs +2/−2
src/Control/Object.hs +86/−39

objective.cabal view

@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/
 
 name:                objective
-version:             0.3
+version:             0.4
 synopsis:            Extensible objects
 description:         Stateful effect transducer
 homepage:            https://github.com/fumieval/objective
@@ -20,6 +20,7 @@   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, free >= 4.0 && <5
+  build-depends:       base >=4.5 && <5, transformers >= 0.3 && <0.5, free >= 4.0 && <5, clean-unions < 0.2
+  ghc-options: -Wall
   hs-source-dirs:      src
   default-language:    Haskell2010

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

@@ -1,6 +1,8 @@ {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE CPP #-}
 
 module Control.Monad.Objective.Class where
@@ -26,9 +28,12 @@ import Data.Monoid
 import Control.Monad
 import Control.Monad.Free
+import Data.OpenUnion1.Clean
 
 infix 3 .-
 infix 3 .&
+infix 3 .|-
+infix 3 .^>
 
 class Monad m => MonadObjective m where
 
@@ -40,12 +45,7 @@   -- | Add an object to the environment.
   new :: Object e (Residence m) -> m (Address e m)
 
--- | Old synonym for 'new'.
-invoke :: MonadObjective m => Object e (Residence m) -> m (Address e m)
-invoke = new
-{-# DEPRECATED invoke "Use new instead of misleading invoke" #-} 
-
-(.&) :: (MonadObjective m, Stateful s e) => Address e m -> Strict.StateT s m a -> m a
+(.&) :: (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
@@ -56,6 +56,12 @@ (.|-) :: 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)

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

@@ -1,4 +1,5 @@-{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, FlexibleInstances  #-}
+{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, FlexibleInstances #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Control.Monad.Objective.IO
@@ -13,7 +14,6 @@ --
 -----------------------------------------------------------------------------
 module Control.Monad.Objective.IO  where
-import GHC.Base
 import Control.Monad.Objective.Class
 import Control.Concurrent
 import Control.Object

src/Control/Object.hs view

@@ -1,17 +1,42 @@ {-# LANGUAGE Rank2Types, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-}
 {-# LANGUAGE DeriveFunctor, DeriveDataTypeable #-}
 {-# LANGUAGE FunctionalDependencies, UndecidableInstances #-}
-module Control.Object where
+{-# LANGUAGE TypeOperators, TupleSections, GADTs #-}
+module Control.Object (
+  -- * Construction
+  Object(..),
+  liftO,
+  echo,
+  oneshot,
+  stateful,
+  variable,
+  -- * Composition
+  (.>>.),
+  transObject,
+  adaptObject,
+  sequential,
+  -- * Extensible objects
+  loner,
+  (.|>.),
+  sharing,
+  -- * Utilitites
+  Request(..),
+  request,
+  accept,
+  acceptM,
+  Lift(..),
+  get_,
+  modify_,
+  put_,
+  )
+where
 
-import Control.Comonad.Zero
-import Control.Comonad
-import Control.Monad.Trans.State
+import Control.Monad.Trans.State.Strict
 import Control.Monad
 import Data.Typeable
 import Control.Applicative
-import Data.Maybe
 import Control.Monad.Free
-import Control.Monad.Trans.Maybe
+import Data.OpenUnion1.Clean
 
 -- | The type 'Object e m' represents objects which can handle messages @e@, perform actions in the environment @m@.
 -- It can be thought of as an automaton that converts effects.
@@ -38,7 +63,9 @@ (.>>.) :: Functor n => Object e m -> Object m n -> Object e n
 Object m .>>. Object n = Object $ \e -> fmap (\((x, m'), n') -> (x, m' .>>. n')) $ n (m e)
 
--- | Build an object.
+infixr 4 .>>.
+
+-- | Build an object using continuation passing style.
 oneshot :: (Functor e, Monad m) => (forall a. e (m a) -> m a) -> Object e m
 oneshot m = go where
   go = Object $ \e -> m (fmap return e) >>= \a -> return (a, go)
@@ -47,46 +74,66 @@ -- | Build a stateful object.
 stateful :: Monad m => (forall a. e a -> StateT s m a) -> s -> Object e m
 stateful h = go where
-  go s = Object $ liftM (\(a, s) -> (a, go s)) . flip runStateT s . h
+  go s = Object $ liftM (\(a, s') -> (a, go s')) . flip runStateT s . h
+{-# INLINE stateful #-}
 
+-- | Convert a /method sequence/ into a sequential /method execution/.
+sequential :: Monad m => Object e m -> Object (Free e) m
+sequential obj = Object $ \x -> case x of
+  Pure a -> return (a, sequential obj)
+  Free f -> do
+    (a, obj') <- runObject obj f
+    runObject (sequential obj') a
+
+-- | A mutable variable.
+variable :: Applicative f => s -> Object (State s) f
+variable s = Object $ \m -> let (a, s') = runState m s in pure (a, variable s')
+
 -- | Build a stateful object, sharing out the state.
-sharing :: Monad m => (forall a. e a -> StateT s m a) -> s -> Object (AccessT s e) m
+sharing :: Monad m => (forall a. e a -> StateT s m a) -> s -> Object (State s |> e |> Nil) m
 sharing m = go where
-  go s = Object $ \k -> liftM (fmap go) $ case k of
-    LiftAccessT e -> runStateT (m e) s
-    Get cont -> return (cont s, s)
-    Put s' cont -> return (cont, s')
+  go s = Object $ \k -> liftM (fmap go) $ ($k)
+    $ (\n -> return $ runState n s)
+    ||> (\e -> runStateT (m e) s)
+    ||> exhaust
 {-# INLINE sharing #-}
 
--- | Like 'MonadState', but doesn't require 'Monad' as a prerequisite.
-class Stateful s f | f -> s where
-  get_ :: f s
-  put_ :: s -> f ()
+-- | An object that won't accept any messages.
+loner :: Functor m => Object Nil m
+loner = liftO exhaust
 
--- | Inflicts external state accessibility to arbitrary effects.
-data AccessT s f a = Get (s -> a) | Put s a | LiftAccessT (f a) deriving (Functor, Typeable)
+-- | Extend an object by adding another independent object.
+(.|>.) :: 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
 
-instance Stateful s (AccessT s f) where
-  get_ = Get id
-  put_ s = Put s ()
+data Request a b r = Request a (b -> r)
 
-instance (Functor f, Stateful s f) => Stateful s (Free f) where
-  get_ = liftF get_
-  put_ = liftF . put_
+class Lift f g | g -> f where
+  lift_ :: f a -> g a
 
--- | A mutable variable.
-variable :: Applicative f => s -> Object (Access s) f
-variable s = Object $ \x -> case x of
-  Get cont -> pure (cont s, variable s)
-  Put s' cont -> pure (cont, variable s')
-  LiftAccessT e -> pure (extract e, variable s)
+instance Lift (Request a b) (Request a b) where
+  lift_ = id
 
-type Access s = AccessT s Zero
+instance (f ∈ u) => Lift f (Union u) where
+  lift_ = liftU
 
--- | Convert a /method sequence/ into a sequential /method execution/.
-sequential :: Monad m => Object e m -> Object (Free e) m
-sequential obj = Object $ \x -> case x of
-  Pure a -> return (a, sequential obj)
-  Free f -> do
-    (a, obj') <- runObject obj f
-    runObject (sequential obj') a
+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)