objective 0.6.3.2 → 0.6.3.3

raw patch · 12 files changed

+546/−492 lines, 12 filesdep +comonaddep +voiddep −transformers-compatdep ~transformers

Dependencies added: comonad, void

Dependencies removed: transformers-compat

Dependency ranges changed: transformers

Files

objective.cabal +17/−10
src/Control/Monad/Objective/Class.hs +1/−1
src/Control/Monad/Objective/IO.hs +1/−1
src/Control/Monad/Objective/ST.hs +1/−1
src/Control/Object.hs +17/−479
src/Control/Object/Extra.hs +114/−0
src/Control/Object/Mortal.hs +62/−0
src/Control/Object/Object.hs +170/−0
src/Control/Object/Process.hs +94/−0
src/Control/Object/Stream.hs +67/−0
src/Data/Functor/PushPull.hs +1/−0
src/Data/Functor/Request.hs +1/−0

objective.cabal view

@@ -1,5 +1,5 @@ name:                objective
-version:             0.6.3.2
+version:             0.6.3.3
 synopsis:            Extensible objects
 description:         Stateful effect transducer
 homepage:            https://github.com/fumieval/objective
@@ -16,16 +16,23 @@ cabal-version:       >=1.10
 
 library
-  exposed-modules:     Control.Object
-                     , Control.Monad.Objective
-                     , Control.Monad.Objective.Class
-                     , Control.Monad.Objective.IO
-                     , Control.Monad.Objective.ST
-                     , Data.Functor.Request
-                     , Data.Functor.PushPull
+  exposed-modules:
+    Control.Object
+      , Control.Object.Object
+      , 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
     , clean-unions < 0.2
     , elevator >= 0.1.2 && <0.2
     , containers
@@ -37,9 +44,9 @@     , unordered-containers
     , hashable >= 1.2 && <1.4
     , either
+    , void
     , adjunctions >= 4.0 && <5
-    , transformers >= 0.2 && <0.5
-    , transformers-compat >= 0.3
+    , transformers >= 0.3 && <0.5
   ghc-options: -Wall
   hs-source-dirs:      src
   default-language:    Haskell2010

src/Control/Monad/Objective/Class.hs view

@@ -21,7 +21,7 @@ --
 -----------------------------------------------------------------------------
 module Control.Monad.Objective.Class where
-import Control.Object
+import Control.Object.Object
 import Control.Elevator
 import Control.Monad.Trans.State.Strict
 import Control.Monad.Operational.Mini

src/Control/Monad/Objective/IO.hs view

@@ -16,7 +16,7 @@ module Control.Monad.Objective.IO  where
 import Control.Monad.Objective.Class
 import Control.Concurrent
-import Control.Object
+import Control.Object.Object
 import Control.Monad.IO.Class
 
 instance ObjectiveBase IO where

src/Control/Monad/Objective/ST.hs view

@@ -18,7 +18,7 @@ 
 import Control.Monad.Objective.Class
 import Control.Monad.ST
-import Control.Object
+import Control.Object.Object
 import Data.STRef
 import Control.Elevator

src/Control/Object.hs view

