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