packages feed

objective 0.6.2 → 0.6.3

raw patch · 4 files changed

+136/−29 lines, 4 filesdep +adjunctionsdep +either

Dependencies added: adjunctions, either

Files

CHANGELOG.md view
@@ -1,14 +1,22 @@+0.6.3
+----
+* Added `Variable`, an alias for `variable` objects.
+* Added `Mortal`.
+* Increased fixity of invocation operators to 5.
+* Added stream connection operators.
+* Added `transit` and `animate`.
+
 0.6.2
 ----
 * Added `announce`, `announceMaybe` and `announceMaybeT` which invoke a method for every objects in a container.
 * Added `(@**@)` and `(@||@)`.
 * Renamed `(.>>.)` to `(@>>@)`, `.|>.` to `(@|>@)` for consistency.
-* Added `filterPush`.
+* Added `filterPush`, `bipush`, `bipull`.
 * Added `iterObject`, `iterTObject`, `iterative`, `iterativeT` for free monads.
 * Renamed `runSequential` to `(@!)`.
 * Added combinators for `ReifiedProgramT`: `(@!!)` and `sequentialT`.
 * Changed the semantics of `variable` to accept `StateT`.
-* Added `flyweight'` that relies on HashMap
+* Added `flyweight'` that relies on HashMap.
 * Added `MonadObjective` constraint
 
 0.6.1
objective.cabal view
@@ -1,5 +1,5 @@ name:                objective
-version:             0.6.2
+version:             0.6.3
 synopsis:            Extensible objects
 description:         Stateful effect transducer
 homepage:            https://github.com/fumieval/objective
@@ -25,7 +25,7 @@                      , Data.Functor.PushPull
   -- other-modules:
   other-extensions:    MultiParamTypeClasses, KindSignatures, TypeFamilies
-  build-depends:       base >=4.5 && <5, transformers >= 0.3 && <0.5, clean-unions < 0.2, elevator >= 0.1.2, containers, minioperational >= 0.4 && <0.5, profunctors >= 4.0 && <5, witherable <= 0.2, free >= 4.4 && <5, kan-extensions >= 4.1, unordered-containers, hashable >= 1.2 && <1.4
+  build-depends:       base >=4.5 && <5, transformers >= 0.3 && <0.5, clean-unions < 0.2, elevator >= 0.1.2, containers, minioperational >= 0.4 && <0.5, profunctors >= 4.0 && <5, witherable <= 0.2, free >= 4.4 && <5, kan-extensions >= 4.1, unordered-containers, hashable >= 1.2 && <1.4, either, adjunctions
   ghc-options: -Wall
   hs-source-dirs:      src
   default-language:    Haskell2010
src/Control/Monad/Objective/Class.hs view
@@ -31,6 +31,8 @@ 
 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)
   invoke :: Monad m => (forall x. b x -> m x) -> (forall x. g x -> m x) -> Inst b f g -> f a -> m a
 
