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