objective 1.1 → 1.1.1

raw patch · 7 files changed

+708/−693 lines, 7 filesdep ~either

Dependency ranges changed: either

Files

CHANGELOG.md +114/−114
objective.cabal +48/−48
src/Control/Object.hs +19/−19
src/Control/Object/Instance.hs +79/−64
src/Control/Object/Mortal.hs +115/−115
src/Control/Object/Object.hs +240/−240
src/Data/Functor/Request.hs +93/−93

CHANGELOG.md view

@@ -1,114 +1,114 @@-1.1------* Removed `HProfunctor`, `(..-)`, `invokeOnSTM`, `newSTM`, `snapshot`-* Added `(?-)`--1.0.5------* Added `filterO` and `filteredO`-* Renamed `announcesOf` to `invokesOf`-* Added `invokes`-* Added `(@!=)`-* Shaved unnecessary `Monoid r` off in `apprisesOf`--1.0.4------* Simplified `Instance`-* Added `snapshot`-* Added `cascade`, `cascadeObject`-* Added `announcesOf`-* Added `(@||@)`-* Safe Haskell--1.0.3------* Added `apprisesOf`-* Added `(@~)`--1.0.2------* Made `(.-)` exception-safe--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`.--0.6.3.1------* Reverted the fixity.--0.6.3------* Added `Variable`, an alias for `variable` objects.-* Added `Mortal`.-* Increased fixity of invocation operators to 5.-* Added stream connection operators.-* Added `transit` and `animate`.--0.6.2------* Added `announce`, `announceMaybe` and `announceMaybeT` which invoke a method for every objects in a container.-* Added `(@**@)` and `(@||@)`.-* Renamed `(.>>.)` to `(@>>@)`, `.|>.` to `(@|>@)` for consistency.-* Added `filterPush`, `bipush`, `bipull`.-* Added `iterObject`, `iterTObject`, `iterative`, `iterativeT` for free monads.-* Renamed `runSequential` to `(@!)`.-* Added combinators for `ReifiedProgramT`: `(@!!)` and `sequentialT`.-* Changed the semantics of `variable` to accept `StateT`.-* Added `flyweight'` that relies on HashMap.-* Added `MonadObjective` constraint--0.6.1-------* Fixed the wrong constraints of `request`--0.6-------* `PushPull` has more `Floors`-* Added `Applicative` instance for `Request`-* Reformed around Control.Monad.Objective-  * Instance f g m ==> Inst m f g-  * `invoke` takes two transformations for lifting-  * Added lifted versions of `new`: `newIO` and `newST`--0.5.2-------* Added Process-* Added `runSequential`, `sequential` for operational monad-* Added `flyweight`--0.5.1-------* Added PushPull functor-* Removed `sequential`--0.5-------* Lift has gone-* Use elevator instead of Lift-* Moved Request to a separate module--0.4-------* Added Request functor along with Lift-* Supported "extensible" objects using open unions-* AccessT is now obsolete+1.1
+----
+* Removed `HProfunctor`, `(..-)`, `invokeOnSTM`, `newSTM`, `snapshot`
+* Added `(?-)`
+
+1.0.5
+----
+* Added `filterO` and `filteredO`
+* Renamed `announcesOf` to `invokesOf`
+* Added `invokes`
+* Added `(@!=)`
+* Shaved unnecessary `Monoid r` off in `apprisesOf`
+
+1.0.4
+----
+* Simplified `Instance`
+* Added `snapshot`
+* Added `cascade`, `cascadeObject`
+* Added `announcesOf`
+* Added `(@||@)`
+* Safe Haskell
+
+1.0.3
+----
+* Added `apprisesOf`
+* Added `(@~)`
+
+1.0.2
+----
+* Made `(.-)` exception-safe
+
+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`.
+
+0.6.3.1
+----
+* Reverted the fixity.
+
+0.6.3
+----
+* Added `Variable`, an alias for `variable` objects.
+* Added `Mortal`.
+* Increased fixity of invocation operators to 5.
+* Added stream connection operators.
+* Added `transit` and `animate`.
+
+0.6.2
+----
+* Added `announce`, `announceMaybe` and `announceMaybeT` which invoke a method for every objects in a container.
+* Added `(@**@)` and `(@||@)`.
+* Renamed `(.>>.)` to `(@>>@)`, `.|>.` to `(@|>@)` for consistency.
+* Added `filterPush`, `bipush`, `bipull`.
+* Added `iterObject`, `iterTObject`, `iterative`, `iterativeT` for free monads.
+* Renamed `runSequential` to `(@!)`.
+* Added combinators for `ReifiedProgramT`: `(@!!)` and `sequentialT`.
+* Changed the semantics of `variable` to accept `StateT`.
+* Added `flyweight'` that relies on HashMap.
+* Added `MonadObjective` constraint
+
+0.6.1
+-----
+* Fixed the wrong constraints of `request`
+
+0.6
+-----
+* `PushPull` has more `Floors`
+* Added `Applicative` instance for `Request`
+* Reformed around Control.Monad.Objective
+  * Instance f g m ==> Inst m f g
+  * `invoke` takes two transformations for lifting
+  * Added lifted versions of `new`: `newIO` and `newST`
+
+0.5.2
+-----
+* Added Process
+* Added `runSequential`, `sequential` for operational monad
+* Added `flyweight`
+
+0.5.1
+-----
+* Added PushPull functor
+* Removed `sequential`
+
+0.5
+-----
+* Lift has gone
+* Use elevator instead of Lift
+* Moved Request to a separate module
+
+0.4
+-----
+* Added Request functor along with Lift
+* Supported "extensible" objects using open unions
+* AccessT is now obsolete

objective.cabal view

