packages feed

objective 0.6.5.1 → 1

raw patch · 16 files changed

+154/−637 lines, 16 filesdep −adjunctionsdep −comonaddep −elevatordep ~witherable

Dependencies removed: adjunctions, comonad, elevator, extensible, kan-extensions, minioperational

Dependency ranges changed: witherable

Files

.travis.yml view
@@ -1,10 +1,11 @@ language: haskell
 
 env:
-  - GHCVER=7.8.3
+  - GHCVER=7.6.3
+  - GHCVER=7.8.4
 
 before_install:
   - sudo add-apt-repository -y ppa:hvr/ghc
   - sudo apt-get update
   - sudo apt-get install -y -qq cabal-install-1.20 ghc-$GHCVER
-  - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/1.20/bin:$PATH+  - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/1.20/bin:$PATH
CHANGELOG.md view
@@ -1,8 +1,3 @@-0.6.5.1------* Added `MonadTrans` instance for `Mortal`.-* Added `newSettle`.- 0.6.5 ---- * Supported `elevator >= 0.2`.
objective.cabal view
@@ -1,5 +1,5 @@ name:                objective-version:             0.6.5.1+version:             1 synopsis:            Extensible objects description:         Stateful effect transducer homepage:            https://github.com/fumieval/objective@@ -19,33 +19,20 @@   exposed-modules:     Control.Object       , Control.Object.Object+      , Control.Object.Instance       , Control.Object.Mortal-      , Control.Object.Process-      , Control.Object.Extra-      , Control.Object.Stream-      , Control.Monad.Objective-      , Control.Monad.Objective.Class-      , Control.Monad.Objective.IO-      , Control.Monad.Objective.ST       , Data.Functor.Request-      , Data.Functor.PushPull   -- other-modules:   other-extensions:    MultiParamTypeClasses, KindSignatures, TypeFamilies   build-depends:       base >=4.5 && <5-    , comonad-    , elevator >= 0.2 && <0.3-    , extensible >= 0.2.9 && <0.3     , containers-    , minioperational >= 0.4 && <0.5-    , profunctors >= 4.0 && <5-    , witherable <= 0.2     , free >= 4.4 && <5-    , kan-extensions >= 4.1 && <5     , unordered-containers     , hashable >= 1.2 && <1.4+    , profunctors >= 4.0 && <5     , either     , void-    , adjunctions >= 4.0 && <5+    , witherable     , transformers >= 0.3 && <0.5   ghc-options: -Wall   hs-source-dirs:      src
− src/Control/Monad/Objective.hs 
@@ -1,7 +0,0 @@-module Control.Monad.Objective (module Control.Monad.Objective.Class-  , module Control.Monad.Objective.IO-  , module Control.Monad.Objective.ST) where--import Control.Monad.Objective.Class-import Control.Monad.Objective.IO-import Control.Monad.Objective.ST
− src/Control/Monad/Objective/Class.hs 
@@ -1,81 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE CPP #-}--------------------------------------------------------------------------------- |--- Module      :  Control.Monad.Objective.IO--- Copyright   :  (c) Fumiaki Kinoshita 2014--- License     :  BSD3------ Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>--- Stability   :  experimental--- Portability :  non-portable------ 'MonadObjective' class and operations----------------------------------------------------------------------------------module Control.Monad.Objective.Class where-import Control.Object.Object-import Control.Elevator-import Control.Monad.Trans.State.Strict-import Control.Monad.Operational.Mini-import Data.Functor.Identity-import Control.Monad--type Inst' f g = Inst g f g--class Monad b => ObjectiveBase b where-  data Inst b (f :: * -> *) (g :: * -> *)-  type InstOf b o :: *-  type InstOf b (Object f g) = Inst b f g-  new :: Object f g -> b (Inst b f g)-  new = new-  invoke :: Monad m => (forall x. b x -> m x) -> (forall x. g x -> m x) -> Inst b f g -> f a -> m a--newSettle :: ObjectiveBase g => Object f g -> g (Inst g f g)-newSettle = new--type MonadObjective b m = (ObjectiveBase b, Elevate b m, Monad m)--(.->) :: (Monad m, ObjectiveBase m) => Inst m f m -> f a -> m a-(.->) = invoke id id-{-# INLINE (.->) #-}--(.-) :: (MonadObjective b m, Elevate g m) => Inst b f g -> f a -> m a-(.-) = invoke elevate elevate-{-# INLINE (.-) #-}--infixr 3 .----- | Invoke a method.-(.^) :: (MonadObjective b m, Elevate g m, Elevate e f) => Inst b f g -> e a -> m a-i .^ e = i .- elevate e-{-# INLINE (.^) #-}-infixr 3 .^---- | (.^) for StateT-(.&) :: (MonadObjective b m, Elevate g m, Elevate (State s) f) => Inst b f g -> StateT s m a -> m a-i .& m = do-  s <- i .^ StateT (\s -> Identity (s, s))-  (a, s') <- runStateT m s-  i .^ StateT (\_ -> Identity (a, s'))--infixr 3 .&--(.!) :: (MonadObjective b m, Elevate g m) => Inst b f g -> Program f a -> m a-(.!) i = interpret (i.-)-{-# INLINE (.!) #-}--infixr 3 .!---- | We can convert method invocation into an object trivially.--- @invocation i = liftO (i.-)@-invocation :: (MonadObjective b m, Elevate g m) => Inst b f g -> Object f m-invocation i = Object $ liftM (\a -> (a, invocation i)). (i.-)-{-# INLINE invocation #-}
− src/Control/Monad/Objective/IO.hs 
@@ -1,34 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, FlexibleInstances #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--------------------------------------------------------------------------------- |--- Module      :  Control.Monad.Objective.IO--- Copyright   :  (c) Fumiaki Kinoshita 2014--- License     :  BSD3------ Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>--- Stability   :  experimental--- Portability :  non-portable------ 'MonadObjective' 'IO' using MVar----------------------------------------------------------------------------------module Control.Monad.Objective.IO  where-import Control.Monad.Objective.Class-import Control.Concurrent-import Control.Object.Object-import Control.Monad.IO.Class--instance ObjectiveBase IO where-  data Inst IO f g = InstIO (MVar (Object f g))--  invoke mr gr (InstIO m) e = do-    c <- mr (takeMVar m)-    (a, c') <- gr (runObject c e)-    mr (putMVar m c')-    return a--  new v = InstIO `fmap` newMVar v--newIO :: MonadIO m => Object f g -> m (Inst IO f g)-newIO = liftIO . new
− src/Control/Monad/Objective/ST.hs 
@@ -1,36 +0,0 @@-{-# LANGUAGE TypeFamilies, ConstraintKinds, FlexibleContexts #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}---------------------------------------------------------------------------------- |--- Module      :  Control.Monad.Objective.ST--- Copyright   :  (c) Corbin Simpson, Google Inc. 2014--- License     :  BSD3------ Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>--- Stability   :  experimental--- Portability :  non-portable (ST)------ 'MonadObjective' 'ST' using 'STRef'----------------------------------------------------------------------------------module Control.Monad.Objective.ST where--import Control.Monad.Objective.Class-import Control.Monad.ST-import Control.Object.Object-import Data.STRef-import Control.Elevator--instance ObjectiveBase (ST s) where-  data Inst (ST s) f g = InstST (STRef s (Object f g))--  invoke mr gr (InstST ref) e = do-    o <- mr (readSTRef ref)-    (a, o') <- gr (runObject o e)-    mr (writeSTRef ref o')-    return a-  new o = InstST `fmap` newSTRef o--newST :: Elevate (ST s) m => Object f g -> m (Inst (ST s) f g)-newST = elevate . new
src/Control/Object.hs view
@@ -4,7 +4,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Control.Object--- Copyright   :  (c) Fumiaki Kinoshita 2014+-- Copyright   :  (c) Fumiaki Kinoshita 2015 -- License     :  BSD3 -- -- Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>@@ -16,18 +16,12 @@ ----------------------------------------------------------------------------- module Control.Object   ( module Control.Object.Object,-    module Control.Object.Stream,     module Control.Object.Mortal,-    module Control.Object.Process,-    module Control.Object.Extra,+    module Control.Object.Instance,     module Data.Functor.Request,-    module Data.Functor.PushPull   ) where  import Control.Object.Object-import Control.Object.Stream import Control.Object.Mortal-import Control.Object.Process-import Control.Object.Extra+import Control.Object.Instance import Data.Functor.Request-import Data.Functor.PushPull
− src/Control/Object/Extra.hs 
@@ -1,104 +0,0 @@-{-# LANGUAGE Rank2Types, TypeOperators, FlexibleContexts, ConstraintKinds #-}-module Control.Object.Extra where-import Control.Object.Object-import qualified Data.HashMap.Strict as HM-import qualified Data.Map.Strict as Map-import Data.Witherable-import Control.Monad.Trans.Maybe-import Control.Monad.Trans.Writer.Strict-import Control.Monad.Trans.State.Strict-import Control.Monad.Trans.Class-import Control.Monad-import Data.Functor.Request-import Data.Functor.PushPull-import Control.Applicative-import Data.Monoid-import Data.Hashable-import Data.Traversable as T-import Data.IORef-import Data.Profunctor.Unsafe-import Control.Monad.IO.Class---- | Build an object using continuation passing style.-oneshot :: (Functor f, Monad m) => (forall a. f (m a) -> m a) -> Object f m-oneshot m = go where-  go = Object $ \e -> m (fmap return e) >>= \a -> return (a, go)-{-# INLINE oneshot #-}---- | The flyweight pattern.-flyweight :: (Monad m, Ord k) => (k -> m a) -> Object (Request k a) m-flyweight f = go Map.empty where-  go m = Object $ \(Request k cont) -> case Map.lookup k m of-    Just a -> return (cont a, go m)-    Nothing -> f k >>= \a -> return (cont a, go $ Map.insert k a m)-{-# INLINE flyweight #-}---- | Like 'flyweight', but it uses 'Data.HashMap.Strict' internally.-flyweight' :: (Monad m, Eq k, Hashable k) => (k -> m a) -> Object (Request k a) m-flyweight' f = go HM.empty where-  go m = Object $ \(Request k cont) -> case HM.lookup k m of-    Just a -> return (cont a, go m)-    Nothing -> f k >>= \a -> return (cont a, go $ HM.insert k a m)-{-# INLINE flyweight' #-}--animate :: (Applicative m, Num t) => (t -> m a) -> Object (Request t a) m-animate f = go 0 where-  go t = Object $ \(Request dt cont) -> (\x -> (cont x, go (t + dt))) <$> f t-{-# INLINE animate #-}--transit :: (Alternative m, Fractional t, Ord t) => t -> (t -> m a) -> Object (Request t a) m-transit len f = go 0 where-  go t-    | t >= len = Object $ const empty-    | otherwise = Object $ \(Request dt cont) -> (\x -> (cont x, go (t + dt))) <$> f (t / len)-{-# INLINE transit #-}--announce :: (T.Traversable t, Monad m) => f a -> StateT (t (Object f m)) m [a]-announce f = StateT $ \t -> do-  (t', Endo e) <- runWriterT $ T.mapM (\obj -> lift (runObject obj f)-      >>= \(x, obj') -> writer (obj', Endo (x:))) t-  return (e [], t')--announceMaybe :: (Witherable t, Monad m) => f a -> StateT (t (Object f Maybe)) m [a]-announceMaybe f = StateT-  $ \t -> let (t', Endo e) = runWriter-                $ witherM (\obj -> case runObject obj f of-                  Just (x, obj') -> lift $ writer (obj', Endo (x:))-                  Nothing -> mzero) t in return (e [], t')--announceMaybeT :: (Witherable t, Monad m) => f a -> StateT (t (Object f (MaybeT m))) m [a]-announceMaybeT f = StateT $ \t -> do-  (t', Endo e) <- runWriterT $ witherM (\obj -> mapMaybeT lift (runObject obj f)-      >>= \(x, obj') -> lift (writer (obj', Endo (x:)))) t-  return (e [], t')--type Variable s = forall m. Monad m => Object (StateT s m) m---- | A mutable variable.-variable :: s -> Variable s-variable s = Object $ \m -> liftM (fmap variable) $ runStateT m s--moore :: Applicative f => (a -> r -> f r) -> r -> Object (PushPull a r) f-moore f = go where-  go r = Object $ \pp -> case pp of-    Push a c -> fmap (\z -> (c, z `seq` go z)) (f a r)-    Pull cont -> pure (cont r, go r)-{-# INLINE moore #-}--foldPP :: Applicative f => (a -> r -> r) -> r -> Object (PushPull a r) f-foldPP f = go where-  go r = Object $ \pp -> case pp of-    Push a c -> let z = f a r in pure (c, z `seq` go z)-    Pull cont -> pure (cont r, go r)-{-# INLINE foldPP #-}--(*-) :: MonadIO m => IORef (Object f m) -> f a -> m a-r *- f = do-  obj <- liftIO $ readIORef r-  (a, obj') <- runObject obj f-  liftIO $ writeIORef r obj'-  return a--invokeState :: f a -> StateT (Object f m) m a-invokeState = StateT #. flip runObject-{-# INLINE invokeState #-}
+ src/Control/Object/Instance.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE GADTs, Rank2Types #-}+module Control.Object.Instance where+import Control.Concurrent.MVar+import Control.Object.Object+import Control.Monad.IO.Class+import Control.Monad++-- | MVar-based instance+data Instance f g where+  InstRef :: MVar (Object f g) -> Instance f g+  InstLmap :: (forall x. f x -> g x) -> Instance g h -> Instance f h+  InstRmap :: Instance f g -> (forall x. g x -> h x) -> Instance f h++instance HProfunctor Instance where+  (^>>@) = InstLmap+  (@>>^) = InstRmap++-- | Invoke a method with an explicit landing function.+invoke :: MonadIO m => (forall x. g x -> m x) -> Instance f g -> f a -> m a+invoke m (InstRef v) f = do+  obj <- liftIO (takeMVar v)+  (a, obj') <- m (runObject obj f)+  liftIO $ putMVar v obj'+  return a+invoke m (InstLmap t i) f = invoke m i (t f)+invoke m (InstRmap i t) f = invoke (m . t) i f++-- | Invoke a method.+(.-) :: MonadIO m => Instance f m -> f a -> m a+(.-) = invoke id+{-# INLINE (.-) #-}++-- | Create a new instance.+new :: MonadIO m => Object f g -> m (Instance f g)+new = liftIO . liftM InstRef . 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,13 +1,13 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE Rank2Types #-}+{-# LANGUAGE LambdaCase #-} module Control.Object.Mortal (     Mortal(..),     mortal,     mortal_,     runMortal,-    runMortal',     immortal,-    reincarnation+    apprise     ) where  import Control.Object.Object@@ -15,6 +15,10 @@ 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 Unsafe.Coerce  -- | Object with a final result.@@ -36,36 +40,38 @@ instance Monad m => Monad (Mortal f m) where   return a = mortal $ const $ left a   {-# INLINE return #-}-  m >>= k = mortal $ \f -> lift (runMortal' m f) >>= \r -> case r of+  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 :: (forall x. f x -> EitherT a m (x, Mortal f m a)) -> Mortal f m a mortal f = Mortal (Object (fmap unsafeCoerce f)) {-# INLINE mortal #-} +-- | Send a message to a mortal. runMortal :: Mortal f m a -> f x -> EitherT a m (x, Mortal f m a) runMortal = unsafeCoerce {-# INLINE runMortal #-} -runMortal' :: Mortal f m a -> f x -> m (Either a (x, Mortal f m a))-runMortal' = unsafeCoerce-{-# INLINE runMortal' #-}---- | Restricted 'Mortal' constuctor, which can be applied to 'transit', 'fromFoldable' without ambiguousness.+-- | 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 immortal into a mortal with eternal life. immortal :: Monad m => Object f m -> Mortal f m x immortal obj = mortal $ \f -> EitherT $ runObject obj f >>= \(a, obj') -> return $ Right (a, immortal obj') -reincarnation :: Monad m => (a -> Mortal f m a) -> a -> Object f m-reincarnation g = go . g where-  go m = Object $ \f -> runMortal' m f >>= \r -> case r of-    Left a -> runObject (go (g a)) f-    Right (a, m') -> return (a, go m')-{-# INLINE reincarnation #-}+-- | Send a message to mortals in a container.+apprise :: (Witherable t, Monad m, Applicative m) => f a -> StateT (t (Mortal f m r)) m ([a], [r])+apprise f = StateT $ \t -> do+  (t', (Endo ba, Endo br)) <- runWriterT $ flip wither t+    $ \obj -> lift (runEitherT $ runMortal obj f) >>= \case+      Left r -> writer (Nothing, (mempty, Endo (r:)))+      Right (x, obj') -> writer (Just obj', (Endo (x:), mempty))+  return ((ba [], br []), t')
src/Control/Object/Object.hs view
@@ -1,26 +1,26 @@ {-# LANGUAGE Trustworthy #-}-{-# LANGUAGE Rank2Types, CPP, TypeOperators, DataKinds #-}+{-# LANGUAGE Rank2Types, CPP, TypeOperators, DataKinds, TupleSections #-} #if __GLASGOW_HASKELL__ >= 707 {-# LANGUAGE DeriveDataTypeable #-} #endif module Control.Object.Object where-import Data.Functor.Day-import Data.Functor.Coproduct-import Control.Monad-import Control.Monad.Free-import Control.Monad.Operational.Mini-import qualified Control.Monad.Trans.Free as T-import qualified Control.Monad.Trans.Operational.Mini as T-import Control.Monad.Trans.State.Strict import Data.Typeable-import Control.Applicative-import Data.Extensible-import Control.Arrow (first)+import Control.Monad.Trans.State.Strict+import Control.Monad.Free+import Control.Monad+import Data.Traversable as T+import Control.Monad.Trans.Writer.Strict+import Control.Monad.Trans.Class+import Data.Monoid  -- | 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 converts effects. -- 'Object's can be composed just like functions using '@>>@'; the identity element is 'echo'.--- Objects are morphisms of the category of functors+-- 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)@@ -40,30 +40,53 @@ #endif {-# NOINLINE objectTyCon #-} #endif---- | An alias for 'runObject'.+-- | An alias for 'runObject' (@-) :: Object f g -> f x -> g (x, Object f g) (@-) = runObject {-# INLINE (@-) #-} infixr 3 @- --- | The identity object+infixr 1 ^>>@+infixr 1 @>>^++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++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 (^>>@) #-}++-- | The trivial object echo :: Functor f => Object f f-echo = Object (fmap (\x -> (x, echo)))+echo = Object $ fmap (,echo) --- | Lift a natural transformation into an object.+-- | Lift 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 #-} +-- | Object composition+(@>>@) :: 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 @<<@+ -- | The unwrapped analog of 'stateful' --     @unfoldO runObject = id@---     @unfoldO runSequential = sequential@ --     @unfoldO iterObject = iterable@ 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 #-}@@ -76,86 +99,23 @@   go s = Object $ \f -> runStateT (h f) s >>= \(a, s') -> s' `seq` return (a, go s') {-# INLINE stateful #-} --- | Object-object composition-(@>>@) :: 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 @<<@---- | Object-function composition-(@>>^) :: 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-infixr 1 @>>^---- | Function-object composition-(^>>@) :: 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-infixr 1 ^>>@---- | Parallel composition-(@**@) :: Applicative m => Object f m -> Object g m -> Object (Day f g) m-a @**@ b = Object $ \(Day f g r) -> (\(x, a') (y, b') -> (r x y, a' @**@ b')) <$> runObject a f <*> runObject b g-infixr 3 @**@---- | Objective fanin-(@||@) :: Functor m => Object f m -> Object g m -> Object (Coproduct f g) m-a @||@ b = Object $ \(Coproduct r) -> case r of-  Left f -> fmap (fmap (@||@b)) (runObject a f)-  Right g -> fmap (fmap (a@||@)) (runObject b g)-infixr 2 @||@---- | Build a stateful object, sharing out the state.-sharing :: Monad m => (forall a. f a -> StateT s m a) -> s -> Object (Union '[State s, f]) m-sharing m = go where-  go s = Object $ \k -> liftM (fmap go) $ caseOf (getUnion k)-    $ (\n cont -> return $ first cont $ runState n s)-    <?!~ (\e cont -> first cont `liftM` runStateT (m e) s)-    <?!~ Nil-{-# INLINE sharing #-}--(@!) :: Monad m => Object e m -> ReifiedProgram e a -> m (a, Object e m)-obj @! Return a = return (a, obj)-obj @! (e :>>= cont) = runObject obj e >>= \(a, obj') -> obj' @! cont a-infixr 3 @!--(@!!) :: Monad m => Object e m -> T.ReifiedProgramT e m a -> m (a, Object e m)-obj @!! T.Return a = return (a, obj)-obj @!! T.Lift m cont = m >>= (obj @!!) . cont-obj @!! (e T.:>>= cont) = runObject obj e >>= \(a, obj') -> obj' @!! cont a-infixr 3 @!!-+-- | 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 -iterTObject :: Monad m => Object f m -> T.FreeT f m a -> m (a, Object f m)-iterTObject obj m = T.runFreeT m >>= \r -> case r of-  T.Pure a -> return (a, obj)-  T.Free f -> runObject obj f >>= \(cont, obj') -> iterTObject obj' cont---- | Let object handle 'ReifiedProgram'.-sequential :: Monad m => Object e m -> Object (ReifiedProgram e) m-sequential = unfoldOM (@!)---- | Let object handle 'ReifiedProgramT'.-sequentialT :: Monad m => Object e m -> Object (T.ReifiedProgramT e m) m-sequentialT = unfoldOM (@!!)--iterative :: Monad m => Object f m -> Object (Free f) m+-- | Objects can consume free monads+iterative :: (Monad m) => Object f m -> Object (Free f) m iterative = unfoldOM iterObject--iterativeT :: Monad m => Object f m -> Object (T.FreeT f m) m-iterativeT = unfoldOM iterTObject+{-# INLINE iterative #-} --- | Change the workspace of the object.-transObject :: Functor g => (forall x. f x -> g x) -> Object e f -> Object e g-transObject f = (@>>^f)+-- | A mutable variable.+variable :: Monad m => s -> Object (StateT s m) m+variable s = Object $ \m -> liftM (fmap variable) $ runStateT m s --- | Apply a function to methods coming into an object.-adaptObject :: Functor m => (forall x. g x -> f x) -> Object f m -> Object g m-adaptObject f = (f^>>@)+-- | Send a message to objects in a container.+announce :: (T.Traversable t, Monad m) => f a -> StateT (t (Object f m)) m [a]+announce f = StateT $ \t -> do+  (t', Endo e) <- runWriterT $ T.mapM (\obj -> lift (runObject obj f)+      >>= \(x, obj') -> writer (obj', Endo (x:))) t+  return (e [], t')
− src/Control/Object/Process.hs 
@@ -1,94 +0,0 @@-{-# LANGUAGE Trustworthy #-}-module Control.Object.Process where-import Control.Object.Object-import Control.Arrow as A-import qualified Control.Category as C-import Data.Profunctor-import Control.Applicative-import Control.Monad-import Data.Monoid-import Data.Functor.Request---- | An object which is specialized to be a Mealy machine-newtype Process m a b = Process { unProcess :: Object (Request a b) m }---- | @_Process :: Iso' (Object (Request a b) m) (Process m a b)@-_Process :: (Profunctor p, Functor f) => p (Process m a b) (f (Process m a b)) -> p (Object (Request a b) m) (f (Object (Request a b) m))-_Process = dimap Process (fmap unProcess)--instance Functor f => Functor (Process f a) where-  fmap f (Process o0) = Process $ go o0 where-    go o = Object $ \(Request a cont) -> fmap (cont *** go) $ runObject o (Request a f)--instance Applicative f => Applicative (Process f a) where-  pure a = Process go where-    go = Object $ \(Request _ cont) -> pure (cont a, go)-  Process f0 <*> Process a0 = Process $ go f0 a0 where-    go mf ma = Object $ \(Request a cont) -> (\(f, mf') (x, ma') -> (cont (f x), go mf' ma'))-      <$> runObject mf (Request a id)-      <*> runObject ma (Request a id)--instance (Applicative f, Monoid b) => Monoid (Process f a b) where-  mempty = pure mempty-  mappend = liftA2 mappend--instance Monad m => C.Category (Process m) where-  id = arr id-  Process g0 . Process f0 = Process $ go f0 g0 where-    go f g = Object $ \(Request a cont) -> runObject f (Request a id)-      >>= \(b, f') -> liftM (\(c, g') -> (cont c, go f' g')) $ runObject g (Request b id)--instance Monad m => Arrow (Process m) where-  arr f = Process go where-    go = Object $ \(Request a cont) -> return (cont (f a), go)-  first (Process f0) = Process $ go f0 where-    go f = Object $ \(Request (a, c) cont) -> liftM (\(b, f') -> (cont (b, c), go f')) $ runObject f (Request a id)-  second (Process f0) = Process $ go f0 where-    go f = Object $ \(Request (a, c) cont) -> liftM (\(d, f') -> (cont (a, d), go f')) $ runObject f (Request c id)--instance Monad m => ArrowChoice (Process m) where-  left (Process f0) = Process $ go f0 where-    go f = Object $ \(Request e cont) -> case e of-      Left a -> liftM (\(b, f') -> (cont (Left b), go f')) $ runObject f (Request a id)-      Right c -> return (cont (Right c), go f)-  right (Process f0) = Process $ go f0 where-    go f = Object $ \(Request e cont) -> case e of-      Right a -> liftM (\(b, f') -> (cont (Right b), go f')) $ runObject f (Request a id)-      Left c -> return (cont (Left c), go f)--instance Monad m => Profunctor (Process m) where-  dimap f g (Process f0) = Process (go f0) where-    go m = Object $ \(Request a cont) -> liftM (\(b, m') -> (cont (g b), go m')) $ runObject m (Request (f a) id)-  {-# INLINE dimap #-}--instance Monad m => Strong (Process m) where-  first' = first-  {-# INLINE first' #-}-  second' = second-  {-# INLINE second' #-}--instance Monad m => Choice (Process m) where-  left' = A.left-  {-# INLINE left' #-}-  right' = A.right-  {-# INLINE right' #-}--instance (Applicative m, Num o) => Num (Process m i o) where-  (+) = liftA2 (+)-  {-# INLINE (+) #-}-  (-) = liftA2 (-)-  {-# INLINE (-) #-}-  (*) = liftA2 (*)-  {-# INLINE (*) #-}-  abs = fmap abs-  {-# INLINE abs #-}-  signum = fmap signum-  {-# INLINE signum #-}-  fromInteger = pure . fromInteger-  {-# INLINE fromInteger #-}--instance (Applicative m, Fractional o) => Fractional (Process m i o) where-  (/) = liftA2 (/)-  {-# INLINE (/) #-}-  recip = fmap recip-  fromRational = pure . fromRational
− src/Control/Object/Stream.hs 
@@ -1,67 +0,0 @@-{-# LANGUAGE Trustworthy #-}-module Control.Object.Stream where--import Data.Functor.Rep-import Data.Functor.Adjunction-import Control.Object.Object-import Data.Foldable as F-import Control.Applicative-import Data.Functor.Request-import Control.Monad-import Control.Monad.Trans.Either-import Control.Object.Mortal---- | For every adjunction f ⊣ g, we can "connect" @Object g m@ and @Object f m@ permanently.-($$) :: (Monad m, Adjunction f g) => Object g m -> Object f m -> m x-a $$ b = do-  (x, a') <- runObject a askRep-  ((), b') <- runObject b (unit () `index` x)-  a' $$ b'-infix 1 $$--($?$) :: (Monad m, Adjunction f g) => Object g (EitherT a m) -> Object f (EitherT a m) -> m a-a $?$ b = liftM (either id id) $ runEitherT (a $$ b)-{-# INLINE ($?$) #-}--(!$$!) :: (Monad m, Adjunction f g) => Mortal g m a -> Mortal f m a -> m a-Mortal a !$$! Mortal b = a $?$ b-{-# INLINE (!$$!) #-}---- | Create a source from a 'Foldable' container.-fromFoldable :: (Foldable t, Alternative m, Representable f) => t (Rep f) -> Object f m-fromFoldable = F.foldr go $ Object $ const empty where-  go x m = Object $ \cont -> pure (index cont x, m)--mapL :: (Adjunction f g, Adjunction f' g', Functor m) => (Rep g' -> Rep g) -> Object f m -> Object f' m-mapL t = (^>>@) $ rightAdjunct $ \x -> tabulate (index (unit x) . t)--mapR :: (Representable f, Representable g, Functor m) => (Rep f -> Rep g) -> Object f m -> Object g m-mapR t = (^>>@) $ \f -> tabulate (index f . t)--filterL :: (Adjunction f g, Applicative m) => (Rep g -> Bool) -> Object f m -> Object f m-filterL p obj = Object $ \f -> if counit (tabulate p <$ f)-  then fmap (filterL p) `fmap` runObject obj f-  else pure (extractL f, filterL p obj)--filterR :: (Representable f, Monad m) => (Rep f -> Bool) -> Object f m -> Object f m-filterR p obj = Object $ \f -> go f obj where-  go f o = do-    (x, o') <- runObject o askRep-    if p x-      then return (index f x, filterR p o')-      else go f o'---- | Attack a rank-1 Mealy machine to a source.-($$@) :: (Representable f, Representable g, Monad m) => Object f m -> Object (Request (Rep f) (Rep g)) m -> Object g m-obj $$@ pro = Object $ \g -> do-  (x, obj') <- runObject obj askRep-  (a, pro') <- runObject pro $ Request x (index g)-  return (a, obj' $$@ pro')---- | Attach a rank-1 Mealy machine into a sink.-(@$$) :: (Adjunction f g, Adjunction f' g', Monad m) => Object (Request (Rep g') (Rep g)) m -> Object f m -> Object f' m-pro @$$ obj = Object $ \f' -> do-  let (a, f_) = splitL f'-  (x, pro') <- runObject pro $ Request (counit (askRep <$ f_)) id-  ((), obj') <- runObject obj $ unit () `index` x-  return (a, pro' @$$ obj')
− src/Data/Functor/PushPull.hs 
@@ -1,60 +0,0 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE ScopedTypeVariables, Rank2Types, DeriveFunctor, DeriveDataTypeable, ConstraintKinds, FlexibleContexts, DataKinds, TypeFamilies, TypeOperators #-}--------------------------------------------------------------------------------- |--- Module      :  Data.Functor.PushPull--- Copyright   :  (c) Fumiaki Kinoshita 2014--- License     :  BSD3------ Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>--- Stability   :  experimental--- Portability :  non-portable----------------------------------------------------------------------------------module Data.Functor.PushPull where-import Data.Typeable-import Control.Elevator-import Control.Applicative-import Data.Profunctor-import Data.Functor.Day-import Data.Extensible---- | The type for asynchronous input/output.-data PushPull a b r = Push a r | Pull (b -> r) deriving (Functor, Typeable)--type PushPull' a = PushPull a a--instance Profunctor (PushPull a) where-  dimap _ g (Push a r) = Push a (g r)-  dimap f g (Pull br) = Pull (dimap f g br)--instance Tower (PushPull a b) where-  type Floors (PushPull a b) = '[(,) a, (->) b]-  stairs = uncurry Push `rung` Pull `rung` Nil--push :: Elevate ((,) a) f => a -> f ()-push a = elevate (a, ())--pull :: Elevate ((->) a) f => f a-pull = elevate id--mapPush :: (a -> a') -> PushPull a b r -> PushPull a' b r-mapPush f (Push a r) = Push (f a) r-mapPush _ (Pull br) = Pull br--bipush :: (i -> (a, c)) -> (b -> d -> o) -> PushPull i o r -> Day (PushPull a b) (PushPull c d) r-bipush f g = go where-  go (Pull r) = Day (Pull id) (Pull id) (fmap r . g)-  go (Push i r) = let (a, b) = f i in Day (Push a ()) (Push b ()) (\_ _ -> r)-{-# INLINE bipush #-}--bipull :: (a -> b -> c) -> PushPull i c r -> Day (PushPull i a) (PushPull i b) r-bipull = bipush (\x -> (x, x))-{-# INLINE bipull #-}---- | @filterPush :: (a -> Bool) -> PushPull a b r -> Program (PushPull a b) r@-filterPush :: (Applicative f, Elevate (PushPull a b) f) => (a -> Bool) -> PushPull a b r -> f r-filterPush p e@(Push a r)-  | p a = elevate e-  | otherwise = pure r-filterPush _ e = elevate e
src/Data/Functor/Request.hs view
@@ -13,12 +13,13 @@ ----------------------------------------------------------------------------- module Data.Functor.Request where import Data.Typeable-import Control.Elevator-import Data.Extensible-import Control.Monad import Data.Monoid 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)@@ -35,15 +36,30 @@   pure a = Request mempty (const a)   Request a c <*> Request b d = Request (mappend a b) (c <*> d) -instance Tower (Request a b) where-  type Floors (Request a b) = '[]-  stairs = Nil+request :: a -> Request a b b+request a = Request a id+{-# INLINE request #-} -request :: (Elevate (Request a b) f) => a -> f b-request a = elevate (Request a id)+handles :: Functor m => (a -> m (b, Object (Request a b) m)) -> Object (Request a b) m+handles f = Object $ \(Request a cont) -> first cont <$> f a+{-# INLINE handles #-} -accept :: Functor f => (a -> f b) -> Request a b r -> f r-accept f (Request a br) = fmap br (f a)+-- | Like 'flyweight', but it uses 'Data.HashMap.Strict' internally.+flyweight :: (Applicative m, Eq k, Hashable k) => (k -> m a) -> Object (Request k a) m+flyweight f = go HM.empty where+  go m = Object $ \(Request k cont) -> case HM.lookup k m of+    Just a -> pure (cont a, go m)+    Nothing -> (\a -> (cont a, go $ HM.insert k a m)) <$> f k+{-# INLINE flyweight #-} -acceptM :: Monad m => (a -> m b) -> Request a b r -> m r-acceptM f (Request a br) = liftM br (f a)+animate :: (Applicative m, Num t) => (t -> m a) -> Object (Request t a) m+animate f = go 0 where+  go t = Object $ \(Request dt cont) -> (\x -> (cont x, go (t + dt))) <$> f t+{-# INLINE animate #-}++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 #-}