implementation module Gtk.Signal

import StdEnv
import StdMaybe
import StdDebug

import Control.Monad
import Data.Functor
import qualified Data.Map

import Gdk.Events

import Gtk
import Gtk.Internal

instance signalHandler GSignalHandler
where
	signalName h = case h of
		ActivateHandler _      -> "activate"
		ChangedHandler _       -> "changed"
		ClickedHandler _       -> "clicked"
		DeleteEventHandler _   -> "delete-event"
		DestroyHandler _       -> "destroy"
		KeyPressHandler _      -> "key-press-event"
		NextMatchHandler _     -> "next-match"
		PreviousMatchHandler _ -> "previous-match"
		SearchChangedHandler _ -> "search-changed"
		StopSearchHandler _    -> "stop-search"
	signalHandler h = case h of
		ActivateHandler f      -> SHI_Void f
		ChangedHandler f       -> SHI_Void f
		ClickedHandler f       -> SHI_Void f
		DeleteEventHandler f   -> SHI_Pointer_Bool \ev -> toBool <$> f (GdkEvent ev)
		DestroyHandler f       -> SHI_Void f
		KeyPressHandler f      -> SHI_Pointer_Bool \ev -> toBool <$> f (GdkEvent ev)
		NextMatchHandler f     -> SHI_Void f
		PreviousMatchHandler f -> SHI_Void f
		SearchChangedHandler f -> SHI_Void f
		StopSearchHandler f    -> SHI_Void f
	where
		toBool :: !GtkPropagate -> Bool
		toBool p = p=:StopPropagation

installSignalHandler :: !h !w -> GtkM w | signalHandler h & gtkWidget w
installSignalHandler handler widget =
	let handler_internal = signalHandler handler in
	modState (\st ->
		{ st
		& signal_handlers = 'Data.Map'.put (st.signal_counter+1) handler_internal st.signal_handlers
		, signal_counter  = st.signal_counter+1
		}) >>= \{signal_counter=id} ->
	let (GtkWidget w) = gtkWidget widget in
	toState (g_signal_connect (type handler_internal) w (signalName handler) id) >>|
	pure widget
where
	type handler = case handler of
		SHI_Void _                         -> 1
		SHI_Int_Int_Bool _                 -> 2
		SHI_Pointer_Bool _                 -> 3
		SHI_Int_Int_Pointer_Pointer_Bool _ -> 4

instance tune w SignalHandler | gtkWidget w
where
	tune (SignalHandler handler) widget = installSignalHandler handler widget

instance tune w GSignalHandler | gtkWidget w
where
	tune handler widget = installSignalHandler handler widget

// NB: low-level hacking to use and modify the GtkState from within callbacks.
// We use a CAF to keep track of the state. In runGtk, the state is saved with
// saveState. This state is retrieved with retrieveState there (to check
// whether the application should quit), but is also used here (in
// handleSignal) to be used and modified from signal callbacks.
saved_state :: {!GtkState}
saved_state =: {newGtkState}

save_state :: !GtkState !.a -> .a
save_state state env
	# saved_state = mk_unique saved_state
	  saved_state & [0] = state
	| saved_state.[0].return <> state.return
		= abort "internal error in saveState\n"
		= env
where
	mk_unique :: !{!GtkState} -> *{!GtkState}
	mk_unique _ = code {
		no_op
	}

saveState :: GtkM ()
saveState = getState >>= \state -> toState (save_state state)

retrieveState :: GtkM GtkState
retrieveState = modState (const saved_state.[0])

withPossibleCallback :: !(GtkM a) -> GtkM a
withPossibleCallback m = saveState >>| m >>= \r -> retrieveState >>| pure r

foreign export handleSignal
handleSignal :: !Int !{#Int} -> Int
handleSignal id args
	# st = saved_state.[0]
	= case 'Data.Map'.get id st.signal_handlers of
		Nothing
			-> trace_n ("handleSignal: missing signal handler #"+++toString id) 0
		Just handler
			# (GtkM f) = runSignalHandler handler args
			# (i,st) = f st
			-> save_state st i

runSignalHandler :: !SignalHandlerInternal !{#Int} -> GtkM Int
runSignalHandler handler args = case handler of
	SHI_Void f
		-> toInt <$> f
	SHI_Int_Int_Bool f
		-> toInt <$> f args.[0] args.[1]
	SHI_Pointer_Bool f
		-> toInt <$> f args.[0]
	SHI_Int_Int_Pointer_Pointer_Bool f
		-> toInt <$> f args.[0] args.[1] args.[2] args.[3]

instance toInt Bool where toInt b = if b 1 0
instance toInt ()   where toInt _ = 0

addTimeout :: !GtkTimeout !(GtkM Bool) -> GtkM ()
addTimeout interval callback =
	modState (\st ->
		let id = st.timeout_counter+1 in
		{ st
		& timeouts        = 'Data.Map'.put id (wrapped_callback id) st.timeouts
		, timeout_counter = id
		}) >>= \{timeout_counter=id} ->
	case interval of
		Milliseconds ms -> toState (g_timeout_add ms get_handleTimeout_address id)
		Seconds s ->       toState (g_timeout_add_seconds s get_handleTimeout_address id)
where
	wrapped_callback id =
		callback >>= \r ->
		if r
			getState
			(modState \st -> {st & timeouts='Data.Map'.del id st.timeouts}) >>|
		pure r

	get_handleTimeout_address :: Pointer
	get_handleTimeout_address = code {
		pushLc handleTimeout
	}

foreign export handleTimeout
handleTimeout :: !Int -> Int
handleTimeout id
	# st = saved_state.[0]
	= case 'Data.Map'.get id st.timeouts of
		Nothing
			-> trace_n ("handleTimeout: missing function #"+++toString id) 0
		Just (GtkM f)
			# (b,st) = f st
			-> save_state st (if b 1 0)