objective 0.5.2.1 → 0.6

raw patch · 6 files changed

+64/−48 lines, 6 files

Files

objective.cabal +1/−1
src/Control/Monad/Objective/Class.hs +21/−26
src/Control/Monad/Objective/IO.hs +12/−8
src/Control/Monad/Objective/ST.hs +13/−9
src/Data/Functor/PushPull.hs +5/−2
src/Data/Functor/Request.hs +12/−2

objective.cabal view

@@ -1,5 +1,5 @@ name:                objective
-version:             0.5.2.1
+version:             0.6
 synopsis:            Extensible objects
 description:         Stateful effect transducer
 homepage:            https://github.com/fumieval/objective

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

@@ -4,6 +4,8 @@ {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE CPP #-}
 -----------------------------------------------------------------------------
 -- |
@@ -21,43 +23,36 @@ module Control.Monad.Objective.Class where
 import Control.Object
 
-import Control.Monad
 import Control.Elevator
 import Control.Monad.Trans.State.Strict
 
-type Instance' e m = Instance e m m
+type Inst' f g = Inst g f g
+type Instance' f g = Inst g f g
+type Instance f g m = Inst m f g
 
-class (Tower m, Monad m) => MonadObjective m where
-  data Instance (e :: * -> *) (n :: * -> *) m
-  -- | Send a message to the pointed one.
-  invoke :: Monad n => Instance e n m -> e a -> m (n (m a))
-  -- | Add an object to the environment.
-  new :: Object e n -> m (Instance e n m)
+class ObjectiveBase b where
+  data Inst b (f :: * -> *) (g :: * -> *)
+  new :: Object f g -> b (Inst b f g)
+  invoke :: Monad r => (forall x. b x -> r x) -> (forall x. g x -> r x) -> Inst b f g -> f a -> r a
 
--- | Invoke a method.
-(.-) :: (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
+(.-) :: (ObjectiveBase b, Elevate b m, Elevate g m, Monad m) => Inst b f g -> f a -> m a
+(.-) = invoke elevate elevate
 {-# INLINE (.-) #-}
 
 infix 3 .-
 
--- | Similar to '(.-)', but also lifts the method according to the instance.
-(.^) :: (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
+-- | Invoke a method.
+(.^) :: (ObjectiveBase b, Elevate b m, Elevate g m, Monad m, Elevate e f) => Inst b f g -> e a -> m a
+i .^ e = i .- elevate e
 {-# INLINE (.^) #-}
-
 infix 3 .^
 
 -- | Specialized (.^) for StateT
-(.&) :: (MonadObjective m, Elevate (StateT s m) e, Monad n, Elevate n m, Elevate m f) => Instance e n m -> StateT s m a -> f a
-(.&) = (.^)
-{-# INLINE (.&) #-}
-infix 3 .&
+(.&) :: (ObjectiveBase b, Elevate b m, Elevate g m, Monad m, Elevate (State s) f) => Inst b f g -> StateT s m a -> m a
+i .& m = do
+  s <- i .^ get
+  (a, s') <- runStateT m s
+  i .^ put s'
+  return a
 
+infix 3 .&

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

@@ -17,14 +17,18 @@ import Control.Monad.Objective.Class
 import Control.Concurrent
 import Control.Object
+import Control.Monad.IO.Class
 
-instance MonadObjective IO where
+instance ObjectiveBase IO where
+  data Inst IO f g = InstIO (MVar (Object f g))
 
-  data Instance e m IO = InstanceIO (MVar (Object e m))
+  invoke mr gr (InstIO m) e = do
+    c <- mr (takeMVar m)
+    (a, c') <- gr (runObject c e)
+    mr (putMVar m c')
+    return a
 
-  InstanceIO m `invoke` e = do
-    c <- takeMVar m
-    return $ do
-      (a, c') <- runObject c e
-      return (putMVar m c' >> return a)
-  new v = InstanceIO `fmap` newMVar v+  new v = InstIO `fmap` newMVar v
+
+newIO :: MonadIO m => Object f g -> m (Inst IO f g)
+newIO = liftIO . new

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

@@ -1,4 +1,4 @@-{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeFamilies, ConstraintKinds, FlexibleContexts #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 -----------------------------------------------------------------------------
@@ -20,13 +20,17 @@ import Control.Monad.ST
 import Control.Object
 import Data.STRef
+import Control.Elevator
 
-instance MonadObjective (ST s) where
-  data Instance e m (ST s) = InstanceST (STRef s (Object e m))
+instance ObjectiveBase (ST s) where
+  data Inst (ST s) f g = InstST (STRef s (Object f g))
 
-  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
+  invoke mr gr (InstST ref) e = do
+    o <- mr (readSTRef ref)
+    (a, o') <- gr (runObject o e)
+    mr (writeSTRef ref o')
+    return a
+  new o = InstST `fmap` newSTRef o
+
+newST :: Elevate (ST s) m => Object f g -> m (Inst (ST s) f g)
+newST = elevate . new

src/Data/Functor/PushPull.hs view

@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveFunctor, DeriveDataTypeable, ConstraintKinds, FlexibleContexts #-}
+{-# LANGUAGE DeriveFunctor, DeriveDataTypeable, ConstraintKinds, FlexibleContexts, DataKinds, TypeFamilies, TypeOperators #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Data.Functor.PushPull
@@ -13,11 +13,14 @@ module Data.Functor.PushPull where
 import Data.Typeable
 import Control.Elevator
+import Data.OpenUnion1.Clean
 
 -- | The type for asynchronous input/output.
 data PushPull a b r = Push a r | Pull (b -> r) deriving (Functor, Typeable)
 
-instance Tower (PushPull a b)
+instance Tower (PushPull a b) where
+  type Floors (PushPull a b) = (,) a :> (->) b :> Empty
+  toLoft = uncurry Push ||> Pull ||> exhaust
 
 push :: (Elevate (PushPull a b) f) => a -> f ()
 push a = elevate (Push a ())

src/Data/Functor/Request.hs view

@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveFunctor, DeriveDataTypeable, ConstraintKinds, FlexibleContexts #-}
+{-# LANGUAGE DeriveFunctor, DeriveDataTypeable, ConstraintKinds, FlexibleContexts, TypeOperators, DataKinds, TypeFamilies #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Data.Functor.Request
@@ -14,11 +14,21 @@ import Data.Typeable
 import Control.Elevator
 import Control.Monad
+import Data.Monoid
+import Control.Applicative
+import Data.OpenUnion1.Clean
+import Data.Functor.Identity
 
 -- | 'Request a b' is the type of a request that sends @a@ to receive @b@.
 data Request a b r = Request a (b -> r) deriving (Functor, Typeable)
 
-instance Tower (Request a b)
+instance Monoid a => Applicative (Request a b) where
+  pure a = Request mempty (const a)
+  Request a c <*> Request b d = Request (mappend a b) (c <*> d)
+
+instance Monoid a => Tower (Request a b) where
+  type Floors (Request a b) = (,) a :> (->) b :> Identity :> Empty
+  toLoft = (\(a, b) -> Request a (const b)) ||> Request mempty ||> pure . runIdentity ||> exhaust
 
 request :: (Elevate (Request a b) f) => a -> f b
 request a = elevate (Request a id)