@@ -1,48 +1,48 @@-name:                objective-version:             1.1-synopsis:            Composable objects-description:         Composable objects-homepage:            https://github.com/fumieval/objective-bug-reports:         http://github.com/fumieval/objective/issues-license:             BSD3-license-file:        LICENSE-author:              Fumiaki Kinoshita-maintainer:          Fumiaki Kinoshita <fumiexcel@gmail.com>-copyright:           Copyright (c) 2014 Fumiaki Kinoshita-category:            Control-build-type:          Simple-extra-source-files:-  CHANGELOG.md-  .travis.yml-cabal-version:       >=1.10--source-repository head-  type: git-  location: https://github.com/fumieval/objective.git--library-  exposed-modules:-    Control.Object-      , Control.Object.Object-      , Control.Object.Instance-      , Control.Object.Mortal-      , Data.Functor.Request-  other-extensions:    MultiParamTypeClasses, KindSignatures, TypeFamilies-  build-depends:       base >=4.6 && <5-    , either >= 4.3 && <4.5-    , exceptions >= 0.8-    , containers >= 0.5.0.0 && <0.6-    , unordered-containers >= 0.2.0.0 && <0.3-    , transformers >= 0.3 && <0.6-    , transformers-compat-    , free >= 4 && <5-    , hashable-    , mtl-    , profunctors-    , void-    , witherable >= 0.1.3-    , monad-skeleton >= 0.1.1 && <0.3-    , template-haskell-  ghc-options: -Wall-  hs-source-dirs:      src-  default-language:    Haskell2010+name:                objective
+version:             1.1.1
+synopsis:            Composable objects
+description:         Composable objects
+homepage:            https://github.com/fumieval/objective
+bug-reports:         http://github.com/fumieval/objective/issues
+license:             BSD3
+license-file:        LICENSE
+author:              Fumiaki Kinoshita
+maintainer:          Fumiaki Kinoshita <fumiexcel@gmail.com>
+copyright:           Copyright (c) 2014 Fumiaki Kinoshita
+category:            Control
+build-type:          Simple
+extra-source-files:
+  CHANGELOG.md
+  .travis.yml
+cabal-version:       >=1.10
+
+source-repository head
+  type: git
+  location: https://github.com/fumieval/objective.git
+
+library
+  exposed-modules:
+    Control.Object
+      , Control.Object.Object
+      , Control.Object.Instance
+      , Control.Object.Mortal
+      , Data.Functor.Request
+  other-extensions:    MultiParamTypeClasses, KindSignatures, TypeFamilies
+  build-depends:       base >=4.6 && <5
+    , either >= 4.3 && <4.5
+    , exceptions >= 0.8
+    , containers >= 0.5.0.0 && <0.6
+    , unordered-containers >= 0.2.0.0 && <0.3
+    , transformers >= 0.3 && <0.6
+    , transformers-compat
+    , free >= 4 && <5
+    , hashable
+    , mtl
+    , profunctors
+    , void
+    , witherable >= 0.1.3
+    , monad-skeleton >= 0.1.1 && <0.3
+    , template-haskell
+  ghc-options: -Wall
+  hs-source-dirs:      src
+  default-language:    Haskell2010

src/Control/Object.hs view

@@ -1,20 +1,20 @@--------------------------------------------------------------------------------- |--- Module      :  Control.Object--- Copyright   :  (c) Fumiaki Kinoshita 2015--- License     :  BSD3------ Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>--- Stability   :  experimental--- Portability :  non-portable----------------------------------------------------------------------------------module Control.Object-  ( module Control.Object.Object,-    module Control.Object.Mortal,-    module Control.Object.Instance,-  ) where--import Control.Object.Object-import Control.Object.Mortal+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Control.Object
+-- Copyright   :  (c) Fumiaki Kinoshita 2015
+-- License     :  BSD3
+--
+-- Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+-----------------------------------------------------------------------------
+module Control.Object
+  ( module Control.Object.Object,
+    module Control.Object.Mortal,
+    module Control.Object.Instance,
+  ) where
+
+import Control.Object.Object
+import Control.Object.Mortal
 import Control.Object.Instance

src/Control/Object/Instance.hs view

