objective (empty) → 0.0

raw patch · 5 files changed

+145/−0 lines, 5 filesdep +basedep +comonaddep +transformerssetup-changed

Dependencies added: base, comonad, transformers, trivia

Files

LICENSE +30/−0
Setup.hs +2/−0
objective.cabal +25/−0
src/Control/Monad/Objective/Class.hs +25/−0
src/Control/Object.hs +63/−0

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright (c) 2014, Fumiaki Kinoshita
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Fumiaki Kinoshita nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple
+main = defaultMain

+ objective.cabal view

@@ -0,0 +1,25 @@+-- Initial objective.cabal generated by cabal init.  For further 
+-- documentation, see http://haskell.org/cabal/users-guide/
+
+name:                objective
+version:             0.0
+synopsis:            Extensible objects
+-- description:         
+homepage:            https://github.com/fumieval/objective
+license:             BSD3
+license-file:        LICENSE
+author:              Fumiaki Kinoshita
+maintainer:          Fumiaki Kinoshita <fumiexcel@gmail.com>
+-- copyright:           
+category:            Control
+build-type:          Simple
+-- extra-source-files:  
+cabal-version:       >=1.10
+
+library
+  exposed-modules:     Control.Object, Control.Monad.Objective.Class
+  -- other-modules:       
+  other-extensions:    MultiParamTypeClasses, KindSignatures, TypeFamilies
+  build-depends:       base >=4.5 && <5, trivia, comonad, transformers >= 0.3 && <0.5
+  hs-source-dirs:      src
+  default-language:    Haskell2010

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

@@ -0,0 +1,25 @@+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module Control.Monad.Objective.Class where
+import Control.Object
+import Control.Monad.Trans.State
+
+infix 3 .-
+infix 3 .&
+
+class Monad m => MonadObjective s m where
+  type Base m :: * -> *
+  data Control s (e :: * -> *)
+  -- | Send a message to the pointed one.
+  (.-) :: Control s e -> e a -> m a
+  -- | Add an object to the environment.
+  invoke :: Object e (Base m) -> m (Control s e)
+
+(.&) :: (MonadObjective k m, Stateful s e) => Control k e -> StateT s m a -> m a
+c .& m = do
+  s <- c .- get_
+  (a, s') <- runStateT m s
+  c .- put_ s'
+  return a

+ src/Control/Object.hs view

@@ -0,0 +1,63 @@+{-# LANGUAGE Rank2Types, MultiParamTypeClasses, FlexibleInstances #-}
+{-# LANGUAGE DeriveFunctor, DeriveDataTypeable #-}
+module Control.Object where
+
+import Control.Comonad.Zero
+import Control.Comonad
+import Control.Monad.Trans.State
+import Control.Monad
+import Data.Typeable
+
+-- | The type 'Object e m' represents objects which can handle messages 'e', perform actions in the 'Monad' 'm'.
+-- It can be thought of as a function where both domain and codomain are effects.
+-- Thus, it can be composed just like functions using '(.>>.)' (not often needed); the identity element is `echo`.
+newtype Object e m = Object { runObject :: forall x. e x -> m (x, Object e m) } deriving Typeable
+
+-- | Change the workspace of the object.
+transObject :: Monad n => (forall x. m x -> n x) -> Object e m -> Object e n
+transObject f (Object m) = Object $ liftM (fmap (transObject f)) . f . m
+
+-- | Apply a function to the messages coming into the object.
+adaptObject :: Monad m => (forall x. e x -> f x) -> Object f m -> Object e m
+adaptObject f (Object m) = Object $ liftM (fmap (adaptObject f)) . m . f
+
+-- | Parrots messages given.
+echo :: Functor e => Object e e
+echo = Object (fmap (\x -> (x, echo)))
+
+-- | Compose two objects (aka Dependency Injection).
+(.>>.) :: Monad n => Object e m -> Object m n -> Object e n
+Object m .>>. Object n = Object $ \e -> liftM (\((x, m'), n') -> (x, m' .>>. n')) $ n (m e)
+
+-- | Build an object.
+oneshot :: (Functor e, Monad m) => (forall a. e (m a) -> m a) -> Object e m
+oneshot m = go where
+  go = Object $ \e -> m (fmap return e) >>= \a -> return (a, go)
+{-# INLINE oneshot #-}
+
+-- | Build a stateful object.
+stateful :: (Functor e, Monad m) => (forall a. e (StateT s m a) -> StateT s m a) -> s -> Object (AccessT s e) m
+stateful m = go where
+  go s = Object $ \k -> liftM (fmap go) $ case k of
+    LiftAccessT e -> runStateT (m (fmap return e)) s
+    Get cont -> return (cont s, s)
+    Put s' cont -> return (cont, s')
+{-# INLINE stateful #-}
+
+-- | Like 'MonadState', but doesn't require 'Monad' as a prerequisite.
+class Stateful s f where
+  get_ :: f s
+  put_ :: s -> f ()
+
+-- | Inflicts external state accessibility to arbitrary effects.
+data AccessT s f a = Get (s -> a) | Put s a | LiftAccessT (f a) deriving (Functor, Typeable)
+
+instance Stateful s (AccessT s f) where
+  get_ = Get id
+  put_ s = Put s ()
+
+variable :: Monad m => s -> Object (AccessT s Zero) m
+variable s = Object $ \x -> case x of
+  Get cont -> return (cont s, variable s)
+  Put s' cont -> return (cont, variable s')
+  LiftAccessT e -> return (extract e, variable s)