objective 1.1.1 → 1.1.2

raw patch · 10 files changed

+801/−796 lines, 10 filesdep −eitherdep ~freesetup-changed

Dependencies removed: either

Dependency ranges changed: free

Files

.travis.yml +56/−56
CHANGELOG.md +119/−114
LICENSE +30/−30
Setup.hs +2/−2
objective.cabal +47/−48
src/Control/Object.hs +19/−19
src/Control/Object/Instance.hs +79/−79
src/Control/Object/Mortal.hs +116/−115
src/Control/Object/Object.hs +240/−240
src/Data/Functor/Request.hs +93/−93

.travis.yml view

@@ -1,56 +1,56 @@-# NB: don't set `language: haskell` here
-
-# See also https://github.com/hvr/multi-ghc-travis for more information
-
-# The following lines enable several GHC versions and/or HP versions
-# to be tested; often it's enough to test only against the last
-# release of a major GHC version. Setting HPVER implictly sets
-# GHCVER. Omit lines with versions you don't need/want testing for.
-env:
- - CABALVER=1.18 GHCVER=7.6.3
- - CABALVER=1.18 GHCVER=7.8.4
- - CABALVER=1.22 GHCVER=7.10.1
-
-# Note: the distinction between `before_install` and `install` is not
-#       important.
-before_install:
- - travis_retry sudo add-apt-repository -y ppa:hvr/ghc
- - travis_retry sudo apt-get update
- - travis_retry sudo apt-get install cabal-install-$CABALVER ghc-$GHCVER
- - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH
-
-install:
- - cabal --version
- - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]"
- - travis_retry cabal update
- - cabal install --only-dependencies --enable-tests --enable-benchmarks
-
-# Here starts the actual work to be performed for the package under
-# test; any command which exits with a non-zero exit code causes the
-# build to fail.
-script:
- - if [ -f configure.ac ]; then autoreconf -i; fi
- # -v2 provides useful information for debugging
- - cabal configure --enable-tests --enable-benchmarks -v2
-
- # this builds all libraries and executables
- # (including tests/benchmarks)
- - cabal build
-
- - cabal test
- - cabal check
-
- # tests that a source-distribution can be generated
- - cabal sdist
-
- # check that the generated source-distribution can be built & installed
- - export SRC_TGZ=$(cabal info . | awk '{print $2 ".tar.gz";exit}') ;
-   cd dist/;
-   if [ -f "$SRC_TGZ" ]; then
-      cabal install --force-reinstalls "$SRC_TGZ";
-   else
-      echo "expected '$SRC_TGZ' not found";
-      exit 1;
-   fi
-
-# EOF
+# NB: don't set `language: haskell` here++# See also https://github.com/hvr/multi-ghc-travis for more information++# The following lines enable several GHC versions and/or HP versions+# to be tested; often it's enough to test only against the last+# release of a major GHC version. Setting HPVER implictly sets+# GHCVER. Omit lines with versions you don't need/want testing for.+env:+ - CABALVER=1.18 GHCVER=7.6.3+ - CABALVER=1.18 GHCVER=7.8.4+ - CABALVER=1.22 GHCVER=7.10.1++# Note: the distinction between `before_install` and `install` is not+#       important.+before_install:+ - travis_retry sudo add-apt-repository -y ppa:hvr/ghc+ - travis_retry sudo apt-get update+ - travis_retry sudo apt-get install cabal-install-$CABALVER ghc-$GHCVER+ - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH++install:+ - cabal --version+ - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]"+ - travis_retry cabal update+ - cabal install --only-dependencies --enable-tests --enable-benchmarks++# Here starts the actual work to be performed for the package under+# test; any command which exits with a non-zero exit code causes the+# build to fail.+script:+ - if [ -f configure.ac ]; then autoreconf -i; fi+ # -v2 provides useful information for debugging+ - cabal configure --enable-tests --enable-benchmarks -v2++ # this builds all libraries and executables+ # (including tests/benchmarks)+ - cabal build++ - cabal test+ - cabal check++ # tests that a source-distribution can be generated+ - cabal sdist++ # check that the generated source-distribution can be built & installed+ - export SRC_TGZ=$(cabal info . | awk '{print $2 ".tar.gz";exit}') ;+   cd dist/;+   if [ -f "$SRC_TGZ" ]; then+      cabal install --force-reinstalls "$SRC_TGZ";+   else+      echo "expected '$SRC_TGZ' not found";+      exit 1;+   fi++# EOF

CHANGELOG.md view

@@ -1,114 +1,119 @@-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.2+----++* Removed `either` dependency++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

LICENSE view

@@ -1,30 +1,30 @@-Copyright (c) 2014, Fumiaki Kinoshita
-
-All rights reserved.
-
-Redistribution and use in source and binary forms, with or without
-modification, are permitted provided that the following conditions are met:
-
-    * Redistributions of source code must retain the above copyright
-      notice, this list of conditions and the following disclaimer.
-
-    * Redistributions in binary form must reproduce the above
-      copyright notice, this list of conditions and the following
-      disclaimer in the documentation and/or other materials provided
-      with the distribution.
-
-    * Neither the name of Fumiaki Kinoshita nor the names of other
-      contributors may be used to endorse or promote products derived
-      from this software without specific prior written permission.
-
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+Copyright (c) 2014, Fumiaki Kinoshita++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Fumiaki Kinoshita nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

Setup.hs view

@@ -1,2 +1,2 @@-import Distribution.Simple
-main = defaultMain
+import Distribution.Simple+main = defaultMain

objective.cabal view

@@ -1,48 +1,47 @@-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
+name:                objective+version:             1.1.2+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+    , 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,79 +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
-  , 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 #-}
+{-# 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) -> Instance 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) -> Instance f g -> f a -> m a+invokeOn = invokeOnUsing runObject+{-# INLINE invokeOn #-}++-- | Invoke a method.+(.-) :: (MonadIO m, MonadMask m) => Instance f m -> f a -> m a+(.-) = invokeOn id+{-# INLINE (.-) #-}+infixr 3 .-++(..-) :: (MonadIO m, MonadMask m)+    => Instance 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) => Instance 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,116 @@-{-# 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.Except+import Control.Monad+import Control.Monad.Trans.Class+import Control.Monad.Trans.State.Strict+import Control.Monad.Trans.Writer.Strict+import Data.Bifunctor+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 (ExceptT a g) }++instance (Functor m, Monad m) => Functor (Mortal f m) where+  fmap f (Mortal obj) = Mortal (obj @>>^ mapExceptT (fmap (first f)))+  {-# 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 $ throwE a+  {-# INLINE return #-}+  m >>= k = mortal $ \f -> lift (runExceptT $ 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 $ ExceptT $ liftM Left m+  {-# INLINE lift #-}++-- | Construct a mortal in a 'Object' construction manner.+mortal :: Monad m => (forall x. f x -> ExceptT 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 -> ExceptT 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 (ExceptT () 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 $ runExceptT (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 debone 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 #-}