@@ -40,13 +42,13 @@ (.-) = invoke elevate elevate
 {-# INLINE (.-) #-}
 
-infix 3 .-
+infixr 5 .-
 
 -- | 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 (.^) #-}
-infix 3 .^
+infixr 5 .^
 
 -- | (.^) for StateT
 (.&) :: (MonadObjective b m, Elevate g m, Elevate (State s) f) => Inst b f g -> StateT s m a -> m a
@@ -56,12 +58,12 @@   i .^ put s'
   return a
 
-infix 3 .&
+infixr 5 .&
 
 (.!) :: (MonadObjective b m, Elevate g m) => Inst b f g -> Program f a -> m a
 (.!) i = interpret (i.-)
 
-infix 3 .!
+infixr 5 .!
 
 -- | We can convert method invocation into an object trivially.
 -- @invocation i = liftO (i.-)@
src/Control/Object.hs view
@@ -18,16 +18,20 @@ module Control.Object (
   -- * Construction
   Object(..),
+  (@-),
   liftO,
   echo,
   oneshot,
   stateful,
   variable,
+  Variable,
   unfoldO,
   unfoldOM,
   foldP,
   foldP',
   sharing,
+  animate,
+  transit,
   -- * Composition
   (@>>@),
   (@>>^),
@@ -38,6 +42,11 @@   (@|>@),
   transObject,
   adaptObject,
+  -- * Stream
+  ($$),
+  ($$!),
+  (!$$),
+  (!$$!),
   -- * Monads
   (@!),
   (@!!),
@@ -55,41 +64,47 @@   announceMaybeT,
   Process(..),
   _Process,
-  -- * Deprecated
-  runSequential
+  Mortal(..),
+  runMortal,
   )
 where
 
 import Control.Applicative
-import Control.Arrow
+import Control.Arrow as A
+import Control.Elevator
 import Control.Monad
+import Control.Monad.Free
 import Control.Monad.Operational.Mini
+import Control.Monad.Trans.Class
 import Control.Monad.Trans.Maybe
 import Control.Monad.Trans.State.Strict
 import Control.Monad.Trans.Writer.Strict
-import Control.Monad.Trans.Class
-import Control.Elevator
-import Data.Functor.Request
+import Data.Functor.Day
 import Data.Functor.PushPull
+import Data.Functor.Request
+import Data.Functor.Sum as F
+import Data.Hashable
 import Data.Monoid
 import Data.OpenUnion1.Clean
 import Data.Profunctor
 import Data.Typeable
 import Data.Witherable
 import qualified Control.Category as C
-import qualified Control.Monad.Trans.Operational.Mini as T
 import qualified Control.Monad.Trans.Free as T
+import qualified Control.Monad.Trans.Operational.Mini as T
+import qualified Data.HashMap.Strict as HM
 import qualified Data.Map.Strict as Map
 import qualified Data.Traversable as T
-import Control.Monad.Free
-import qualified Data.HashMap.Strict as HM
-import Data.Functor.Day
-import Data.Functor.Sum as F
-import Data.Hashable
+import Control.Monad.Trans.Either as E
+import Unsafe.Coerce
 
--- | The type 'Object f g' represents objects which can handle messages @f@, perform actions in the environment @g@.
+import Data.Functor.Rep
+import Data.Functor.Adjunction
+
+-- | 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
 newtype Object f g = Object { runObject :: forall x. f x -> g (x, Object f g) }
 #if __GLASGOW_HASKELL__ >= 707
   deriving (Typeable)
@@ -110,6 +125,12 @@ {-# NOINLINE objectTyCon #-}
 #endif
 
+-- | An alias for 'runObject'.
+(@-) :: Object f g -> f x -> g (x, Object f g)
+(@-) = runObject
+{-# INLINE (@-) #-}
+infixr 5 @-
+
 -- | The identity object
 echo :: Functor f => Object f f
 echo = Object (fmap (\x -> (x, echo)))
@@ -159,6 +180,7 @@ {-# INLINE oneshot #-}
 
 -- | Build a stateful object.
+--
 -- @stateful t s = t ^>>@ variable s@
 stateful :: Monad m => (forall a. f a -> StateT s m a) -> s -> Object f m
 stateful h = go where
@@ -177,8 +199,10 @@ unfoldOM h = go where go r = Object $ liftM (fmap go) . h r
 {-# INLINE unfoldOM #-}
 
+type Variable s = forall m. Monad m => Object (StateT s m) m
+
 -- | A mutable variable.
-variable :: Monad m => s -> Object (StateT s m) m
+variable :: s -> Variable s
 variable s = Object $ \m -> liftM (fmap variable) $ runStateT m s
 
 -- | Build a stateful object, sharing out the state.
@@ -216,15 +240,13 @@ (@!) :: 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 5 @!
 
 (@!!) :: 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
-
-runSequential :: Monad m => Object e m -> ReifiedProgram e a -> m (a, Object e m)
-runSequential = (@!)
-{-# DEPRECATED runSequential "use (@!!) instead" #-}
+infixr 5 @!!
 
 iterObject :: Monad m => Object f m -> Free f a -> m (a, Object f m)
 iterObject obj (Pure a) = return (a, obj)
@@ -263,6 +285,16 @@     Pull cont -> pure (cont r, go r)
 {-# INLINE foldP' #-}
 
+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
+
+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)
+
 announce :: (T.Traversable t, Monad m, Elevate (State (t (Object f g))) m, Elevate g m) => f a -> m [a]
 announce f = do
   t <- elevate get
@@ -290,7 +322,7 @@ 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 :: (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
@@ -345,9 +377,9 @@   {-# INLINE second' #-}
 
 instance Monad m => Choice (Process m) where
-  left' = left
+  left' = A.left
   {-# INLINE left' #-}
-  right' = right
+  right' = A.right
   {-# INLINE right' #-}
 
 instance (Applicative m, Num o) => Num (Process m i o) where
@@ -369,3 +401,68 @@   {-# INLINE (/) #-}
   recip = fmap recip
   fromRational = pure . fromRational
+
+-- | Object with a final result.
+--
+-- @Object f g ≡ Mortal f g Void@
+--
+newtype Mortal f g a = Mortal { unMortal :: Object f (EitherT a g) }
+
+instance (Functor m, Monad m) => Functor (Mortal f m) where
+  fmap f (Mortal obj) = Mortal (obj @>>^ bimapEitherT f id)
+
+instance (Functor m, Monad m) => Applicative (Mortal f m) where
+  pure = return
+  (<*>) = ap
+
+instance Monad m => Monad (Mortal f m) where
+  return a = Mortal $ Object $ const $ E.left a
+  Mortal obj >>= k = unsafeCoerce $ \f -> lift (runEitherT (runObject obj f)) >>= \r -> case r of
+    Left a -> runObject (unMortal (k a)) f
+    Right (x, obj') -> return (x, unMortal (Mortal obj' >>= k))
+
+runMortal :: Monad m => Mortal f m a -> f x -> m (Either a (x, Mortal f m a))
+runMortal = unsafeCoerce runObject
+
+-- | 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 0 $$
+
+-- | Like '$$', but kept until the right 'Mortal' dies.
+($$!) :: (Monad m, Adjunction f g) => Object g m -> Mortal f m a -> m (Object g m, a)
+o $$! m = do
+  (x, o') <- runObject o askRep
+  r <- runMortal m (unit () `index` x)
+  case r of
+    Left a -> return (o', a)
+    Right ((), m') -> o' $$! m'
+infix 0 $$!
+
+-- | Like '$$', but kept until the left 'Mortal' dies.
+(!$$) :: (Monad m, Adjunction f g) => Mortal g m a -> Object f m -> m (a, Object f m)
+m !$$ o = do
+  r <- runMortal m askRep
+  case r of
+    Left a -> return (a, o)
+    Right (x, m') -> do
+      ((), o') <- runObject o (unit () `index` x)
+      m' !$$ o'
+infix 0 !$$
+
+-- | Connect two 'Mortal's.
+(!$$!) :: (Monad m, Adjunction f g) => Mortal g m a -> Mortal f m b -> m (Either (a, Mortal f m b) (Mortal g m a, b))
+m !$$! n = do
+  r <- runMortal m askRep
+  case r of
+    Left a -> return (Left (a, n))
+    Right (x, m') -> do
+      s <- runMortal n (unit () `index` x)
+      case s of
+        Left b -> return (Right (m', b))
+        Right ((), n') -> m' !$$! n'
+
+infix 0 !$$!