objective 0.5.1 → 0.5.2

raw patch · 5 files changed

+137/−6 lines, 5 filesdep +containersdep +minioperationaldep +profunctors

Dependencies added: containers, minioperational, profunctors

Files

.travis.yml +1/−0
CHANGELOG.md +21/−0
objective.cabal +5/−3
src/Control/Monad/Objective/Class.hs +3/−1
src/Control/Object.hs +107/−2

+ .travis.yml view

@@ -0,0 +1,1 @@+language: haskell

+ CHANGELOG.md view

@@ -0,0 +1,21 @@+0.5.2
+-----
+* Added Process
+* Added `runSequential`, `sequential` for operational monad
+
+0.5.1
+-----
+* Added PushPull functor
+* Removed `sequential`
+
+0.5
+-----
+* Lift has gone
+* Use elevator instead of Lift
+* Moved Request to a separate module
+
+0.4
+-----
+* Added Request functor along with Lift
+* Supported "extensible" objects using open unions
+* AccessT is now obsolete

objective.cabal view

@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/
 
 name:                objective
-version:             0.5.1
+version:             0.5.2
 synopsis:            Extensible objects
 description:         Stateful effect transducer
 homepage:            https://github.com/fumieval/objective
@@ -13,7 +13,9 @@ -- copyright:           
 category:            Control
 build-type:          Simple
--- extra-source-files:  
+extra-source-files:
+  CHANGELOG.md
+  .travis.yml
 cabal-version:       >=1.10
 
 library
@@ -26,7 +28,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
+  build-depends:       base >=4.5 && <5, transformers >= 0.3 && <0.5, clean-unions < 0.2, elevator, containers, minioperational >= 0.4 && <0.5, profunctors >= 4.0 && <5
   ghc-options: -Wall
   hs-source-dirs:      src
   default-language:    Haskell2010

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

@@ -33,6 +33,7 @@   -- | Add an object to the environment.
   new :: Object e n -> m (Instance e n m)
 
+-- | Invoke a method.
 (.-) :: (Monad n
   , Elevate n m
   , MonadObjective m
@@ -41,6 +42,7 @@ 
 infix 3 .-
 
+-- | Similar to '(.-)', but also lifts the method according to the instance.
 (.^) :: (Elevate e f
   , Monad n
   , Elevate n m
@@ -48,4 +50,4 @@   , Elevate m g) => Instance f n m -> e a -> g a
 a .^ e = a .- elevate e
 
-infix 3 .^+infix 3 .^

src/Control/Object.hs view

@@ -27,10 +27,16 @@   (.>>.),
   transObject,
   adaptObject,
-  -- * Extensible objects
+  sequential,
+  runSequential,
+  -- * Multifunctional objects
   loner,
   (.|>.),
-  sharing
+  sharing,
+  -- * Patterns
+  flyweight,
+  Process(..),
+  _Process
   )
 where
 
@@ -39,6 +45,13 @@ import Data.Typeable
 import Control.Applicative
 import Data.OpenUnion1.Clean
+import qualified Data.Map as Map
+import Data.Functor.Request
+import Control.Monad.Operational.Mini
+import Control.Arrow
+import qualified Control.Category as C
+import Data.Profunctor
+import Data.Monoid
 
 -- | The type 'Object e m' represents objects which can handle messages @e@, perform actions in the environment @m@.
 -- It can be thought of as an automaton that converts effects.
@@ -120,3 +133,95 @@ 
 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)
+
+runSequential :: Monad m => Object e m -> ReifiedProgram e a -> m (a, Object e m)
+runSequential obj (Return a) = return (a, obj)
+runSequential obj (e :>>= cont) = runObject obj e >>= \(a, obj') -> runSequential obj' (cont a)
+
+-- | Let object handle sequential methods.
+sequential :: Monad m => Object e m -> Object (ReifiedProgram e) m
+sequential obj = Object $ liftM (fmap sequential) . runSequential obj
+
+-- | 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)
+
+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)
+
+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' = left
+  {-# INLINE left' #-}
+  right' = 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