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

7 files changed, 131 insertions, 98 deletions

diff --git a/src/Gtk/Internal.dcl b/src/Gtk/Internal.dcl
index 69410d4..b4d72b3 100644
--- a/src/Gtk/Internal.dcl
+++ b/src/Gtk/Internal.dcl
@@ -4,16 +4,11 @@ from StdMaybe import :: Maybe
 
 from System._Pointer import :: Pointer
 
-:: GSignalArgs =
-	{ sig_id :: !Int
-	}
-
 g_free :: !Pointer !.a -> .a
 
 g_object_unref :: !Pointer !.a -> .a
 
-g_signal_connect_void :: !Pointer !String !Int !.a -> .a
-g_signal_pop :: !.a -> (!Maybe GSignalArgs, !.a)
+g_signal_connect :: !Int !Pointer !String !Int !.a -> .a
 
 gtk_box_new :: !Bool !Int !.a -> (!Pointer, !.a)
 gtk_box_pack_start :: !Pointer !Pointer !Bool !Bool !Int !.a -> .a
diff --git a/src/Gtk/Internal.icl b/src/Gtk/Internal.icl
index 988ab3a..4be7f70 100644
--- a/src/Gtk/Internal.icl
+++ b/src/Gtk/Internal.icl
@@ -18,27 +18,12 @@ g_object_unref p env = code {
 	ccall g_object_unref "p:V:A"
 }
 
-g_signal_connect_void :: !Pointer !String !Int !.a -> .a
-g_signal_connect_void widget signal id env = connect widget (packString signal) id env
+g_signal_connect :: !Int !Pointer !String !Int !.a -> .a
+g_signal_connect type widget signal id env = connect type widget (packString signal) id env
 where
