diff --git a/Control/EventDriven.hs b/Control/EventDriven.hs new file mode 100644 --- /dev/null +++ b/Control/EventDriven.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} + +module Control.EventDriven ( + + EventState +, EventMonad + +, initEvent +, putEvent +, getEventValue + +, delegate + +, bind +, unbind +, runEvent + +, copyContainer +, removeContainer + +) where + +import Control.Talk hiding ( delegate ) +import qualified Control.Talk as T ( delegate ) +import Control.Monad.State ( MonadState, put, get, StateType ) + +type EventState e c = Talker e c +type EventMonad e c = TalkM ( Talker e c, Answer e c ) + +instance MonadState ( EventMonad e c ) where + type StateType ( EventMonad e c ) = c + put = tkApply . SetContainer NoAnswer + get = do tkApply $ GetContainer NoMessage + ContainerIs _ x <- getAnswer + return x + +runValue :: EventMonad e c () +runValue = + get >>= tkApply . PleaseAnswer . ContainerIs ( PleaseAnswer GivemeEvent ) + +initEvent :: c -> ( e -> EventMonad e c () ) -> EventState e c +initEvent iv kb = snd $ flip runTalkMonad initialTalker $ do + tkApply Wakeup + tkApply $ SupplyEventbind GivemeEvent eb + tkApply $ SetContainer GivemeEvent iv + where eb ( Event c ) = kb c >> runValue + eb _ = delegate + +putEvent :: Monad m => + ( c -> m c ) -> Talker e c -> e -> m ( Maybe ( Talker e c ) ) +putEvent doVal tk ev = let ( ans, ntk ) = runTalkMonad ( tkApply $ Event ev ) tk + in processAnswer ntk ans + where + processAnswer tk' ans = + case ans of + ContainerIs m c -> do + nc <- doVal c + let ( nans, ntk ) = runTalkMonad ( put nc >> tkApply m ) tk' + ( stt , _ ) = runTalkMonad ( tkApply Howareyou ) tk' + case stt of + Awake -> processAnswer ntk nans + Asleep -> return Nothing + _ -> error "never occur in processAnswer" + GivemeEvent -> return $ Just tk' + _ -> error "bad" + +getEventValue :: EventState e c -> c +getEventValue es = case fst $ runTalkMonad runValue es of + ContainerIs _ v -> v + _ -> error "Answer is not ContainerIs" + +delegate :: EventMonad e c () +delegate = T.delegate + +bind :: ( e -> EventMonad e c () ) -> EventMonad e c () +bind kb = tkApply ( SupplyEventbind NoAnswer eb ) >> runValue + where eb ( Event c ) = kb c >> runValue + eb _ = T.delegate + +unbind :: EventMonad e c () +unbind = tkApply ( Unbind NoAnswer ) >> runValue + +runEvent :: e -> EventMonad e c () +runEvent cmd = tkApply $ Event cmd + +copyContainer :: EventMonad e c () +copyContainer = tkApply ( CopyContainer NoAnswer ) >> runValue + +removeContainer :: EventMonad e c () +removeContainer = tkApply ( RemoveContainer GivemeEvent ) >> runValue diff --git a/Control/Talk.hs b/Control/Talk.hs new file mode 100644 --- /dev/null +++ b/Control/Talk.hs @@ -0,0 +1,156 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Control.Talk ( + + initialTalker +, tkApply + +, Talker +, TalkM +, Message( .. ) +, Answer( .. ) + +, runTalkMonad +, delegate + +, getAnswer + +) where + +data Talker event container + = Talker { + tkEventbind :: [ Eventbind event container ] , + tkContainerIndex :: Int , + tkContainer :: [ container ] + } + +data Message event container + = Wakeup | Goodnight | Howareyou | Event event | NoMessage | + PleaseAnswer ( Answer event container ) | + SupplyEventbind ( Answer event container ) + ( Eventbind event container ) | + Unbind ( Answer event container ) | + SetContainer ( Answer event container ) container | + GetContainer ( Message event container ) | + ModifyContainer ( Answer event container ) + ( container -> container ) | + CopyContainer ( Answer event container ) | + RemoveContainer ( Answer event container ) + +data Answer event container + = GivemeEventbind | GivemeEvent | Asleep | Awake | NoAnswer | + ContainerIs ( Message event container ) container + +data TalkM t a = + Terminus { runTerminus :: [ TalkM t () ] -> t -> ( a, t ) } | Delegate + +putActions :: [ TalkM t () ] -> TalkM t a -> TalkM t a +putActions tms ( Terminus x ) = Terminus $ \_ -> x tms +putActions _ Delegate = Delegate + +delegate :: TalkM t () +delegate = Terminus $ \( tm : tms ) t -> runTerminus tm tms t + +instance Monad ( TalkM t ) where + return a = Terminus $ \_ t -> ( a, t ) + Terminus x >>= f = Terminus $ \tms t -> + let ( v, t' ) = x tms t + in case f v of + Delegate -> ( error "not allow delegate here", t' ) + term -> runTerminus term tms t' + Delegate >>= _ = Delegate + +type Eventbind event container = + Message event container -> + TalkM ( Talker event container, Answer event container ) () + +runTalkMonad :: + TalkM ( Talker e c, Answer e c ) a -> Talker e c -> ( Answer e c, Talker e c ) +runTalkMonad term t = flipTuple $ snd $ runTerminus term [ ] ( t, NoAnswer ) + where + flipTuple ( x, y ) = ( y, x ) + +put :: t -> TalkM ( t, Answer e c ) () +put t = Terminus $ \_ ( _, a ) -> ( (), ( t, a ) ) + +get :: TalkM ( t, Answer e c ) t +get = Terminus $ \_ ( t, a ) -> ( t , ( t, a ) ) + +putAnswer :: Answer e c -> TalkM ( t, Answer e c ) () +putAnswer a = Terminus $ \_ ( t, _ ) -> ( (), ( t, a ) ) + +getAnswer :: TalkM ( t, Answer e c ) ( Answer e c ) +getAnswer = Terminus $ \_ ( t, a ) -> ( a , ( t, a ) ) + +initialTalker :: Talker event container +initialTalker = Talker { + tkEventbind = [ initialEventbind ] , + tkContainerIndex = 0 , + tkContainer = [ ] + } + +initialEventbind, howareyouEventbind :: Eventbind e c + +howareyouEventbind Howareyou = putAnswer Awake +howareyouEventbind _ = delegate + +initialEventbind Howareyou = putAnswer Asleep +initialEventbind Wakeup = do + tk@Talker { tkEventbind = eventbinds } <- get + put tk { tkEventbind = howareyouEventbind : eventbinds } + putAnswer GivemeEventbind +initialEventbind Goodnight = do + tk <- get + put tk { tkEventbind = [ initialEventbind ] } + putAnswer Asleep +initialEventbind ( PleaseAnswer answer ) = + putAnswer answer +initialEventbind ( SupplyEventbind answer eventbind ) = do + tk@Talker { tkEventbind = eventbinds } <- get + put tk { tkEventbind = eventbind : eventbinds } + putAnswer answer +initialEventbind ( Unbind answer ) = do + tk@Talker { tkEventbind = _ : eventbinds } <- get + put tk { tkEventbind = eventbinds } + putAnswer answer +initialEventbind ( SetContainer answer val ) = do + tk@Talker { tkContainerIndex = i, tkContainer = vals } <- get + put tk { tkContainer = take i vals ++ [ val ] ++ drop ( i + 1 ) vals } + putAnswer answer +initialEventbind ( GetContainer msg ) = do + Talker { tkContainerIndex = i, tkContainer = vals } <- get + if i > - 1 && i < length vals + then putAnswer $ ContainerIs msg ( vals !! i ) + else error "not occur" +initialEventbind ( ModifyContainer answer m ) = do + tk@Talker { tkContainerIndex = i, tkContainer = vals } <- get + put tk { tkContainer = take i vals ++ [ m $ vals !! i ] ++ drop ( i + 1 ) vals } + putAnswer answer +initialEventbind ( CopyContainer answer ) = do + tk@Talker { tkContainerIndex = i, tkContainer = vals } <- get + if i < 0 then error "not occur in CopyContainer" else do + put tk { tkContainerIndex = 0, tkContainer = vals !! i : vals } + putAnswer answer +initialEventbind ( RemoveContainer answer ) = do + tk@Talker { tkContainerIndex = i, tkContainer = vals } <- get + if length vals <= 1 + then tkApply Goodnight + else do + put tk { tkContainerIndex = if i < length vals - 1 then i else i - 1 , + tkContainer = take i vals ++ drop ( i + 1 ) vals } + putAnswer answer +initialEventbind _ = error "not bind" + +tkApply :: Eventbind e c +tkApply msg = do + tk@Talker { tkEventbind = eventbinds } <- get + apply eventbinds tk + where + apply [ ] _ = error "no event bind in tkApply" + apply ( eb : ebs ) tk = case eb msg of + Delegate -> apply ebs tk + term -> putActions ( map ($ msg) ebs ) term + +-- delegate :: TalkM t a +-- delegate = Delegate diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,27 @@ +Copyright (c) 2010, Yoshikuni Jujo +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 the Yoshikuni Jujo nor the names of its + 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 EVEN SHALL THE COPYRIGHT HOLDER 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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,4 @@ +import Distribution.Simple + +main :: IO () +main = defaultMain diff --git a/event-driven.cabal b/event-driven.cabal new file mode 100644 --- /dev/null +++ b/event-driven.cabal @@ -0,0 +1,18 @@ +name: event-driven +version: 0.0.2 +license: BSD3 +license-file: LICENSE +maintainer: Yoshikuni Jujo + +category: Control +synopsis: library for event driven programming +description: library for event driven programming + +build-type: Simple +cabal-version: >= 1.2 + +library + exposed-modules: Control.EventDriven + other-modules : Control.Talk + build-depends : yjtools, monads-tf, base > 4 && < 5 + ghc-options : -Wall