{-# 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