packages feed

objective 1.0.5 → 1.3

raw patch · 11 files changed

Files

− .travis.yml 
@@ -1,56 +0,0 @@-# 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,3 +1,27 @@+1.3+----+* Supported GHC 9.0+* Removed `unfoldOM`+* Removed `apprisesOf`+* Removed `withBuilder`+* Trimmed unnecessary dependencies++1.2+----++* Removed `iterObject` and `iterative`+* Removed `Data.Functor.Request`++1.1.2+----++* Removed `either` dependency++1.1+----+* Removed `HProfunctor`, `(..-)`, `invokeOnSTM`, `newSTM`, `snapshot`+* Added `(?-)`+ 1.0.5 ---- * Added `filterO` and `filteredO`
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.
+ README.md view
@@ -0,0 +1,46 @@+objective+====++[![Hackage](https://img.shields.io/hackage/v/objective.svg)](https://hackage.haskell.org/package/objective) [![Build Status](https://secure.travis-ci.org/fumieval/objective.png?branch=master)](http://travis-ci.org/fumieval/objective)++Paper: https://fumieval.github.io/papers/en/2015-Haskell-objects.html++This package provides composable objects and instances.++Introduction+----++The primal construct, `Object`, models _object-oriented_ objects. `Object f g` represents an object.++```haskell+newtype Object f g = Object { runObject :: forall x. f x -> g (x, Object f g) }+```++An object interprets a message `f a` and returns the result `a` and the next object `Object f g`, on `g`.++```haskell+data Counter a where+  Increment :: Counter ()+  Print :: Counter Int++counter :: Int -> Object Counter IO+counter n = Object $ \case+  Increment -> return ((), counter (n + 1))+  Print -> print n >> return (n, counter n)+```++`new :: Object f g -> IO (Instance f g)` creates an instance of an object.++`(.-) :: (MonadIO m, MonadMask m) => Instance f m -> f a -> m a` sends a message to an instance. This can be used to handle instances in the typical OOP fashion.++```haskell+> i <- new (counter 0)+> i .- Increment+> i .- Print+1+> i .- Increment+> i .- Print+2+```++Interestingly, `Object (Skeleton t) m` and `Object t m` are isomorphic (`Skeleton` is an operational monad). `cascading` lets objects to handle an operational monad.
Setup.hs view
@@ -1,2 +1,2 @@-import Distribution.Simple
-main = defaultMain
+import Distribution.Simple+main = defaultMain
objective.cabal view
@@ -1,20 +1,20 @@+cabal-version:       2.4 name:                objective-version:             1.0.5+version:             1.3 synopsis:            Composable objects description:         Composable objects homepage:            https://github.com/fumieval/objective bug-reports:         http://github.com/fumieval/objective/issues-license:             BSD3+license:             BSD-3-Clause license-file:        LICENSE author:              Fumiaki Kinoshita maintainer:          Fumiaki Kinoshita <fumiexcel@gmail.com>-copyright:           Copyright (c) 2014 Fumiaki Kinoshita+copyright:           Copyright (c) 2014-2021 Fumiaki Kinoshita category:            Control build-type:          Simple extra-source-files:   CHANGELOG.md-  .travis.yml-cabal-version:       >=1.10+  README.md  source-repository head   type: git@@ -26,25 +26,12 @@       , 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+  build-depends:       base >=4.9 && <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-    , stm-    , monad-stm+    , witherable ^>= 0.4     , monad-skeleton >= 0.1.1 && <0.3-    , template-haskell-  ghc-options: -Wall+  ghc-options: -Wall -Wcompat   hs-source-dirs:      src   default-language:    Haskell2010
src/Control/Object.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE Safe #-} ----------------------------------------------------------------------------- -- | -- Module      :  Control.Object
src/Control/Object/Instance.hs view
@@ -1,5 +1,4 @@-{-# LANGUAGE Safe #-}-{-# LANGUAGE GADTs, Rank2Types #-}+{-# LANGUAGE GADTs, Rank2Types, LambdaCase #-} ----------------------------------------------------------------------------- -- | -- Module      :  Control.Object.Instance@@ -13,61 +12,40 @@ ----------------------------------------------------------------------------- module Control.Object.Instance (   -- * Instantiation-  Instance(..)+  Instance   , new   , newSettle-  , newSTM   -- * Invocation+  , invokeOnUsing   , invokeOn-  , invokeOnSTM   , (.-)   , (..-)-  , snapshot+  , (?-)   ) where-import Control.Concurrent.STM.TMVar-import Control.Monad.STM+import Control.Concurrent+import Control.Exception (evaluate) import Control.Object.Object import Control.Monad.IO.Class-import Control.Monad.STM.Class-import Control.Monad-import Control.Monad.Catch (MonadMask, bracketOnError)+import Control.Monad.Catch+import Control.Monad.Skeleton --- | TMVar-based instance-data Instance f g where-  InstRef :: (forall x. e x -> f x) -> (forall x. g x -> h x) -> TMVar (Object f g) -> Instance e h+type Instance f g = MVar (Object f g) -instance HProfunctor Instance where-  f ^>>@ InstRef l r v = InstRef (l . f) r v-  {-# INLINE (^>>@) #-}-  InstRef l r v @>>^ f = InstRef l (f . r) v-  {-# INLINE (@>>^) #-}+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 m (InstRef t l v) f = bracketOnError-  (liftIO $ atomically $ takeTMVar v)-  (\obj -> liftIO $ atomically $ do-    _ <- tryTakeTMVar v-    putTMVar v obj)-  (\obj -> do-    (a, obj') <- m $ l $ runObject obj (t f)-    liftIO $ atomically $ putTMVar v obj'-    return a)---- | Invoke a method with an explicit landing function.-invokeOnSTM :: (forall x. g x -> STM x) -> Instance f g -> f a -> STM a-invokeOnSTM m (InstRef t l v) f = do-  obj <- takeTMVar v-  (a, obj') <- m $ l $ runObject obj (t f)-  putTMVar v obj'-  return a---- | Invoke a method, atomically.-(..-) :: MonadSTM m => Instance f STM -> f a -> m a-(..-) i = liftSTM . invokeOnSTM id i-{-# INLINE (..-) #-}-infixr 3 ..-+invokeOn = invokeOnUsing (\o f -> runObject o f)+{-# INLINE invokeOn #-}  -- | Invoke a method. (.-) :: (MonadIO m, MonadMask m) => Instance f m -> f a -> m a@@ -75,22 +53,27 @@ {-# INLINE (.-) #-} infixr 3 .- --- | Take a snapshot of an instance.-snapshot :: (MonadSTM m, Functor g) => Instance f g -> m (Object f g)-snapshot (InstRef f g v) = liftSTM $ go `fmap` readTMVar v-  where go (Object m) = Object $ fmap (fmap go) . g . m . f+(..-) :: (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 . liftM (InstRef id id) . newTMVarIO+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 #-}---- | Create a new instance.-newSTM :: MonadSTM m => Object f g -> m (Instance f g)-newSTM = liftSTM . liftM (InstRef id id) . newTMVar-{-# INLINE newSTM #-}
src/Control/Object/Mortal.hs view
@@ -1,5 +1,4 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE Safe #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE BangPatterns #-}@@ -20,25 +19,20 @@     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.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 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.@@ -47,41 +41,39 @@ -- -- @Object f g ≡ Mortal f g Void@ ---newtype Mortal f g a = Mortal { unMortal :: Object f (EitherT a g) }+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 @>>^ bimapEitherT f id)+instance 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+instance Monad m => Applicative (Mortal f m) where+  pure a = mortal $ const $ throwE a   {-# 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+  m >>= k = mortal $ \f -> lift (runExceptT $ runMortal m f) >>= \case     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+  lift m = mortal $ const $ ExceptT $ fmap 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))+mortal :: Monad m => (forall x. f x -> ExceptT a m (x, Mortal f m a)) -> Mortal f m a+mortal f = 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)+runMortal :: Monad m => Mortal f m a -> f x -> ExceptT a m (x, Mortal f m a)+runMortal m f = fmap Mortal <$> runObject (unMortal m) f {-# INLINE runMortal #-} --- | Restricted 'Mortal' constuctor which can be applied to 'transit', 'fromFoldable' without ambiguousness.-mortal_ :: Object f (EitherT () g) -> Mortal f g ()+-- | A smart constructor of 'Mortal' where the result type is restricted to ()+mortal_ :: Object f (ExceptT () g) -> Mortal f g () mortal_ = Mortal {-# INLINE mortal_ #-} @@ -90,26 +82,16 @@ 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+apprises :: (Witherable t, Monad m, Monoid r) => f a -> (a -> r) -> (b -> r) -> StateT (t (Mortal f m b)) m r+apprises f p q = StateT $ \t -> fmap swap $ runWriterT $ flip wither t+  $ \obj -> WriterT $ runExceptT (runMortal obj f) >>= \case+    Left r -> return (Nothing, q r)+    Right (x, obj') -> return (Just obj', p x) {-# 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:)))+apprise :: (Witherable t, Monad m) => f a -> StateT (t (Mortal f m r)) m ([a], [r])+apprise f = bimap (`appEndo` []) (`appEndo` [])+  <$> apprises f (\a -> (Endo (a:), mempty)) (\b -> (mempty, Endo (b:))) {-# INLINE apprise #-}
src/Control/Object/Object.hs view
@@ -1,12 +1,7 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE Rank2Types, TupleSections, TypeOperators #-}+{-# LANGUAGE RankNTypes, TupleSections, TypeOperators #-} {-# LANGUAGE GADTs #-}-#if __GLASGOW_HASKELL__ >= 707-{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE Safe #-}-#else-{-# LANGUAGE Trustworthy #-}-#endif ----------------------------------------------------------------------------- -- | -- Module      :  Control.Object.Object@@ -23,18 +18,16 @@   , (@>>@)   , (@<<@)   , liftO-  , HProfunctor(..)+  , (^>>@)+  , (@>>^)   , (@||@)   -- * Stateful construction   , unfoldO-  , unfoldOM   , stateful   , (@~)   , variable   -- * Method cascading   , (@-)-  , iterObject-  , iterative   , cascadeObject   , cascading   -- * Filtering@@ -46,14 +39,9 @@   , 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)@@ -68,44 +56,23 @@ --     @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+a @- b = runObject a b {-# INLINE (@-) #-} infixr 3 @-  infixr 1 ^>>@ infixr 1 @>>^ --- | Higher-order profunctors-class HProfunctor k where-  (^>>@) :: Functor h => (forall x. f x -> g x) -> k g h -> k f h-  (@>>^) :: Functor h => k f g -> (forall x. g x -> h x) -> k f h+(^>>@) :: 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 (^>>@) #-} -instance HProfunctor Object where-  m0 @>>^ g = go m0 where go (Object m) = Object $ fmap (fmap go) . g . m-  {-# INLINE (@>>^) #-}-  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@@ -129,7 +96,7 @@  -- | 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+a @||@ b = Object $ \case   Functor.InL f -> fmap (fmap (@||@b)) (runObject a f)   Functor.InR g -> fmap (fmap (a@||@)) (runObject b g) @@ -141,11 +108,6 @@ 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@@@ -162,16 +124,6 @@ {-# 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@@@ -182,34 +134,31 @@  -- | 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+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+cascading = unfoldO 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+invokesOf t f c = StateT $ fmap swap . runWriterT   . t (\obj -> WriterT $ runObject obj f >>= \(x, obj') -> return (obj', c x)) {-# INLINABLE invokesOf #-} -invokes :: (T.Traversable t, Monad m, Monoid r)+invokes :: (Traversable t, Monad m, Monoid r)   => f a -> (a -> r) -> StateT (t (Object f m)) m r-invokes = invokesOf T.mapM+invokes = invokesOf traverse {-# 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)+announce :: (Traversable t, Monad m) => f a -> StateT (t (Object f m)) m [a]+announce f = withListBuilder (invokes f) {-# INLINABLE announce #-}  -- | A method invocation operator on 'StateT'.@@ -219,13 +168,9 @@ 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 #-}+withListBuilder :: Functor f => ((a -> Endo [a]) -> f (Endo [a])) -> f [a]+withListBuilder f = fmap (flip appEndo []) (f (Endo . (:)))+{-# INLINABLE withListBuilder #-}  data Fallible t a where   Fallible :: t a -> Fallible t (Maybe a)
− src/Data/Functor/Request.hs 
@@ -1,94 +0,0 @@-{-# LANGUAGE Safe #-}-{-# 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 #-}