-	connect :: !Pointer !String !Int !.a -> .a
-	connect _ _ _ _ = code {
-		ccall clean_g_signal_connect_void "psI:V:A"
-	}
-
-g_signal_pop :: !.a -> (!Maybe GSignalArgs, !.a)
-g_signal_pop env
-	# (sig,env) = pop env
-	| sig == 0
-		= (Nothing, env)
-	# (id,sig) = readIntP sig (IF_INT_64_OR_32 8 4)
-	| sig == 0 // force evaluation
-		= abort "Internal error in g_signal_pop\n"
-		= (Just {sig_id=id}, env)
-where
-	pop :: !.a -> (!Pointer, !.a)
-	pop env = code {
-		ccall clean_g_signal_pop ":p:A"
+	connect :: !Int !Pointer !String !Int !.a -> .a
+	connect _ _ _ _ _ = code {
+		ccall clean_g_signal_connect "IpsI:V:A"
 	}
 
 gtk_box_new :: !Bool !Int !.a -> (!Pointer, !.a)
@@ -180,7 +165,7 @@ where
 
 gtk_main_iteration :: !.a -> (!Bool, !.a)
 gtk_main_iteration env = code {
-	ccall gtk_main_iteration ":I:A"
+	ccall gtk_main_iteration "G:I:A"
 }
 
 gtk_main_quit :: !.a -> .a
diff --git a/src/Gtk/Signal.dcl b/src/Gtk/Signal.dcl
index 32ebc08..e4ce83b 100644
--- a/src/Gtk/Signal.dcl
+++ b/src/Gtk/Signal.dcl
@@ -1,15 +1,27 @@
 definition module Gtk.Signal
 
-from Gtk.State import :: GtkM
+from System._Pointer import :: Pointer
+
+from Gtk.State import :: GtkM, :: GtkState
 from Gtk.Widgets import class gtkWidget
 
-:: GSignalHandlerFunction :== GtkM ()
+class signalHandler h
+where
+	signalName :: !h -> String
+	signalHandler :: !h -> SignalHandlerInternal
 
 :: GSignalHandler
-	= DestroyHandler  !GSignalHandlerFunction
-	| ActivateHandler !GSignalHandlerFunction
+	= DestroyHandler  !(GtkM ())
+	| ActivateHandler !(GtkM ())
+
+instance signalHandler GSignalHandler
+
+:: SignalHandlerInternal
+	= SHI_Void !(GtkM ())
+	| SHI_Int_Int_Pointer_Pointer_Bool !(Int Int Pointer Pointer -> GtkM Bool)
 
-:: GSignalHandlerInternal
-	= GSHI_Void !GSignalHandlerFunction
+installSignalHandler :: !h !w -> GtkM w | signalHandler h & gtkWidget w
 
-installSignalHandler :: !GSignalHandler !w -> GtkM w | gtkWidget w
+saveState :: GtkM ()
+retrieveState :: GtkM GtkState
+handleSignal :: !Int !{#Int} -> Int
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
diff --git a/src/Gtk/State.dcl b/src/Gtk/State.dcl
index 2a5396c..5c8d039 100644
--- a/src/Gtk/State.dcl
+++ b/src/Gtk/State.dcl
@@ -7,12 +7,12 @@ from Control.Monad import class Monad
 from Data.Functor import class Functor
 from Data.Map import :: Map
 
-from Gtk.Signal import :: GSignalHandlerInternal
+from Gtk.Signal import :: SignalHandlerInternal
 
 :: GtkState =
 	{ world           :: !()
 	, return          :: !Bool
-	, signal_handlers :: !Map Int GSignalHandlerInternal
+	, signal_handlers :: !Map Int SignalHandlerInternal
 	, signal_counter  :: !Int
 	}
 
diff --git a/src/Gtk/State.icl b/src/Gtk/State.icl
index f6e56fe..405b8b4 100644
--- a/src/Gtk/State.icl
+++ b/src/Gtk/State.icl
@@ -54,30 +54,20 @@ where
 runGtk :: !(GtkM a) !*World -> (!a, !*World)
 runGtk f w = (getResult (wrapped_f newGtkState), w)
 where
-	(GtkM wrapped_f) = toState gtk_init >>| f >>= \x -> main >>| pure x
-
 	getResult :: !(!a, !GtkState) -> a
 	getResult (r,_) = r
 
-	main =
+	(GtkM wrapped_f) =
+		toState gtk_init >>|
+		f >>= \x ->
+		saveState >>|
+		main x
+
+	main x =
 		toStateR gtk_main_iteration >>|
-		handle_signals >>|
-		getState >>= \{return}
-			| return    -> pure ()
-			| otherwise -> main
-
-	handle_signals =
-		toStateR g_signal_pop >>= \sig_args -> case sig_args of
-			Nothing ->
-				pure ()
-			Just sig_args ->
-				getState >>= \{signal_handlers} ->
-				let (Just handler) = 'Data.Map'.get sig_args.sig_id signal_handlers in
-				run handler >>|
-				handle_signals
-			with
-				run handler = case handler of
-					GSHI_Void st -> st
+		retrieveState >>= \{return}
+			| return    -> pure x
+			| otherwise -> main x
 
 getState :: GtkM GtkState
 getState = GtkM \st -> (st,st)
diff --git a/src/clean_gtk_support.c b/src/clean_gtk_support.c
index c725dfd..f1672ed 100644
--- a/src/clean_gtk_support.c
+++ b/src/clean_gtk_support.c
@@ -2,52 +2,42 @@
 
 typedef long CleanInt;
 
-void *safe_malloc(size_t n) {
+extern CleanInt handleSignal (CleanInt,CleanInt*);
+
+static void *safe_malloc(size_t n) {
 	void *ptr=malloc (n);
 	if (ptr==NULL)
 		perror ("malloc");
 	return ptr;
 }
 
-struct clean_g_signal {
-	GtkWidget *target;
-	CleanInt id;
-	struct clean_g_signal *next;
-};
-
-static struct clean_g_signal *signal_queue=NULL;
-static struct clean_g_signal *last_signal=NULL;
-
-static struct clean_g_signal *clean_g_signal_push (void) {
-	struct clean_g_signal *signal=safe_malloc (sizeof(struct clean_g_signal));
-
-	if (last_signal!=NULL)
-		last_signal->next=signal;
-	else if (signal_queue==NULL)
-		signal_queue=signal;
-
-	last_signal=signal;
-
-	return signal;
+static void clean_g_signal_handler_void (GtkWidget *target,gpointer data) {
+	CleanInt args[2];
+	args[0]=0;
+	handleSignal ((CleanInt)data,&args[2]);
 }
 
-struct clean_g_signal *clean_g_signal_pop (void) {
-	struct clean_g_signal *signal=signal_queue;
-
-	if (signal_queue==NULL)
-		last_signal=NULL;
-
-	signal_queue=NULL;
-
-	return signal;
+static CleanInt clean_g_signal_handler_int_int_pointer_pointer_bool
+		(GtkWidget *target,gint i1,gint i2,gpointer p1,gpointer p2,gpointer data) {
+	CleanInt args[6];
+	args[0]=4;
+	args[2]=i1;
+	args[3]=i2;
+	args[4]=(CleanInt)p1;
+	args[5]=(CleanInt)p2;
+	return handleSignal ((CleanInt)data,&args[2]);
 }
 
-static void clean_g_signal_handler_void (GtkWidget *target,gpointer data) {
-	struct clean_g_signal *signal=clean_g_signal_push();
-	signal->target=target;
-	signal->id=(CleanInt)data;
-}
+void clean_g_signal_connect (int type,GtkWidget *widget,char *signal,CleanInt id) {
+	void *callback=NULL;
+
+	switch (type) {
+		case  1: callback=&clean_g_signal_handler_void; break;
+		case  2: callback=&clean_g_signal_handler_int_int_pointer_pointer_bool; break;
+		default:
+			fprintf (stderr,"clean_g_signal_connect: illegal type %d\n",type);
+			return;
+	}
 
-void clean_g_signal_connect_void (GtkWidget *widget,char *signal,CleanInt id) {
-	g_signal_connect (widget,signal,G_CALLBACK (clean_g_signal_handler_void),(gpointer)id);
+	g_signal_connect (widget,signal,G_CALLBACK (callback),(gpointer)id);
 }