packages feed

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 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