packages feed

objective 1 → 1.0.1

raw patch · 5 files changed

+137/−33 lines, 5 filesdep +stmdep ~basedep ~containersdep ~either

Dependencies added: stm

Dependency ranges changed: base, containers, either, free, hashable, profunctors, transformers, unordered-containers

Files

CHANGELOG.md view
@@ -1,3 +1,22 @@+1.0.1+----+* Switched to use TMVar for instances+* Added atomic operations+* Add `apprises`+* Re-added `accept`+* Added `(>~~>)`+* Added `accumulator`++1.0+----+* No longer support `extensible`, `elevator`, and `minioperational`+* Removed `Data.Functor.PushPull`+* Removed `Control.Object.Process`+* Removed `Control.Object.Stream`+* Removed `Control.Monad.Objective`+* Added `apprise`+* Generalized `(^>>@)` and `(@>>^)` so that they also work on instances+ 0.6.5 ---- * Supported `elevator >= 0.2`.
objective.cabal view
@@ -1,8 +1,9 @@ name:                objective-version:             1+version:             1.0.1 synopsis:            Extensible objects description:         Stateful effect transducer homepage:            https://github.com/fumieval/objective+bug-reports:         http://github.com/fumieval/objective/issues license:             BSD3 license-file:        LICENSE author:              Fumiaki Kinoshita@@ -15,6 +16,10 @@   .travis.yml cabal-version:       >=1.10 +source-repository head+  type: git+  location: https://github.com/fumieval/objective.git+ library   exposed-modules:     Control.Object@@ -22,18 +27,18 @@       , Control.Object.Instance       , Control.Object.Mortal       , Data.Functor.Request-  -- other-modules:   other-extensions:    MultiParamTypeClasses, KindSignatures, TypeFamilies-  build-depends:       base >=4.5 && <5-    , containers-    , free >= 4.4 && <5-    , unordered-containers-    , hashable >= 1.2 && <1.4-    , profunctors >= 4.0 && <5-    , either+  build-depends:       base >=4.6 && <5+    , either >= 4.3 && <4.5+    , containers >= 0.5.0.0 && <0.6+    , unordered-containers >= 0.2.0.0 && <0.3+    , transformers >= 0.3+    , free+    , hashable+    , profunctors     , void     , witherable-    , transformers >= 0.3 && <0.5+    , stm   ghc-options: -Wall   hs-source-dirs:      src   default-language:    Haskell2010
src/Control/Object/Instance.hs view
@@ -1,41 +1,66 @@ {-# LANGUAGE GADTs, Rank2Types #-} module Control.Object.Instance where-import Control.Concurrent.MVar+import Control.Concurrent.STM.TMVar+import Control.Monad.STM import Control.Object.Object import Control.Monad.IO.Class import Control.Monad --- | MVar-based instance+-- | TMVar-based instance data Instance f g where-  InstRef :: MVar (Object f g) -> Instance f g+  InstRef :: TMVar (Object f g) -> Instance f g   InstLmap :: (forall x. f x -> g x) -> Instance g h -> Instance f h   InstRmap :: Instance f g -> (forall x. g x -> h x) -> Instance f h  instance HProfunctor Instance where   (^>>@) = InstLmap+  {-# INLINE (^>>@) #-}   (@>>^) = InstRmap+  {-# INLINE (@>>^) #-}  -- | Invoke a method with an explicit landing function.-invoke :: MonadIO m => (forall x. g x -> m x) -> Instance f g -> f a -> m a-invoke m (InstRef v) f = do-  obj <- liftIO (takeMVar v)+invokeOn :: MonadIO m => (forall x. g x -> m x) -> Instance f g -> f a -> m a+invokeOn m (InstRef v) f = do+  obj <- liftIO $ atomically $ takeTMVar v   (a, obj') <- m (runObject obj f)-  liftIO $ putMVar v obj'+  liftIO $ atomically $ putTMVar v obj'   return a-invoke m (InstLmap t i) f = invoke m i (t f)-invoke m (InstRmap i t) f = invoke (m . t) i f+invokeOn m (InstLmap t i) f = invokeOn m i (t f)+invokeOn m (InstRmap i t) f = invokeOn (m . t) i f +-- | Invoke a method with an explicit landing function.+invokeOnSTM :: (forall x. g x -> STM x) -> Instance f g -> f a -> STM a+invokeOnSTM m (InstRef v) f = do+  obj <- takeTMVar v+  (a, obj') <- m (runObject obj f)+  putTMVar v obj'+  return a+invokeOnSTM m (InstLmap t i) f = invokeOnSTM m i (t f)+invokeOnSTM m (InstRmap i t) f = invokeOnSTM (m . t) i f++-- | Invoke a method, atomically.+(..-) :: Instance f STM -> f a -> STM a+(..-) i = invokeOnSTM id i+{-# INLINE (..-) #-}+infixr 3 ..-+ -- | Invoke a method. (.-) :: MonadIO m => Instance f m -> f a -> m a-(.-) = invoke id+(.-) = invokeOn id {-# INLINE (.-) #-}+infixr 3 .-  -- | Create a new instance. new :: MonadIO m => Object f g -> m (Instance f g)-new = liftIO . liftM InstRef . newMVar+new = liftIO . atomically . newSTM {-# INLINE new #-}  -- | Create a new instance, having it sitting on the current environment. newSettle :: MonadIO m => Object f m -> m (Instance f m) newSettle = new {-# INLINE newSettle #-}++-- | Create a new instance.+newSTM :: Object f g -> STM (Instance f g)+newSTM = liftM InstRef . newTMVar+{-# INLINE newSTM #-}
src/Control/Object/Mortal.hs view
@@ -7,7 +7,13 @@     mortal_,     runMortal,     immortal,-    apprise+    apprise,+    apprises,+    -- * Combinators+    gatherFst,+    gatherSnd,+    buildSingle,+    buildBoth,     ) where  import Control.Object.Object@@ -20,6 +26,7 @@ import Data.Monoid import Data.Witherable import Unsafe.Coerce+import Control.Arrow ((***))  -- | Object with a final result. --@@ -69,9 +76,32 @@  -- | Send a message to mortals in a container. apprise :: (Witherable t, Monad m, Applicative m) => f a -> StateT (t (Mortal f m r)) m ([a], [r])-apprise f = StateT $ \t -> do-  (t', (Endo ba, Endo br)) <- runWriterT $ flip wither t+apprise f = buildBoth (apprises f)+{-# INLINE apprise #-}++-- | Send a message to mortals in a container.+apprises :: (Witherable t, Monad m, Applicative m, Monoid r) => f a -> (a -> r) -> (b -> r) -> StateT (t (Mortal f m b)) m r+apprises f = \p q -> StateT $ \t -> do+  (t', res) <- runWriterT $ flip wither t     $ \obj -> lift (runEitherT $ runMortal obj f) >>= \case-      Left r -> writer (Nothing, (mempty, Endo (r:)))-      Right (x, obj') -> writer (Just obj', (Endo (x:), mempty))-  return ((ba [], br []), t')+      Left r -> writer (Nothing, q r)+      Right (x, obj') -> writer (Just obj', p x)+  return (res, t')+{-# INLINE apprises #-}++gatherFst :: (Monoid r) => (a -> r) -> ((a -> r) -> (b -> r) -> k) -> k+gatherFst g f = f g (const mempty)+{-# INLINE gatherFst #-}++gatherSnd :: (Monoid r) => (b -> r) -> ((a -> r) -> (b -> r) -> k) -> k+gatherSnd g f = f (const mempty) g+{-# INLINE gatherSnd #-}++buildSingle :: Functor f => ((a -> Endo [a]) -> f (Endo [a])) -> f [a]+buildSingle f = fmap (flip appEndo []) (f (Endo . (:)))+{-# INLINABLE buildSingle #-}++buildBoth :: Functor f => ((a -> (Endo [a], Endo [b])) -> (b -> (Endo [a], Endo [b])) -> f (Endo [a], Endo [b])) -> f ([a], [b])+buildBoth f = fmap (flip appEndo [] *** flip appEndo [])+  $ f (\a -> (Endo (a:), mempty)) (\b -> (mempty, Endo (b:)))+{-# INLINABLE buildBoth #-}
src/Data/Functor/Request.hs view
@@ -34,27 +34,52 @@  instance Monoid a => Applicative (Request a b) where   pure a = Request mempty (const a)+  {-# INLINE pure #-}   Request a c <*> Request b d = Request (mappend a b) (c <*> d)+  {-# INLINE (<*>) #-}  request :: a -> Request a b b request a = Request a id {-# INLINE request #-} +accept :: Functor m => (a -> m b) -> Request a b r -> m r+accept f = \(Request a cont) -> cont <$> f a+{-# INLINE accept #-}++{-# DEPRECATED handles "Use mealy instead" #-} handles :: Functor m => (a -> m (b, Object (Request a b) m)) -> Object (Request a b) m-handles f = Object $ \(Request a cont) -> first cont <$> f a-{-# INLINE handles #-}+handles = mealy +mealy :: Functor m => (a -> m (b, Object (Request a b) m)) -> Object (Request a b) m+mealy f = Object $ \(Request a cont) -> first cont <$> f a+{-# INLINE mealy #-}+ -- | Like 'flyweight', but it uses 'Data.HashMap.Strict' internally. flyweight :: (Applicative m, Eq k, Hashable k) => (k -> m a) -> Object (Request k a) m flyweight f = go HM.empty where-  go m = Object $ \(Request k cont) -> case HM.lookup k m of-    Just a -> pure (cont a, go m)-    Nothing -> (\a -> (cont a, go $ HM.insert k a m)) <$> f k+  go m = mealy $ \k -> case HM.lookup k m of+    Just a -> pure (a, go m)+    Nothing -> (\a -> (a, go $ HM.insert k a m)) <$> f k {-# INLINE flyweight #-} +(>~~>) :: Monad m => Object (Request a b) m -> Object (Request b c) m -> Object (Request a c) m+p >~~> q = Object $ \(Request a cont) -> do+  (b, p') <- runObject p (Request a id)+  (r, q') <- runObject q (Request b cont)+  return (r, p' >~~> q')++accumulator :: Applicative m => (b -> a -> b) -> b -> Object (Request a b) m+accumulator f = go where+  go b = mealy $ \a -> pure (b, go (f b a))+{-# INLINE accumulator #-}++-- |+-- @+-- animate f ≡ accumulator (+) 0 >~~> liftO (accept f)+-- @ animate :: (Applicative m, Num t) => (t -> m a) -> Object (Request t a) m animate f = go 0 where-  go t = Object $ \(Request dt cont) -> (\x -> (cont x, go (t + dt))) <$> f t+  go t = mealy $ \dt -> flip (,) (go (t + dt)) <$> f t {-# INLINE animate #-}  transit :: (Alternative m, Fractional t, Ord t) => t -> (t -> m a) -> Object (Request t a) m