objective 1.1.2 → 1.2
raw patch · 7 files changed
+60/−200 lines, 7 filesdep +bifunctorsdep −free
Dependencies added: bifunctors
Dependencies removed: free
Files
- .travis.yml +0/−56
- CHANGELOG.md +6/−0
- README.md +46/−0
- objective.cabal +3/−4
- src/Control/Object/Mortal.hs +4/−8
- src/Control/Object/Object.hs +1/−39
- src/Data/Functor/Request.hs +0/−93
− .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,9 @@+1.2+----++* Removed `iterObject` and `iterative`+* Removed `Data.Functor.Request`+ 1.1.2 ----
+ README.md view
@@ -0,0 +1,46 @@+objective+====++[](https://hackage.haskell.org/package/objective) [](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.
objective.cabal view
@@ -1,5 +1,5 @@ name: objective-version: 1.1.2+version: 1.2 synopsis: Composable objects description: Composable objects homepage: https://github.com/fumieval/objective@@ -13,7 +13,7 @@ build-type: Simple extra-source-files: CHANGELOG.md- .travis.yml+ README.md cabal-version: >=1.10 source-repository head@@ -26,15 +26,14 @@ , Control.Object.Object , Control.Object.Instance , Control.Object.Mortal- , Data.Functor.Request other-extensions: MultiParamTypeClasses, KindSignatures, TypeFamilies build-depends: base >=4.6 && <5+ , bifunctors , 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
src/Control/Object/Mortal.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE Trustworthy #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE LambdaCase #-}@@ -26,9 +25,6 @@ ) where import Control.Object.Object-#if !MIN_VERSION_base(4,8,0)-import Control.Applicative-#endif import Control.Monad.Trans.Except import Control.Monad import Control.Monad.Trans.Class@@ -73,12 +69,12 @@ -- | Construct a mortal in a 'Object' construction manner. mortal :: Monad m => (forall x. f x -> ExceptT a m (x, Mortal f m a)) -> Mortal f m a-mortal f = unsafeCoerce f `asTypeOf` Mortal (Object (fmap (fmap unMortal) . f))+mortal f = unsafeCoerce f `asTypeOf` Mortal (Object (liftM (fmap unMortal) . f)) {-# INLINE mortal #-} -- | Send a message to a mortal. runMortal :: Monad m => Mortal f m a -> f x -> ExceptT a m (x, Mortal f m a)-runMortal = unsafeCoerce `asTypeOf` ((fmap (fmap Mortal) . ) . runObject . unMortal)+runMortal = unsafeCoerce `asTypeOf` ((liftM (fmap Mortal) . ) . runObject . unMortal) {-# INLINE runMortal #-} -- | Restricted 'Mortal' constuctor which can be applied to 'transit', 'fromFoldable' without ambiguousness.@@ -87,13 +83,13 @@ {-# INLINE mortal_ #-} -- | Turn an object into a mortal without death.-immortal :: Monad m => Object f m -> Mortal f m x+immortal :: (Functor m, Monad m) => Object f m -> Mortal f m x immortal obj = Mortal (obj @>>^ lift) {-# INLINE immortal #-} -- | Send a message to mortals through a filter. apprisesOf :: Monad m- => FilterLike' (WriterT r m) s (Mortal f m b)+ => WitherLike' (WriterT r m) s (Mortal f m b) -> f a -> (a -> r) -> (b -> r) -> StateT s m r apprisesOf l f p q = StateT $ \t -> liftM swap $ runWriterT $ flip l t $ \obj -> WriterT $ runExceptT (runMortal obj f) >>= \case
src/Control/Object/Object.hs view
@@ -1,12 +1,6 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE Rank2Types, TupleSections, TypeOperators #-}+{-# LANGUAGE RankNTypes, TupleSections, TypeOperators #-} {-# LANGUAGE GADTs #-}-#if __GLASGOW_HASKELL__ >= 707-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE Safe #-}-#else-{-# LANGUAGE Trustworthy #-}-#endif ----------------------------------------------------------------------------- -- | -- Module : Control.Object.Object@@ -34,8 +28,6 @@ , variable -- * Method cascading , (@-)- , iterObject- , iterative , cascadeObject , cascading -- * Filtering@@ -49,9 +41,7 @@ , 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@@ -69,25 +59,7 @@ -- @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@@ -159,16 +131,6 @@ s @~ h = stateful h s {-# INLINE (@~) #-} infix 1 @~---- | Cascading-iterObject :: Monad m => Object f m -> Free f a -> m (a, Object f m)-iterObject obj (Pure a) = return (a, obj)-iterObject obj (Free f) = runObject obj f >>= \(cont, obj') -> iterObject obj' cont---- | Objects can consume free monads. 'cascading' is more preferred.-iterative :: Monad m => Object f m -> Object (Free f) m-iterative = unfoldOM iterObject-{-# INLINE iterative #-} -- | A mutable variable. --
− src/Data/Functor/Request.hs
@@ -1,93 +0,0 @@-{-# 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 #-}