# event-loop.pkg
# (C) 1996-99, Bremen Institute for Safe Systems, Universitaet Bremen
# Author: bu/stefan (Last modification $Author: 2cxl $)
# Compiled by:
# src/lib/tk/src/tk.sublib#############################################################################
#
# tk event handler.
#
# This module implements the tk event handling mechanism -- i.e.
# the bit which listens to something coming from Tcl, figures out which
# naming this corresponds to, and calls the corresponding SML function.
#
# Further, there are the two functions, start_tcl and start_tcl_and_trap_tcl_exceptions, which
# launch the application loop and the GUI.
#
# $Date: 2001/03/30 13:39:10 $
# $Revision: 3.0 $
#############################################################################
### "A day will come when beings,
### now latent in our thoughts
### and hidden in our loins,
### shall stand upon Earth
### as a footstool and laugh,
### and reach out their hands
### amidst the stars."
###
### -- H.G. Wells, 1902
package event_loop
: (weak) Event_Loop # Event_Loop is from src/lib/tk/src/event-loop.api{
include package basic_utilities;
include package basic_tk_types;
include package gui_state;
#############################################################################
#
# tk's main event handler.
#
# This is the 'raw' event handler. Below, we wrap the interrupt handler
# around this, so diverging event handling functions can be interrupted
#############################################################################
fun do_interpret_event s
=
{ my kind . window . path . ss
=
string_util::words s;
case kind
"Command"
=>
widget_tree::select_command_path (window, path) ();
"MCommand"
=>
{ mitpath = config::read_casc_path (hd ss);
widget_tree::select_mcommand_mpath (window, path) mitpath ();
};
"SCommand"
=>
{ newval = the (float::from_string (hd (ss)));
widget_tree::select_scommand_path (window, path) newval;
};
"Destroy"
=>
{ key = path; # no path in Window Namings
ev_v = hd (ss);
tkev = tk_event::unparse ev_v;
wind = (THE (gui_state::get_window_gui window))
except WINDOWS t => NULL; end ;
case wind
THE wind => (window::select_bind_key_path window key)tkev;
NULL => ();
esac;
if (gui_state::is_init_window window)
com::exit_tcl ();
window::delete_all_gui;
else
window::delete_gui window;
fi;
}
except
WINDOWS t = ();
"WinNaming"
=>
{ key = path; # no path in Window Namings
ev_v = hd (ss);
tkev = tk_event::unparse ev_v;
wind = (THE (gui_state::get_window_gui window))
except
WINDOWS t = NULL;
case wind
THE wind => (window::select_bind_key_path window key) tkev;
NULL => debug::print 1 "got NONEX-WNaming\n";
esac;
}
except
WINDOWS t = debug::warning ("Exception WINDOWS: " + t);
"WNaming"
=>
{ my key . ev_v . _ = ss;
tkev = tk_event::unparse ev_v;
wid = (THE (widget_tree::get_widget_guipath (window, path)))
except
WINDOWS t => NULL;
WIDGET t => NULL;
end ;
case wid
THE wid => (widget_tree::select_bind_key_path (window, path) key) tkev;
NULL => debug::print 1 "got NONEX-WNaming\n";
esac;
}
except
WIDGET t => debug::warning ("Exception WIDGET: " + t);
canvas_item::CANVAS_ITEM t => debug::warning ("Exception CANVAS_ITEM: " + t);
end;
"CNaming"
=>
{ my cid . key . ev_v . _ = ss;
tkev = tk_event::unparse ev_v;
wid = (THE (widget_tree::get_widget_guipath (window, path)))
except
WINDOWS t => NULL;
WIDGET t => NULL;
end ;
case wid
THE wid => (canvas_item::get_naming_by_name wid cid key) tkev;
NULL => debug::print 1 ("got NONEX-CNaming\n");
esac;
}
except
canvas_item::CANVAS_ITEM t => debug::warning("Exception CANVAS_ITEM: " + t);
WIDGET t => debug::warning("Exception WIDGET: " + t);
end;
"TNaming"
=>
{ my tn . key . ev_v . _ = ss;
tkev = tk_event::unparse ev_v;
wid = (THE (widget_tree::get_widget_guipath (window, path)))
except
WINDOWS t => NULL;
WIDGET t => NULL;
end;
case wid
THE wid => (text_item::get_naming_by_name wid tn key) tkev;
NULL => debug::print 1 ("got NONEX-TNaming\n");
esac;
}
except
canvas_item::CANVAS_ITEM t => debug::warning("Exception CANVAS_ITEM: " + t);
WIDGET t => debug::warning("Exception WIDGET: " + t);
end;
"VValue"
=>
debug::print 1 ("event_loop::interpret_event: someone missed VValue");
"ERROR"
=>
{ debug::print 1 ("event_loop::interpret_event: got Tcl Error: \"" +
(string::join " " (window . path . ss)) + "\"");
raise exception TCL_ERROR ("event_loop::interpret_event: got Tcl Error: \"" +
(string::join " " (window . path . ss)) + "\"");
};
_ =>
debug::warning ("Tcl junk sent to tk: " + s);
esac;
};
# except e => debug::warning ("Event::interpret_event: exception " + (exception_name e) +
# " raised (and ignored) with event: " + s)
# **********************************************************************
#
# Interrupt Handling
#
# I refer the honourable gentleman to the answer I gave earlier.
#
lcnt = REF 0;
Intr_Listener = MAKE_IL Int;
listeners = REF [(0, \\()= file::print "[tk] Interrupt.\n")];
/* Register an interrupt listener, i.e. a function f: Void-> Void to be
* called when an interrupt occurs. Use sparingly if ever. */
fun register_signal_callback h
=
{ id= inc lcnt;
(make_il id) then (listeners := *listeners @ [ (id, h) ]);
};
# Deregister this listener -- don't call us, we'll call you:
#
fun deregister_signal_callback (make_il id)
=
listeners := list::filter (\\ (lid, _)=> not (lid == id); end ) *listeners;
# Call all the interrupt listeners:
#
fun get_listeners s
=
list::fold_forward (o) (\\ x= x) (map #2 *listeners) s;
# The 'real' event handler is this one:
#
fun interpret_event s
=
sys_dep::interruptable do_interpret_event get_listeners s;
########################################################################
# The main application loop
#
# For the wish, we sometimes need to read Tcl values (e.g.
# readCoords, get_val) and while we do so, other Tcl namings may fire.
# In this case, these Tcl answers are stored in the COM_state, and
# are processed separately by readAnswerFromTcl below.
########################################################################
fun app_loop _
=
while (com_state::wish_active()) {
com::read_answer_from_tcl interpret_event;
interpret_event (com::get_line());
};
/***********************************************************************
*
* Launching the application loop.
*
*/
fun start_tcl ws
=
{ com::init_tcl();
apply window::open_w ws;
app_loop();
};
fun start_tcl_and_trap_tcl_exceptions ws
=
{ start_tcl ws;
"";
}
except WIDGET t => "WIDGET: " + t;
canvas_item::CANVAS_ITEM t => "CANVAS_ITEM: " + t;
WINDOWS t => "WINDOWS: " + t;
CONFIG t => "CONFIG: " + t;
basic_tk_types::TCL_ERROR t => "TCL_ERROR: " + t;
text_item::TEXT_ITEM t => "TEXT_ITEM: " + t;
end ;
};