event-driven (empty) → 0.0.2
raw patch · 5 files changed
+299/−0 lines, 5 filesdep +basedep +monads-tfdep +yjtoolssetup-changed
Dependencies added: base, monads-tf, yjtools
Files
- Control/EventDriven.hs +94/−0
- Control/Talk.hs +156/−0
- LICENSE +27/−0
- Setup.hs +4/−0
- event-driven.cabal +18/−0
+ Control/EventDriven.hs view
@@ -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
+ Control/Talk.hs view
@@ -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
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,4 @@+import Distribution.Simple++main :: IO ()+main = defaultMain
+ event-driven.cabal view
@@ -0,0 +1,18 @@+name: event-driven+version: 0.0.2+license: BSD3+license-file: LICENSE+maintainer: Yoshikuni Jujo <PAF01143@nifty.ne.jp>++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