objective 1.0.3 → 1.0.4
raw patch · 8 files changed
+265/−84 lines, 8 filesdep +monad-skeletondep +mtldep +template-haskelldep ~freedep ~transformersdep ~witherable
Dependencies added: monad-skeleton, mtl, template-haskell, transformers-compat
Dependency ranges changed: free, transformers, witherable
Files
- .travis.yml +52/−7
- CHANGELOG.md +9/−0
- objective.cabal +10/−6
- src/Control/Object.hs +1/−5
- src/Control/Object/Instance.hs +41/−18
- src/Control/Object/Mortal.hs +38/−22
- src/Control/Object/Object.hs +98/−18
- src/Data/Functor/Request.hs +16/−8
.travis.yml view
@@ -1,11 +1,56 @@-language: haskell +# 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: - - GHCVER=7.6.3 - - GHCVER=7.8.4 + - 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: - - 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 + - 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,12 @@+1.0.4+----+* Simplified `Instance`+* Added `snapshot`+* Added `cascade`, `cascadeObject`+* Added `announcesOf`+* Added `(@||@)`+* Safe Haskell+ 1.0.3 ---- * Added `apprisesOf`
objective.cabal view
@@ -1,7 +1,7 @@ name: objective-version: 1.0.3-synopsis: Extensible objects-description: Stateful effect transducer+version: 1.0.4+synopsis: Composable objects+description: Composable objects homepage: https://github.com/fumieval/objective bug-reports: http://github.com/fumieval/objective/issues license: BSD3@@ -33,14 +33,18 @@ , exceptions >= 0.8 , containers >= 0.5.0.0 && <0.6 , unordered-containers >= 0.2.0.0 && <0.3- , transformers >= 0.3- , free+ , transformers >= 0.3 && <0.6+ , transformers-compat+ , free >= 4 && <5 , hashable+ , mtl , profunctors , void- , witherable+ , witherable < 0.2 , stm , monad-stm+ , 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,6 +1,4 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE Rank2Types, FlexibleInstances, FlexibleContexts, TypeOperators, CPP, ConstraintKinds #-}-+{-# LANGUAGE Safe #-} ----------------------------------------------------------------------------- -- | -- Module : Control.Object@@ -10,8 +8,6 @@ -- Maintainer : Fumiaki Kinoshita <fumiexcel@gmail.com> -- Stability : experimental -- Portability : non-portable------ Stateful effect transducer: The Mealy machine for effects. -- ----------------------------------------------------------------------------- module Control.Object
src/Control/Object/Instance.hs view
@@ -1,5 +1,29 @@+{-# LANGUAGE Safe #-} {-# LANGUAGE GADTs, Rank2Types #-}-module Control.Object.Instance where+-----------------------------------------------------------------------------+-- |+-- 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+ , newSTM+ -- * Invocation+ , invokeOn+ , invokeOnSTM+ , (.-)+ , (..-)+ , snapshot+ ) where import Control.Concurrent.STM.TMVar import Control.Monad.STM import Control.Object.Object@@ -10,40 +34,34 @@ -- | TMVar-based instance data Instance f g where- InstRef :: TMVar (Object f g) -> Instance f g- InstLmap :: (forall x. f x -> g x) -> Instance g h -> Instance f h- InstRmap :: Instance f g -> (forall x. g x -> h x) -> Instance f h+ InstRef :: (forall x. e x -> f x) -> (forall x. g x -> h x) -> TMVar (Object f g) -> Instance e h instance HProfunctor Instance where- (^>>@) = InstLmap+ f ^>>@ InstRef l r v = InstRef (l . f) r v {-# INLINE (^>>@) #-}- (@>>^) = InstRmap+ InstRef l r v @>>^ f = InstRef l (f . r) v {-# INLINE (@>>^) #-} -- | Invoke a method with an explicit landing function. invokeOn :: (MonadIO m, MonadMask m) => (forall x. g x -> m x) -> Instance f g -> f a -> m a-invokeOn m (InstRef v) f = bracketOnError+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 (runObject obj f)+ (a, obj') <- m $ l $ runObject obj (t f) liftIO $ atomically $ putTMVar v obj' return a)-invokeOn m (InstLmap t i) f = invokeOn m i (t f)-invokeOn m (InstRmap i t) f = invokeOn (m . t) i f -- | Invoke a method with an explicit landing function. invokeOnSTM :: (forall x. g x -> STM x) -> Instance f g -> f a -> STM a-invokeOnSTM m (InstRef v) f = do+invokeOnSTM m (InstRef t l v) f = do obj <- takeTMVar v- (a, obj') <- m (runObject obj f)+ (a, obj') <- m $ l $ runObject obj (t f) putTMVar v obj' return a-invokeOnSTM m (InstLmap t i) f = invokeOnSTM m i (t f)-invokeOnSTM m (InstRmap i t) f = invokeOnSTM (m . t) i f -- | Invoke a method, atomically. (..-) :: MonadSTM m => Instance f STM -> f a -> m a@@ -57,9 +75,14 @@ {-# INLINE (.-) #-} infixr 3 .- --- | Create a new instance.+-- | 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` takeTMVar v+ where go (Object m) = Object $ fmap (fmap go) . g . m . f++-- | 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 . atomically . newSTM+new = liftIO . liftM (InstRef id id) . newTMVarIO {-# INLINE new #-} -- | Create a new instance, having it sitting on the current environment.@@ -68,6 +91,6 @@ {-# INLINE newSettle #-} -- | Create a new instance.-newSTM :: Object f g -> STM (Instance f g)-newSTM = liftM InstRef . newTMVar+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,7 +1,19 @@+{-# 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,@@ -10,12 +22,13 @@ immortal, apprisesOf, apprises,- apprise,- withBuilder,+ 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@@ -23,10 +36,14 @@ import Control.Monad.Trans.Writer.Strict import Data.Monoid import Data.Witherable-import Unsafe.Coerce+import Data.Tuple (swap) import Control.Arrow ((***))+import Unsafe.Coerce --- | Object with a final result.+-- | 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@ --@@ -54,13 +71,13 @@ {-# 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))+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 :: Mortal f m a -> f x -> EitherT a m (x, Mortal f m a)-runMortal = unsafeCoerce+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.@@ -68,21 +85,24 @@ mortal_ = Mortal {-# INLINE mortal_ #-} --- | Turn an immortal into a mortal with eternal life.+-- | Turn an object into a mortal without death. 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')+immortal obj = Mortal (obj @>>^ lift)+{-# INLINE immortal #-} --- | Send a message to mortals in a container.+-- | Send a message to mortals through a filter. apprisesOf :: (Monad m, Monoid r) => ((Mortal f m b -> WriterT r m (Maybe (Mortal f m b))) -> s -> WriterT r m s) -> f a -> (a -> r) -> (b -> r) -> StateT s m r-apprisesOf l f p q = StateT $ \t -> do- (t', res) <- runWriterT $ flip l t- $ \obj -> lift (runEitherT $ runMortal obj f) >>= \case- Left r -> writer (Nothing, q r)- Right (x, obj') -> writer (Just obj', p x)- return (res, t')+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 container.+-- | 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 #-}@@ -92,7 +112,3 @@ apprise f = fmap (flip appEndo [] *** flip appEndo []) $ apprises f (\a -> (Endo (a:), mempty)) (\b -> (mempty, Endo (b:))) {-# INLINE apprise #-}--withBuilder :: Functor f => ((a -> Endo [a]) -> f (Endo [a])) -> f [a]-withBuilder f = fmap (flip appEndo []) (f (Endo . (:)))-{-# INLINABLE withBuilder #-}
src/Control/Object/Object.hs view
@@ -1,20 +1,59 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE Rank2Types, CPP, TypeOperators, DataKinds, TupleSections, BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE Rank2Types, TupleSections, TypeOperators #-} #if __GLASGOW_HASKELL__ >= 707 {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE Safe #-}+#else+{-# LANGUAGE Trustworthy #-} #endif-module Control.Object.Object where+-----------------------------------------------------------------------------+-- |+-- 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+ , HProfunctor(..)+ , (@||@)+ -- * Stateful construction+ , unfoldO+ , unfoldOM+ , stateful+ , (@~)+ , variable+ -- * Method cascading+ , (@-)+ , iterObject+ , iterative+ , cascadeObject+ , cascading+ -- * Masses+ , announcesOf+ , 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 Control.Monad.Trans.Class 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 converts effects.+-- 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. --@@ -40,7 +79,8 @@ #endif {-# NOINLINE objectTyCon #-} #endif--- | An alias for 'runObject'++-- | An infix alias for 'runObject' (@-) :: Object f g -> f x -> g (x, Object f g) (@-) = runObject {-# INLINE (@-) #-}@@ -49,6 +89,7 @@ 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@@ -63,12 +104,12 @@ echo :: Functor f => Object f f echo = Object $ fmap (,echo) --- | Lift natural transformation into an object+-- | 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 #-} --- | Object composition+-- | 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 @>>@@@ -79,9 +120,16 @@ {-# INLINE (@<<@) #-} infixl 1 @<<@ --- | The unwrapped analog of 'stateful'--- @unfoldO runObject = id@--- @unfoldO iterObject = iterable@+-- | 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@+-- @cascade = 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 #-}@@ -93,13 +141,15 @@ -- | Build a stateful object. ----- @stateful t s = t ^>>@ variable s@+-- @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'+-- | Flipped 'stateful'.+-- it is 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 (@~) #-}@@ -116,13 +166,43 @@ {-# INLINE iterative #-} -- | A mutable variable.+--+-- @variable = stateful id@+-- variable :: Monad m => s -> Object (StateT s m) m variable = stateful id {-# INLINE variable #-} --- | Send a message to objects in a container.+-- | 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 objects through a traversal.+announcesOf :: (Monad m, Monoid r) => ((Object t m -> WriterT r m (Object t m)) -> s -> WriterT r m s)+ -> t a -> (a -> r) -> StateT s m r+announcesOf t f c = StateT $ liftM swap . runWriterT+ . t (\obj -> WriterT $ runObject obj f >>= \(x, obj') -> return (obj', c x))+{-# INLINABLE announcesOf #-}++-- | Send a message to objects in a traversable container.+--+-- @announce = withBuilder . announcesOf traverse@+-- 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')+announce f = withBuilderM (announcesOf T.mapM f)+{-# INLINABLE announce #-}++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 #-}
src/Data/Functor/Request.hs view
@@ -1,9 +1,9 @@-{-# LANGUAGE Trustworthy #-}-{-# LANGUAGE DeriveFunctor, DeriveDataTypeable, ConstraintKinds, FlexibleContexts, TypeOperators, DataKinds, TypeFamilies #-}+{-# LANGUAGE Safe #-}+{-# LANGUAGE CPP, DeriveFunctor, DeriveDataTypeable, ConstraintKinds, FlexibleContexts, TypeOperators, DataKinds, TypeFamilies #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Functor.Request--- Copyright : (c) Fumiaki Kinoshita 2014+-- Copyright : (c) Fumiaki Kinoshita 2015 -- License : BSD3 -- -- Maintainer : Fumiaki Kinoshita <fumiexcel@gmail.com>@@ -13,7 +13,9 @@ ----------------------------------------------------------------------------- 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@@ -24,6 +26,7 @@ -- | @'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 #-}@@ -38,19 +41,22 @@ 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 pattern+-- | 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@@ -58,6 +64,7 @@ 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)@@ -69,15 +76,16 @@ go b = mealy $ \a -> pure (b, go (f b a)) {-# INLINE accumulator #-} --- |--- @--- animate f ≡ accumulator (+) 0 >~~> liftO (accept f)--- @+-- | 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