@@ -1,64 +1,79 @@-{-# LANGUAGE GADTs, Rank2Types, LambdaCase #-}--------------------------------------------------------------------------------- |--- Module      :  Control.Object.Instance--- Copyright   :  (c) Fumiaki Kinoshita 2015--- License     :  BSD3------ Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>--- Stability   :  provisional--- Portability :  GADTs, Rank2Types----------------------------------------------------------------------------------module Control.Object.Instance (-  -- * Instantiation-  Instance-  , new-  , newSettle-  -- * Invocation-  , invokeOn-  , (.-)-  , (?-)-  ) where-import Control.Concurrent-import Control.Exception (evaluate)-import Control.Object.Object-import Control.Monad.IO.Class-import Control.Monad.Catch--type Instance f g = MVar (Object f g)---- | Invoke a method with an explicit landing function.--- In case of exception, the original object will be set.-invokeOn :: (MonadIO m, MonadMask m)-         => (forall x. g x -> m x) -> MVar (Object f g) -> f a -> m a-invokeOn m v f = mask $ \restore -> do-  obj <- liftIO $ takeMVar v-  (a, obj') <- restore (m (runObject obj f) >>= liftIO . evaluate) `onException` liftIO (putMVar v obj)-  liftIO $ putMVar v obj'-  return a---- | Invoke a method.-(.-) :: (MonadIO m, MonadMask m) => MVar (Object f m) -> f a -> m a-(.-) = invokeOn id-{-# INLINE (.-) #-}-infixr 3 .----- | Try to invoke a method. If the instance is unavailable, it returns Nothing.-(?-) :: (MonadIO m, MonadMask m) => MVar (Object f m) -> f a -> m (Maybe a)-v ?- f = mask $ \restore -> liftIO (tryTakeMVar v) >>= \case-  Just obj -> do-    (a, obj') <- restore (runObject obj f >>= liftIO . evaluate) `onException` liftIO (putMVar v obj)-    liftIO $ putMVar v obj'-    return (Just a)-  Nothing -> return Nothing---- | Create a new instance. This can be used inside 'unsafePerformIO' to create top-level instances.-new :: MonadIO m => Object f g -> m (Instance f g)-new = liftIO . newMVar-{-# 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 #-}+{-# LANGUAGE GADTs, Rank2Types, LambdaCase #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Control.Object.Instance
+-- Copyright   :  (c) Fumiaki Kinoshita 2015
+-- License     :  BSD3
+--
+-- Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>
+-- Stability   :  provisional
+-- Portability :  GADTs, Rank2Types
+--
+-----------------------------------------------------------------------------
+module Control.Object.Instance (
+  -- * Instantiation
+  Instance
+  , new
+  , newSettle
+  -- * Invocation
+  , invokeOnUsing
+  , invokeOn
+  , (.-)
+  , (..-)
+  , (?-)
+  ) where
+import Control.Concurrent
+import Control.Exception (evaluate)
+import Control.Object.Object
+import Control.Monad.IO.Class
+import Control.Monad.Catch
+import Control.Monad.Skeleton
+
+type Instance f g = MVar (Object f g)
+
+invokeOnUsing :: (MonadIO m, MonadMask m)
+  => (Object f g -> t a -> g (a, Object f g))
+  -> (forall x. g x -> m x) -> MVar (Object f g) -> t a -> m a
+invokeOnUsing run m v f = mask $ \restore -> do
+  obj <- liftIO $ takeMVar v
+  (a, obj') <- restore (m (run obj f) >>= liftIO . evaluate) `onException` liftIO (putMVar v obj)
+  liftIO $ putMVar v obj'
+  return a
+
+-- | Invoke a method with an explicit landing function.
+-- In case of exception, the original object will be set.
+invokeOn :: (MonadIO m, MonadMask m)
+         => (forall x. g x -> m x) -> MVar (Object f g) -> f a -> m a
+invokeOn = invokeOnUsing runObject
+{-# INLINE invokeOn #-}
+
+-- | Invoke a method.
+(.-) :: (MonadIO m, MonadMask m) => MVar (Object f m) -> f a -> m a
+(.-) = invokeOn id
+{-# INLINE (.-) #-}
+infixr 3 .-
+
+(..-) :: (MonadIO m, MonadMask m)
+    => MVar (Object t m) -> Skeleton t a -> m a
+(..-) = invokeOnUsing cascadeObject id
+{-# INLINE (..-) #-}
+infixr 3 ..-
+
+-- | Try to invoke a method. If the instance is unavailable, it returns Nothing.
+(?-) :: (MonadIO m, MonadMask m) => MVar (Object f m) -> f a -> m (Maybe a)
+v ?- f = mask $ \restore -> liftIO (tryTakeMVar v) >>= \case
+  Just obj -> do
+    (a, obj') <- restore (runObject obj f >>= liftIO . evaluate) `onException` liftIO (putMVar v obj)
+    liftIO $ putMVar v obj'
+    return (Just a)
+  Nothing -> return Nothing
+
+-- | Create a new instance. This can be used inside 'unsafePerformIO' to create top-level instances.
+new :: MonadIO m => Object f g -> m (Instance f g)
+new = liftIO . newMVar
+{-# 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 #-}

src/Control/Object/Mortal.hs view

@@ -1,115 +1,115 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE BangPatterns #-}--------------------------------------------------------------------------------- |--- Module      :  Control.Object.Mortal--- Copyright   :  (c) Fumiaki Kinoshita 2015--- License     :  BSD3------ Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>--- Stability   :  provisional--- Portability :  GADTs, Rank2Types----------------------------------------------------------------------------------module Control.Object.Mortal (-    Mortal(..),-    mortal,-    mortal_,-    runMortal,-    immortal,-    apprisesOf,-    apprises,-    apprise-    ) where--import Control.Object.Object-#if !MIN_VERSION_base(4,8,0)-import Control.Applicative-#endif-import Control.Monad.Trans.Either-import Control.Monad-import Control.Monad.Trans.Class-import Control.Monad.Trans.State.Strict-import Control.Monad.Trans.Writer.Strict-import Data.Monoid-import Data.Witherable-import Data.Tuple (swap)-import Control.Arrow ((***))-import Unsafe.Coerce---- | A 'Mortal' is an object that may die.--- A mortal yields a final result upon death.--- @'Mortal' f g@ forms a 'Monad':--- 'return' is a dead object and ('>>=') prolongs the life of the left object.------ @Object f g ≡ Mortal f g Void@----newtype Mortal f g a = Mortal { unMortal :: Object f (EitherT a g) }--instance (Functor m, Monad m) => Functor (Mortal f m) where-  fmap f (Mortal obj) = Mortal (obj @>>^ bimapEitherT f id)-  {-# INLINE fmap #-}--instance (Functor m, Monad m) => Applicative (Mortal f m) where-  pure = return-  {-# INLINE pure #-}-  (<*>) = ap-  {-# INLINE (<*>) #-}--instance Monad m => Monad (Mortal f m) where-  return a = mortal $ const $ left a-  {-# INLINE return #-}-  m >>= k = mortal $ \f -> lift (runEitherT $ runMortal m f) >>= \r -> case r of-    Left a -> runMortal (k a) f-    Right (x, m') -> return (x, m' >>= k)--instance MonadTrans (Mortal f) where-  lift m = mortal $ const $ EitherT $ liftM Left m-  {-# INLINE lift #-}---- | Construct a mortal in a 'Object' construction manner.-mortal :: Monad m => (forall x. f x -> EitherT a m (x, Mortal f m a)) -> Mortal f m a-mortal f = unsafeCoerce f `asTypeOf` Mortal (Object (fmap (fmap unMortal) . f))-{-# INLINE mortal #-}---- | Send a message to a mortal.-runMortal :: Monad m => Mortal f m a -> f x -> EitherT a m (x, Mortal f m a)-runMortal = unsafeCoerce `asTypeOf` ((fmap (fmap Mortal) . ) . runObject . unMortal)-{-# INLINE runMortal #-}---- | Restricted 'Mortal' constuctor which can be applied to 'transit', 'fromFoldable' without ambiguousness.-mortal_ :: Object f (EitherT () g) -> Mortal f g ()-mortal_ = Mortal-{-# INLINE mortal_ #-}---- | Turn an object into a mortal without death.-immortal :: Monad m => Object f m -> Mortal f m x-immortal obj = Mortal (obj @>>^ lift)-{-# INLINE immortal #-}---- | Send a message to mortals through a filter.-apprisesOf :: Monad m-  => FilterLike' (WriterT r m) s (Mortal f m b)-  -> f a -> (a -> r) -> (b -> r) -> StateT s m r-apprisesOf l f p q = StateT $ \t -> liftM swap $ runWriterT $ flip l t-    $ \obj -> WriterT $ runEitherT (runMortal obj f) >>= \case-      Left r -> return (Nothing, q r)-      Right (x, obj') -> return (Just obj', p x)-{-# INLINABLE apprisesOf #-}---- | Send a message to mortals in a 'Witherable' container.------ @apprises = apprisesOf wither@----apprises :: (Witherable t, Monad m, Applicative m, Monoid r) => f a -> (a -> r) -> (b -> r) -> StateT (t (Mortal f m b)) m r-apprises = apprisesOf wither-{-# INLINE apprises #-}---- | 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 = fmap (flip appEndo [] *** flip appEndo [])-  $ apprises f (\a -> (Endo (a:), mempty)) (\b -> (mempty, Endo (b:)))-{-# INLINE apprise #-}+{-# LANGUAGE CPP #-}
+{-# LANGUAGE Trustworthy #-}
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE BangPatterns #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Control.Object.Mortal
+-- Copyright   :  (c) Fumiaki Kinoshita 2015
+-- License     :  BSD3
+--
+-- Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>
+-- Stability   :  provisional
+-- Portability :  GADTs, Rank2Types
+--
+-----------------------------------------------------------------------------
+module Control.Object.Mortal (
+    Mortal(..),
+    mortal,
+    mortal_,
+    runMortal,
+    immortal,
+    apprisesOf,
+    apprises,
+    apprise
+    ) where
+
+import Control.Object.Object
+#if !MIN_VERSION_base(4,8,0)
+import Control.Applicative
+#endif
+import Control.Monad.Trans.Either
+import Control.Monad
+import Control.Monad.Trans.Class
+import Control.Monad.Trans.State.Strict
+import Control.Monad.Trans.Writer.Strict
+import Data.Monoid
+import Data.Witherable
+import Data.Tuple (swap)
+import Control.Arrow ((***))
+import Unsafe.Coerce
+
+-- | A 'Mortal' is an object that may die.
+-- A mortal yields a final result upon death.
+-- @'Mortal' f g@ forms a 'Monad':
+-- 'return' is a dead object and ('>>=') prolongs the life of the left object.
+--
+-- @Object f g ≡ Mortal f g Void@
+--
+newtype Mortal f g a = Mortal { unMortal :: Object f (EitherT a g) }
+
+instance (Functor m, Monad m) => Functor (Mortal f m) where
+  fmap f (Mortal obj) = Mortal (obj @>>^ bimapEitherT f id)
+  {-# INLINE fmap #-}
+
+instance (Functor m, Monad m) => Applicative (Mortal f m) where
+  pure = return
+  {-# INLINE pure #-}
+  (<*>) = ap
+  {-# INLINE (<*>) #-}
+
+instance Monad m => Monad (Mortal f m) where
+  return a = mortal $ const $ left a
+  {-# INLINE return #-}
+  m >>= k = mortal $ \f -> lift (runEitherT $ runMortal m f) >>= \r -> case r of
+    Left a -> runMortal (k a) f
+    Right (x, m') -> return (x, m' >>= k)
+
+instance MonadTrans (Mortal f) where
+  lift m = mortal $ const $ EitherT $ liftM Left m
+  {-# INLINE lift #-}
+
+-- | Construct a mortal in a 'Object' construction manner.
+mortal :: Monad m => (forall x. f x -> EitherT a m (x, Mortal f m a)) -> Mortal f m a
+mortal f = unsafeCoerce f `asTypeOf` Mortal (Object (fmap (fmap unMortal) . f))
+{-# INLINE mortal #-}
+
+-- | Send a message to a mortal.
+runMortal :: Monad m => Mortal f m a -> f x -> EitherT a m (x, Mortal f m a)
+runMortal = unsafeCoerce `asTypeOf` ((fmap (fmap Mortal) . ) . runObject . unMortal)
+{-# INLINE runMortal #-}
+
+-- | Restricted 'Mortal' constuctor which can be applied to 'transit', 'fromFoldable' without ambiguousness.
+mortal_ :: Object f (EitherT () g) -> Mortal f g ()
+mortal_ = Mortal
+{-# INLINE mortal_ #-}
+
+-- | Turn an object into a mortal without death.
+immortal :: Monad m => Object f m -> Mortal f m x
+immortal obj = Mortal (obj @>>^ lift)
+{-# INLINE immortal #-}
+
+-- | Send a message to mortals through a filter.
+apprisesOf :: Monad m
+  => FilterLike' (WriterT r m) s (Mortal f m b)
+  -> f a -> (a -> r) -> (b -> r) -> StateT s m r
+apprisesOf l f p q = StateT $ \t -> liftM swap $ runWriterT $ flip l t
+    $ \obj -> WriterT $ runEitherT (runMortal obj f) >>= \case
+      Left r -> return (Nothing, q r)
+      Right (x, obj') -> return (Just obj', p x)
+{-# INLINABLE apprisesOf #-}
+
+-- | Send a message to mortals in a 'Witherable' container.
+--
+-- @apprises = apprisesOf wither@
+--
+apprises :: (Witherable t, Monad m, Applicative m, Monoid r) => f a -> (a -> r) -> (b -> r) -> StateT (t (Mortal f m b)) m r
+apprises = apprisesOf wither
+{-# INLINE apprises #-}
+
+-- | 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 = fmap (flip appEndo [] *** flip appEndo [])
+  $ apprises f (\a -> (Endo (a:), mempty)) (\b -> (mempty, Endo (b:)))
+{-# INLINE apprise #-}

src/Control/Object/Object.hs view

@@ -1,240 +1,240 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE Rank2Types, TupleSections, TypeOperators #-}-{-# LANGUAGE GADTs #-}-#if __GLASGOW_HASKELL__ >= 707-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE Safe #-}-#else-{-# LANGUAGE Trustworthy #-}-#endif--------------------------------------------------------------------------------- |--- Module      :  Control.Object.Object--- Copyright   :  (c) Fumiaki Kinoshita 2015--- License     :  BSD3------ Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>--- Stability   :  provisional--- Portability :  GADTs, Rank2Types----------------------------------------------------------------------------------module Control.Object.Object (Object(..)-  , echo-  , (@>>@)-  , (@<<@)-  , liftO-  , (^>>@)-  , (@>>^)-  , (@||@)-  -- * Stateful construction-  , unfoldO-  , unfoldOM-  , stateful-  , (@~)-  , variable-  -- * Method cascading-  , (@-)-  , iterObject-  , iterative-  , cascadeObject-  , cascading-  -- * Filtering-  , Fallible(..)-  , filteredO-  , filterO-  -- * Manipulation on StateT-  , invokesOf-  , invokes-  , (@!=)-  , announce-  , withBuilder-  ) where-import Data.Typeable-import Control.Monad.Trans.State.Strict-import Control.Monad.Free-import Control.Monad-import Control.Monad.Skeleton-import Data.Traversable as T-import Control.Monad.Trans.Writer.Strict-import Data.Monoid-import Data.Tuple (swap)-import qualified Data.Functor.Sum as Functor---- | The type @Object f g@ represents objects which can handle messages @f@, perform actions in the environment @g@.--- It can be thought of as an automaton that transforms effects.--- 'Object's can be composed just like functions using '@>>@'; the identity element is 'echo'.--- Objects are morphisms of the category of actions.------ [/Naturality/]---     @runObject obj . fmap f ≡ fmap f . runObject obj@----newtype Object f g = Object { runObject :: forall x. f x -> g (x, Object f g) }-#if __GLASGOW_HASKELL__ >= 707-  deriving (Typeable)-#else-instance (Typeable1 f, Typeable1 g) => Typeable (Object f g) where-  typeOf t = mkTyConApp objectTyCon [typeOf1 (f t), typeOf1 (g t)] where-    f :: Object f g -> f a-    f = undefined-    g :: Object f g -> g a-    g = undefined--objectTyCon :: TyCon-#if __GLASGOW_HASKELL__ < 704-objectTyCon = mkTyCon "Control.Object.Object"-#else-objectTyCon = mkTyCon3 "objective" "Control.Object" "Object"-#endif-{-# NOINLINE objectTyCon #-}-#endif---- | An infix alias for 'runObject'-(@-) :: Object f g -> f x -> g (x, Object f g)-(@-) = runObject-{-# INLINE (@-) #-}-infixr 3 @---infixr 1 ^>>@-infixr 1 @>>^--(^>>@) :: Functor h => (forall x. f x -> g x) -> Object g h -> Object f h-f ^>>@ m0 = go m0 where go (Object m) = Object $ fmap (fmap go) . m . f-{-# INLINE (^>>@) #-}--(@>>^) :: Functor h => Object f g -> (forall x. g x -> h x) -> Object f h-m0 @>>^ g = go m0 where go (Object m) = Object $ fmap (fmap go) . g . m-{-# INLINE (@>>^) #-}---- | The trivial object-echo :: Functor f => Object f f-echo = Object $ fmap (,echo)---- | Lift a natural transformation into an object.-liftO :: Functor g => (forall x. f x -> g x) -> Object f g-liftO f = go where go = Object $ fmap (\x -> (x, go)) . f-{-# INLINE liftO #-}---- | The categorical composition of objects.-(@>>@) :: Functor h => Object f g -> Object g h -> Object f h-Object m @>>@ Object n = Object $ fmap (\((x, m'), n') -> (x, m' @>>@ n')) . n . m-infixr 1 @>>@---- | Reversed '(@>>@)'-(@<<@) :: Functor h => Object g h -> Object f g -> Object f h-(@<<@) = flip (@>>@)-{-# INLINE (@<<@) #-}-infixl 1 @<<@---- | Combine objects so as to handle a 'Functor.Sum' of interfaces.-(@||@) :: Functor h => Object f h -> Object g h -> Object (f `Functor.Sum` g) h-a @||@ b = Object $ \r -> case r of-  Functor.InL f -> fmap (fmap (@||@b)) (runObject a f)-  Functor.InR g -> fmap (fmap (a@||@)) (runObject b g)---- | An unwrapped analog of 'stateful'---     @id = unfoldO runObject@---     @'iterative' = unfoldO 'iterObject'@---     @'cascading' = unfoldO 'cascadeObject'@-unfoldO :: Functor g => (forall a. r -> f a -> g (a, r)) -> r -> Object f g-unfoldO h = go where go r = Object $ fmap (fmap go) . h r-{-# INLINE unfoldO #-}---- | Same as 'unfoldO' but requires 'Monad' instead-unfoldOM :: Monad m => (forall a. r -> f a -> m (a, r)) -> r -> Object f m-unfoldOM h = go where go r = Object $ liftM (fmap go) . h r-{-# INLINE unfoldOM #-}---- | Build a stateful object.------ @stateful t s = t ^>>\@ variable s@----stateful :: Monad m => (forall a. t a -> StateT s m a) -> s -> Object t m-stateful h = go where-  go s = Object $ \f -> runStateT (h f) s >>= \(a, s') -> s' `seq` return (a, go s')-{-# INLINE stateful #-}---- | Flipped 'stateful'.--- it is super convenient to use with the LambdaCase extension.-(@~) :: Monad m => s -> (forall a. t a -> StateT s m a) -> Object t m-s @~ h = stateful h s-{-# INLINE (@~) #-}-infix 1 @~---- | Cascading-iterObject :: Monad m => Object f m -> Free f a -> m (a, Object f m)-iterObject obj (Pure a) = return (a, obj)-iterObject obj (Free f) = runObject obj f >>= \(cont, obj') -> iterObject obj' cont---- | Objects can consume free monads. 'cascading' is more preferred.-iterative :: Monad m => Object f m -> Object (Free f) m-iterative = unfoldOM iterObject-{-# INLINE iterative #-}---- | A mutable variable.------ @variable = stateful id@----variable :: Monad m => s -> Object (StateT s m) m-variable = stateful id-{-# INLINE variable #-}---- | Pass zero or more messages to an object.-cascadeObject :: Monad m => Object t m -> Skeleton t a -> m (a, Object t m)-cascadeObject obj sk = case unbone sk of-  Return a -> return (a, obj)-  t :>>= k -> runObject obj t >>= \(a, obj') -> cascadeObject obj' (k a)---- | Add capability to handle multiple messages at once.-cascading :: Monad m => Object t m -> Object (Skeleton t) m-cascading = unfoldOM cascadeObject-{-# INLINE cascading #-}---- | Send a message to an object through a lens.-invokesOf :: Monad m-  => ((Object t m -> WriterT r m (Object t m)) -> s -> WriterT r m s)-  -> t a -> (a -> r) -> StateT s m r-invokesOf t f c = StateT $ liftM swap . runWriterT-  . t (\obj -> WriterT $ runObject obj f >>= \(x, obj') -> return (obj', c x))-{-# INLINABLE invokesOf #-}--invokes :: (T.Traversable t, Monad m, Monoid r)-  => f a -> (a -> r) -> StateT (t (Object f m)) m r-invokes = invokesOf T.mapM-{-# INLINE invokes #-}---- | Send a message to objects in a traversable container.------ @announce = withBuilder . invokesOf traverse@----announce :: (T.Traversable t, Monad m) => f a -> StateT (t (Object f m)) m [a]-announce f = withBuilderM (invokes f)-{-# INLINABLE announce #-}---- | A method invocation operator on 'StateT'.-(@!=) :: Monad m-  => ((Object t m -> WriterT a m (Object t m)) -> s -> WriterT a m s)-  -> t a -> StateT s m a-l @!= f = invokesOf l f id-{-# INLINE (@!=) #-}--withBuilder :: Functor f => ((a -> Endo [a]) -> f (Endo [a])) -> f [a]-withBuilder f = fmap (flip appEndo []) (f (Endo . (:)))-{-# INLINABLE withBuilder #-}--withBuilderM :: Monad f => ((a -> Endo [a]) -> f (Endo [a])) -> f [a]-withBuilderM f = liftM (flip appEndo []) (f (Endo . (:)))-{-# INLINABLE withBuilderM #-}--data Fallible t a where-  Fallible :: t a -> Fallible t (Maybe a)--filteredO :: Monad m-       => (forall x. t x -> Bool)-       -> Object t m -> Object (Fallible t) m-filteredO p obj = Object $ \(Fallible t) -> if p t-  then runObject obj t >>= \(a, obj') -> return (Just a, filteredO p obj')-  else return (Nothing, filteredO p obj)--filterO :: (forall x. t x -> Bool) -> Object (Fallible t) (Skeleton t)-filterO p = filteredO p (liftO bone)-{-# INLINE filterO #-}+{-# LANGUAGE CPP #-}
+{-# LANGUAGE Rank2Types, TupleSections, TypeOperators #-}
+{-# LANGUAGE GADTs #-}
+#if __GLASGOW_HASKELL__ >= 707
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE Safe #-}
+#else
+{-# LANGUAGE Trustworthy #-}
+#endif
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Control.Object.Object
+-- Copyright   :  (c) Fumiaki Kinoshita 2015
+-- License     :  BSD3
+--
+-- Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>
+-- Stability   :  provisional
+-- Portability :  GADTs, Rank2Types
+--
+-----------------------------------------------------------------------------
+module Control.Object.Object (Object(..)
+  , echo
+  , (@>>@)
+  , (@<<@)
+  , liftO
+  , (^>>@)
+  , (@>>^)
+  , (@||@)
+  -- * Stateful construction
+  , unfoldO
+  , unfoldOM
+  , stateful
+  , (@~)
+  , variable
+  -- * Method cascading
+  , (@-)
+  , iterObject
+  , iterative
+  , cascadeObject
+  , cascading
+  -- * Filtering
+  , Fallible(..)
+  , filteredO
+  , filterO
+  -- * Manipulation on StateT
+  , invokesOf
+  , invokes
+  , (@!=)
+  , announce
+  , withBuilder
+  ) where
+import Data.Typeable
+import Control.Monad.Trans.State.Strict
+import Control.Monad.Free
+import Control.Monad
+import Control.Monad.Skeleton
+import Data.Traversable as T
+import Control.Monad.Trans.Writer.Strict
+import Data.Monoid
+import Data.Tuple (swap)
+import qualified Data.Functor.Sum as Functor
+
+-- | The type @Object f g@ represents objects which can handle messages @f@, perform actions in the environment @g@.
+-- It can be thought of as an automaton that transforms effects.
+-- 'Object's can be composed just like functions using '@>>@'; the identity element is 'echo'.
+-- Objects are morphisms of the category of actions.
+--
+-- [/Naturality/]
+--     @runObject obj . fmap f ≡ fmap f . runObject obj@
+--
+newtype Object f g = Object { runObject :: forall x. f x -> g (x, Object f g) }
+#if __GLASGOW_HASKELL__ >= 707
+  deriving (Typeable)
+#else
+instance (Typeable1 f, Typeable1 g) => Typeable (Object f g) where
+  typeOf t = mkTyConApp objectTyCon [typeOf1 (f t), typeOf1 (g t)] where
+    f :: Object f g -> f a
+    f = undefined
+    g :: Object f g -> g a
+    g = undefined
+
+objectTyCon :: TyCon
+#if __GLASGOW_HASKELL__ < 704
+objectTyCon = mkTyCon "Control.Object.Object"
+#else
+objectTyCon = mkTyCon3 "objective" "Control.Object" "Object"
+#endif
+{-# NOINLINE objectTyCon #-}
+#endif
+
+-- | An infix alias for 'runObject'
+(@-) :: Object f g -> f x -> g (x, Object f g)
+(@-) = runObject
+{-# INLINE (@-) #-}
+infixr 3 @-
+
+infixr 1 ^>>@
+infixr 1 @>>^
+
+(^>>@) :: Functor h => (forall x. f x -> g x) -> Object g h -> Object f h
+f ^>>@ m0 = go m0 where go (Object m) = Object $ fmap (fmap go) . m . f
+{-# INLINE (^>>@) #-}
+
+(@>>^) :: Functor h => Object f g -> (forall x. g x -> h x) -> Object f h
+m0 @>>^ g = go m0 where go (Object m) = Object $ fmap (fmap go) . g . m
+{-# INLINE (@>>^) #-}
+
+-- | The trivial object
+echo :: Functor f => Object f f
+echo = Object $ fmap (,echo)
+
+-- | Lift a natural transformation into an object.
+liftO :: Functor g => (forall x. f x -> g x) -> Object f g
+liftO f = go where go = Object $ fmap (\x -> (x, go)) . f
+{-# INLINE liftO #-}
+
+-- | The categorical composition of objects.
+(@>>@) :: Functor h => Object f g -> Object g h -> Object f h
+Object m @>>@ Object n = Object $ fmap (\((x, m'), n') -> (x, m' @>>@ n')) . n . m
+infixr 1 @>>@
+
+-- | Reversed '(@>>@)'
+(@<<@) :: Functor h => Object g h -> Object f g -> Object f h
+(@<<@) = flip (@>>@)
+{-# INLINE (@<<@) #-}
+infixl 1 @<<@
+
+-- | Combine objects so as to handle a 'Functor.Sum' of interfaces.
+(@||@) :: Functor h => Object f h -> Object g h -> Object (f `Functor.Sum` g) h
+a @||@ b = Object $ \r -> case r of
+  Functor.InL f -> fmap (fmap (@||@b)) (runObject a f)
+  Functor.InR g -> fmap (fmap (a@||@)) (runObject b g)
+
+-- | An unwrapped analog of 'stateful'
+--     @id = unfoldO runObject@
+--     @'iterative' = unfoldO 'iterObject'@
+--     @'cascading' = unfoldO 'cascadeObject'@
+unfoldO :: Functor g => (forall a. r -> f a -> g (a, r)) -> r -> Object f g
+unfoldO h = go where go r = Object $ fmap (fmap go) . h r
+{-# INLINE unfoldO #-}
+
+-- | Same as 'unfoldO' but requires 'Monad' instead
+unfoldOM :: Monad m => (forall a. r -> f a -> m (a, r)) -> r -> Object f m
+unfoldOM h = go where go r = Object $ liftM (fmap go) . h r
+{-# INLINE unfoldOM #-}
+
+-- | Build a stateful object.
+--
+-- @stateful t s = t ^>>\@ variable s@
+--
+stateful :: Monad m => (forall a. t a -> StateT s m a) -> s -> Object t m
+stateful h = go where
+  go s = Object $ \f -> runStateT (h f) s >>= \(a, s') -> s' `seq` return (a, go s')
+{-# INLINE stateful #-}
+
+-- | Flipped 'stateful'.
+-- it is super convenient to use with the LambdaCase extension.
+(@~) :: Monad m => s -> (forall a. t a -> StateT s m a) -> Object t m
+s @~ h = stateful h s
+{-# INLINE (@~) #-}
+infix 1 @~
+
+-- | Cascading
+iterObject :: Monad m => Object f m -> Free f a -> m (a, Object f m)
+iterObject obj (Pure a) = return (a, obj)
+iterObject obj (Free f) = runObject obj f >>= \(cont, obj') -> iterObject obj' cont
+
+-- | Objects can consume free monads. 'cascading' is more preferred.
+iterative :: Monad m => Object f m -> Object (Free f) m
+iterative = unfoldOM iterObject
+{-# INLINE iterative #-}
+
+-- | A mutable variable.
+--
+-- @variable = stateful id@
+--
+variable :: Monad m => s -> Object (StateT s m) m
+variable = stateful id
+{-# INLINE variable #-}
+
+-- | Pass zero or more messages to an object.
+cascadeObject :: Monad m => Object t m -> Skeleton t a -> m (a, Object t m)
+cascadeObject obj sk = case unbone sk of
+  Return a -> return (a, obj)
+  t :>>= k -> runObject obj t >>= \(a, obj') -> cascadeObject obj' (k a)
+
+-- | Add capability to handle multiple messages at once.
+cascading :: Monad m => Object t m -> Object (Skeleton t) m
+cascading = unfoldOM cascadeObject
+{-# INLINE cascading #-}
+
+-- | Send a message to an object through a lens.
+invokesOf :: Monad m
+  => ((Object t m -> WriterT r m (Object t m)) -> s -> WriterT r m s)
+  -> t a -> (a -> r) -> StateT s m r
+invokesOf t f c = StateT $ liftM swap . runWriterT
+  . t (\obj -> WriterT $ runObject obj f >>= \(x, obj') -> return (obj', c x))
+{-# INLINABLE invokesOf #-}
+
+invokes :: (T.Traversable t, Monad m, Monoid r)
+  => f a -> (a -> r) -> StateT (t (Object f m)) m r
+invokes = invokesOf T.mapM
+{-# INLINE invokes #-}
+
+-- | Send a message to objects in a traversable container.
+--
+-- @announce = withBuilder . invokesOf traverse@
+--
+announce :: (T.Traversable t, Monad m) => f a -> StateT (t (Object f m)) m [a]
+announce f = withBuilderM (invokes f)
+{-# INLINABLE announce #-}
+
+-- | A method invocation operator on 'StateT'.
+(@!=) :: Monad m
+  => ((Object t m -> WriterT a m (Object t m)) -> s -> WriterT a m s)
+  -> t a -> StateT s m a
+l @!= f = invokesOf l f id
+{-# INLINE (@!=) #-}
+
+withBuilder :: Functor f => ((a -> Endo [a]) -> f (Endo [a])) -> f [a]
+withBuilder f = fmap (flip appEndo []) (f (Endo . (:)))
+{-# INLINABLE withBuilder #-}
+
+withBuilderM :: Monad f => ((a -> Endo [a]) -> f (Endo [a])) -> f [a]
+withBuilderM f = liftM (flip appEndo []) (f (Endo . (:)))
+{-# INLINABLE withBuilderM #-}
+
+data Fallible t a where
+  Fallible :: t a -> Fallible t (Maybe a)
+
+filteredO :: Monad m
+       => (forall x. t x -> Bool)
+       -> Object t m -> Object (Fallible t) m
+filteredO p obj = Object $ \(Fallible t) -> if p t
+  then runObject obj t >>= \(a, obj') -> return (Just a, filteredO p obj')
+  else return (Nothing, filteredO p obj)
+
+filterO :: (forall x. t x -> Bool) -> Object (Fallible t) (Skeleton t)
+filterO p = filteredO p (liftO bone)
+{-# INLINE filterO #-}

src/Data/Functor/Request.hs view

@@ -1,93 +1,93 @@-{-# LANGUAGE CPP, DeriveFunctor, DeriveDataTypeable, ConstraintKinds, FlexibleContexts, TypeOperators, DataKinds, TypeFamilies #-}--------------------------------------------------------------------------------- |--- Module      :  Data.Functor.Request--- Copyright   :  (c) Fumiaki Kinoshita 2015--- License     :  BSD3------ Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>--- Stability   :  experimental--- Portability :  non-portable----------------------------------------------------------------------------------module Data.Functor.Request where-import Data.Typeable-#if !MIN_VERSION_base(4,8,0)-import Data.Monoid-#endif-import Control.Applicative-import Data.Profunctor-import Control.Object.Object-import qualified Data.HashMap.Strict as HM-import Data.Hashable-import Control.Arrow---- | @'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)---- | Apply a function to the body of 'Request'-mapRequest :: (a -> a') -> Request a b r -> Request a' b r-mapRequest f (Request a br) = Request (f a) br-{-# INLINE mapRequest #-}--instance Profunctor (Request a) where-  dimap f g (Request a br) = Request a (dimap f g br)-  {-# INLINE dimap #-}--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 (<*>) #-}---- | Create a 'Request'.-request :: a -> Request a b b-request a = Request a id-{-# INLINE request #-}---- | Handle a 'Request', smashing the continuation.-accept :: Functor m => (a -> m b) -> Request a b r -> m r-accept f = \(Request a cont) -> cont <$> f a-{-# INLINE accept #-}---- | Add a step as a mealy machine-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 #-}---- | The flyweight object-flyweight :: (Applicative m, Eq k, Hashable k) => (k -> m a) -> Object (Request k a) m-flyweight f = go HM.empty where-  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 #-}---- | Compose mealy machines-(>~~>) :: 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 #-}---- | Create a mealy machine from a time-varying action.------ @ 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 = mealy $ \dt -> flip (,) (go (t + dt)) <$> f t-{-# INLINE animate #-}---- | Like 'animate', but the life is limited.-transit :: (Alternative m, Fractional t, Ord t) => t -> (t -> m a) -> Object (Request t a) m-transit len f = animate go where-  go t-    | t >= len = empty-    | otherwise = f (t / len)-{-# INLINE transit #-}+{-# LANGUAGE CPP, DeriveFunctor, DeriveDataTypeable, ConstraintKinds, FlexibleContexts, TypeOperators, DataKinds, TypeFamilies #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Functor.Request
+-- Copyright   :  (c) Fumiaki Kinoshita 2015
+-- License     :  BSD3
+--
+-- Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>
+-- Stability   :  experimental
+-- Portability :  non-portable
+--
+-----------------------------------------------------------------------------
+module Data.Functor.Request where
+import Data.Typeable
+#if !MIN_VERSION_base(4,8,0)
+import Data.Monoid
+#endif
+import Control.Applicative
+import Data.Profunctor
+import Control.Object.Object
+import qualified Data.HashMap.Strict as HM
+import Data.Hashable
+import Control.Arrow
+
+-- | @'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)
+
+-- | Apply a function to the body of 'Request'
+mapRequest :: (a -> a') -> Request a b r -> Request a' b r
+mapRequest f (Request a br) = Request (f a) br
+{-# INLINE mapRequest #-}
+
+instance Profunctor (Request a) where
+  dimap f g (Request a br) = Request a (dimap f g br)
+  {-# INLINE dimap #-}
+
+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 (<*>) #-}
+
+-- | Create a 'Request'.
+request :: a -> Request a b b
+request a = Request a id
+{-# INLINE request #-}
+
+-- | Handle a 'Request', smashing the continuation.
+accept :: Functor m => (a -> m b) -> Request a b r -> m r
+accept f = \(Request a cont) -> cont <$> f a
+{-# INLINE accept #-}
+
+-- | Add a step as a mealy machine
+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 #-}
+
+-- | The flyweight object
+flyweight :: (Applicative m, Eq k, Hashable k) => (k -> m a) -> Object (Request k a) m
+flyweight f = go HM.empty where
+  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 #-}
+
+-- | Compose mealy machines
+(>~~>) :: 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 #-}
+
+-- | Create a mealy machine from a time-varying action.
+--
+-- @ 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 = mealy $ \dt -> flip (,) (go (t + dt)) <$> f t
+{-# INLINE animate #-}
+
+-- | Like 'animate', but the life is limited.
+transit :: (Alternative m, Fractional t, Ord t) => t -> (t -> m a) -> Object (Request t a) m
+transit len f = animate go where
+  go t
+    | t >= len = empty
+    | otherwise = f (t / len)
+{-# INLINE transit #-}