Restructure signal handling: callbacks cannot be delayed because they may have pointer arguments referring to the stack; also, some callbacks expect a return value

1 files changed, 66 insertions, 5 deletions

diff --git a/src/Gtk/Signal.icl b/src/Gtk/Signal.icl
index 119829a..e51614c 100644
--- a/src/Gtk/Signal.icl
+++ b/src/Gtk/Signal.icl
@@ -1,15 +1,28 @@
 implementation module Gtk.Signal
 
 import StdEnv
+import StdMaybe
+import StdDebug
 
 import Control.Monad
+import Data.Functor
 import qualified Data.Map
 
 import Gtk
 import Gtk.Internal
 
-installSignalHandler :: !GSignalHandler !w -> GtkM w | gtkWidget w
+instance signalHandler GSignalHandler
+where
+	signalName h = case h of
+		DestroyHandler _  -> "destroy"
+		ActivateHandler _ -> "activate"
+	signalHandler h = case h of
+		DestroyHandler f  -> SHI_Void f
+		ActivateHandler f -> SHI_Void f
+
+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
@@ -17,9 +30,57 @@ installSignalHandler handler widget =
 		}) >>|
 	getState >>= \{signal_counter=id} ->
 	(toState case handler_internal of
-		GSHI_Void _ -> g_signal_connect_void (toPtr (gtkWidget widget)) signal_name id) >>|
+		SHI_Void _
+			-> g_signal_connect 1 (toPtr (gtkWidget widget)) (signalName handler) id
+		SHI_Int_Int_Pointer_Pointer_Bool _
+			-> g_signal_connect 2 (toPtr (gtkWidget widget)) (signalName handler) id) >>|
 	pure 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
-	(signal_name,handler_internal) = case handler of
-		DestroyHandler f  -> ("destroy", GSHI_Void f)
-		ActivateHandler f -> ("activate",GSHI_Void f)
+	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])
+
+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_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