@@ -1,7 +1,6 @@+{-# LANGUAGE Trustworthy #-}
 {-# LANGUAGE Rank2Types, FlexibleInstances, FlexibleContexts, TypeOperators, CPP, ConstraintKinds #-}
-#if __GLASGOW_HASKELL__ >= 707
-{-# LANGUAGE DeriveDataTypeable #-}
-#endif
+
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Control.Object
@@ -15,481 +14,20 @@ -- Stateful effect transducer: The Mealy machine for effects.
 --
 -----------------------------------------------------------------------------
-module Control.Object (
-  -- * Construction
-  Object(..),
-  (@-),
-  liftO,
-  echo,
-  oneshot,
-  stateful,
-  variable,
-  Variable,
-  unfoldO,
-  unfoldOM,
-  foldP,
-  foldP',
-  sharing,
-  animate,
-  transit,
-  -- * Composition
-  (@>>@),
-  (@>>^),
-  (^>>@),
-  (@**@),
-  (@||@),
-  loner,
-  (@|>@),
-  transObject,
-  adaptObject,
-  -- * Stream
-  ($$),
-  ($$!),
-  (!$$),
-  (!$$!),
-  -- * Monads
-  (@!),
-  (@!!),
-  sequential,
-  sequentialT,
-  iterObject,
-  iterTObject,
-  iterative,
-  iterativeT,
-  -- * Patterns
-  flyweight,
-  flyweight',
-  announce,
-  announceMaybe,
-  announceMaybeT,
-  announceMortal,
-  Process(..),
-  _Process,
-  Mortal(..),
-  runMortal,
-  )
-where
+module Control.Object
+  ( module Control.Object.Object,
+    module Control.Object.Stream,
+    module Control.Object.Mortal,
+    module Control.Object.Process,
+    module Control.Object.Extra,
+    module Data.Functor.Request,
+    module Data.Functor.PushPull
+  ) where
 
-import Control.Applicative
-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 Data.Functor.Day
-import Data.Functor.PushPull
+import Control.Object.Object
+import Control.Object.Stream
+import Control.Object.Mortal
+import Control.Object.Process
+import Control.Object.Extra
 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.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.Trans.Either as E
-import Unsafe.Coerce
-
-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)
-#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 "object" "Control.Object" "Object"
-#endif
-{-# NOINLINE objectTyCon #-}
-#endif
-
--- | An alias for 'runObject'.
-(@-) :: Object f g -> f x -> g (x, Object f g)
-(@-) = runObject
-{-# INLINE (@-) #-}
-infixr 3 @-
-
--- | The identity object
-echo :: Functor f => Object f f
-echo = Object (fmap (\x -> (x, echo)))
-
--- | 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 @>>@
-
--- | 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 ^>>@
-
-(@**@) :: 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 @**@
-
-(@||@) :: Functor m => Object f m -> Object g m -> Object (F.Sum f g) m
-a @||@ b = Object $ \r -> case r of
-  InL f -> fmap (fmap (@||@b)) (runObject a f)
-  InR g -> fmap (fmap (a@||@)) (runObject b g)
-infixr 2 @||@
-
--- | 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 #-}
-
--- | Change the workspace of the object.
-transObject :: Functor g => (forall x. f x -> g x) -> Object e f -> Object e g
-transObject f = (@>>^f)
-
--- | Apply a function to the messages coming into the object.
-adaptObject :: Functor m => (forall x. g x -> f x) -> Object f m -> Object g m
-adaptObject f = (f^>>@)
-
--- | 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 #-}
-
--- | 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
-  go s = Object $ liftM (\(a, s') -> (a, go s')) . flip runStateT s . h
-{-# INLINE stateful #-}
-
--- | 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 #-}
-
-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 #-}
-
-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
-
--- | Build a stateful object, sharing out the state.
-sharing :: Monad m => (forall a. f a -> StateT s m a) -> s -> Object (State s |> f |> Nil) m
-sharing m = go where
-  go s = Object $ \k -> liftM (fmap go) $ ($k)
-    $ (\n -> return $ runState n s)
-    ||> (\e -> runStateT (m e) s)
-    ||> exhaust
-{-# INLINE sharing #-}
-
--- | An object that won't accept any messages.
-loner :: Functor f => Object Nil f
-loner = liftO exhaust
-
--- | Extend an object by adding another independent object.
-(@|>@) :: Functor g => Object f g -> Object (Union s) g -> Object (f |> Union s) g
-p @|>@ q = Object $ fmap (fmap (@|>@q)) . runObject p ||> fmap (fmap (p @|>@)) . runObject q
-infixr 3 @|>@
-
--- | 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)
-
--- | 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)
-
-(@!) :: 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 @!!
-
-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 sequential methods.
-sequential :: Monad m => Object e m -> Object (ReifiedProgram e) m
-sequential = unfoldOM (@!)
-
--- | Let object handle sequential methods.
-sequentialT :: Monad m => Object e m -> Object (T.ReifiedProgramT e m) m
-sequentialT = unfoldOM (@!!)
-
-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
-
-foldP :: Applicative f => (a -> r -> f r) -> r -> Object (PushPull a r) f
-foldP 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 foldP #-}
-
-foldP' :: Applicative f => (a -> r -> r) -> r -> Object (PushPull a r) f
-foldP' 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 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
-  (t', Endo e) <- runWriterT $ T.mapM (\obj -> (lift . elevate) (runObject obj f)
-      >>= \(x, obj') -> writer (obj', Endo (x:))) t
-  elevate (put t')
-  return (e [])
-
-announceMaybe :: (Witherable t
-    , Monad m
-    , Elevate (State (t (Object f Maybe))) m) => f a -> m [a]
-announceMaybe f = elevate $ state
-  $ \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 (e [], t')
-
-announceMaybeT :: (Witherable t
-  , Monad m
-  , State (t (Object f (MaybeT g))) ∈ Floors1 m
-  , g ∈ Floors1 m
-  , Tower m) => f a -> m [a]
-announceMaybeT f = do
-  t <- elevate get
-  (t', Endo e) <- runWriterT $ witherM (\obj -> mapMaybeT (lift . elevate) (runObject obj f)
-      >>= \(x, obj') -> lift (writer (obj', Endo (x:)))) t
-  elevate (put t')
-  return (e [])
-
-announceMortal :: (Witherable t
-  , Monad m
-  , State (t (Mortal f g ())) ∈ Floors1 m
-  , g ∈ Floors1 m
-  , Tower m) => f a -> m [a]
-announceMortal f = do
-  t <- elevate get
-  (t', Endo e) <- runWriterT $ witherM (\obj -> MaybeT (lift $ liftM is $ elevate $ runMortal obj f)
-      >>= \(x, obj') -> lift (writer (obj', Endo (x:)))) t
-  elevate (put t')
-  return (e [])
-  where
-    is (Left ()) = Nothing
-    is (Right a) = Just a
-
--- | 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
-
--- | 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 $ const $ E.left a
-  m >>= k = mortal $ \f -> lift (runMortal m f) >>= \r -> case r of
-    Left a -> EitherT $ runMortal (k a) f
-    Right (x, m') -> return (x, m' >>= k)
-
-mortal :: (forall x. f x -> EitherT a m (x, Mortal f m a)) -> Mortal f m a
-mortal f = unsafeCoerce f
-{-# INLINE mortal #-}
-
-runMortal :: Mortal f m a -> f x -> m (Either a (x, Mortal f m a))
-runMortal = unsafeCoerce
-{-# INLINE runMortal #-}
-
--- | 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 !$$!
+import Data.Functor.PushPull

+ src/Control/Object/Extra.hs view

@@ -0,0 +1,114 @@+{-# LANGUAGE Rank2Types, TypeOperators, FlexibleContexts, ConstraintKinds #-}+module Control.Object.Extra where+import Control.Object.Object+import Control.Object.Mortal+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 Control.Elevator+import Data.Functor.Request+import Data.Functor.PushPull+import Control.Applicative+import Data.OpenUnion1.Clean+import Data.Monoid+import Data.Hashable+import Data.Traversable as T++-- | 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)++-- | 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)++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+  (t', Endo e) <- runWriterT $ T.mapM (\obj -> (lift . elevate) (runObject obj f)+      >>= \(x, obj') -> writer (obj', Endo (x:))) t+  elevate (put t')+  return (e [])++announceMaybe :: (Witherable t+    , Monad m+    , Elevate (State (t (Object f Maybe))) m) => f a -> m [a]+announceMaybe f = elevate $ state+  $ \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 (e [], t')++announceMaybeT :: (Witherable t+  , Monad m+  , State (t (Object f (MaybeT g))) ∈ Floors1 m+  , g ∈ Floors1 m+  , Tower m) => f a -> m [a]+announceMaybeT f = do+  t <- elevate get+  (t', Endo e) <- runWriterT $ witherM (\obj -> mapMaybeT (lift . elevate) (runObject obj f)+      >>= \(x, obj') -> lift (writer (obj', Endo (x:)))) t+  elevate (put t')+  return (e [])++announceMortal :: (Witherable t+  , Monad m+  , State (t (Mortal f g ())) ∈ Floors1 m+  , g ∈ Floors1 m+  , Tower m) => f a -> m [a]+announceMortal f = do+  t <- elevate get+  (t', Endo e) <- runWriterT $ witherM (\obj -> MaybeT (lift $ liftM is $ elevate $ runMortal obj f)+      >>= \(x, obj') -> lift (writer (obj', Endo (x:)))) t+  elevate (put t')+  return (e [])+  where+    is (Left ()) = Nothing+    is (Right a) = Just a++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 #-}

+ src/Control/Object/Mortal.hs view

@@ -0,0 +1,62 @@+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE Rank2Types #-}+module Control.Object.Mortal (+    Mortal(..),+    mortal,+    mortal_,+    runMortal,+    immortal,+    reincarnation+    ) where++import Control.Object.Object+import Control.Applicative+import Control.Monad.Trans.Either+import Control.Monad+import Control.Monad.Trans.Class+import Unsafe.Coerce++-- | 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)+  {-# INLINE fmap #-}++instance (Functor m, Monad m) => Applicative (Mortal f m) where+  pure = return+  {-# INLINE pure #-}+  (<*>) = ap+  {-# INLINE (<*>) #-}++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+    Left a -> EitherT $ runMortal (k a) f+    Right (x, m') -> return (x, m' >>= k)++mortal :: (forall x. f x -> EitherT a m (x, Mortal f m a)) -> Mortal f m a+mortal f = unsafeCoerce f+{-# INLINE mortal #-}++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.+mortal_ :: Object f (EitherT () g) -> Mortal f g ()+mortal_ = Mortal+{-# INLINE mortal_ #-}++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 a0 = go (g a0) 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')

+ src/Control/Object/Object.hs view

@@ -0,0 +1,170 @@+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE Rank2Types, CPP, TypeOperators #-}+#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.OpenUnion1.Clean+import Data.Typeable+import Control.Applicative++-- | 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)+#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 alias for 'runObject'.+(@-) :: Object f g -> f x -> g (x, Object f g)+(@-) = runObject+{-# INLINE (@-) #-}+infixr 3 @-++-- | The identity object+echo :: Functor f => Object f f+echo = Object (fmap (\x -> (x, echo)))++-- | 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 #-}++-- | 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 #-}++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 #-}++-- | 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+  go s = Object $ liftM (\(a, s') -> (a, go s')) . flip runStateT s . h+{-# 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 @||@++-- | An object that won't accept any messages.+loner :: Functor f => Object Nil f+loner = liftO exhaust++-- | Extend an object by another independent object.+(@|>@) :: Functor g => Object f g -> Object (Union s) g -> Object (f |> Union s) g+p @|>@ q = Object $ fmap (fmap (@|>@q)) . runObject p ||> fmap (fmap (p @|>@)) . runObject q+infixr 3 @|>@++-- | Build a stateful object, sharing out the state.+sharing :: Monad m => (forall a. f a -> StateT s m a) -> s -> Object (State s |> f |> Nil) m+sharing m = go where+  go s = Object $ \k -> liftM (fmap go) $ ($k)+    $ (\n -> return $ runState n s)+    ||> (\e -> runStateT (m e) s)+    ||> exhaust+{-# 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 @!!++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+iterative = unfoldOM iterObject++iterativeT :: Monad m => Object f m -> Object (T.FreeT f m) m+iterativeT = unfoldOM iterTObject++-- | Change the workspace of the object.+transObject :: Functor g => (forall x. f x -> g x) -> Object e f -> Object e g+transObject f = (@>>^f)++-- | 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^>>@)

+ src/Control/Object/Process.hs view

@@ -0,0 +1,94 @@+{-# 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 view

@@ -0,0 +1,67 @@+{-# 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 view

@@ -1,3 +1,4 @@+{-# LANGUAGE Trustworthy #-}
 {-# LANGUAGE DeriveFunctor, DeriveDataTypeable, ConstraintKinds, FlexibleContexts, DataKinds, TypeFamilies, TypeOperators #-}
 -----------------------------------------------------------------------------
 -- |

src/Data/Functor/Request.hs view

@@ -1,3 +1,4 @@+{-# LANGUAGE Trustworthy #-}
 {-# LANGUAGE DeriveFunctor, DeriveDataTypeable, ConstraintKinds, FlexibleContexts, TypeOperators, DataKinds, TypeFamilies #-}
 -----------------------------------------------------------------------------
 -- |