# ***********************************************************************
#
# Project: sml/Tk: an Tk Toolkit for sml
# Author: Burkhart Wolff, University of Bremen
# Date: 25.7.95
# Purpose of this file: Functions related to "Tk-Namings"
#
# ***********************************************************************
# Compiled by:
# src/lib/tk/src/tk.sublibpackage bind
: (weak) Bind # Bind is from src/lib/tk/src/bind.api{
stipulate
include package basic_tk_types;
herein
infix my 20 bind_elem ;
fun bind_eq (EVENT_CALLBACK (k1, c1)) (EVENT_CALLBACK (k2, c2))
=
k1 == k2;
fun bind_elem_h (b,[]) => FALSE;
bind_elem_h (b, (x . xs)) => bind_eq b x or bind_elem_h (b, xs);
end;
my
(bind_elem) = bind_elem_h;
fun no_dbl_p [] => TRUE;
no_dbl_p (x . xs) => not (x bind_elem xs) andalso no_dbl_p xs;
end;
# ***********************************************************************
#
# Convert Events to strings
#
# *********************************************************************** *)
fun sp_to_str NULL => "";
sp_to_str (THE i) => "-" + (int::to_string i);
end;
stipulate
fun event_name' FOCUS_IN => "FocusIn";
event_name' FOCUS_OUT => "FocusOut";
event_name' CONFIGURE => "Configure";
event_name' MAP => "Map";
event_name' UNMAP => "Unmap";
event_name' VISIBILITY => "Visibility";
event_name' DESTROY => "Destroy";
event_name' (KEY_PRESS str) => "KeyPress-" + str;
event_name' (KEY_RELEASE str) => "KeyRelease-" + str;
event_name' (BUTTON_PRESS sp) => "ButtonPress" + (sp_to_str sp);
event_name' (BUTTON_RELEASE sp) => "ButtonRelease" + (sp_to_str sp);
event_name' ENTER => "Enter";
event_name' LEAVE => "Leave";
event_name' MOTION => "Motion";
event_name' (DEPRECATED_EVENT str) => str;
event_name' (SHIFT (KEY_PRESS s))=> "Shift-" + s;
event_name' (SHIFT e) => "Shift-" + (event_name' e);
event_name' (CONTROL (KEY_PRESS s))=> "Control-" + s;
event_name' (CONTROL e) => "Control-" + (event_name' e);
event_name' (LOCK e) => "Lock-" + (event_name' e);
event_name' (ANY e) => "Any-" + (event_name' e);
event_name' (DOUBLE e) => "Double-" + (event_name' e);
event_name' (TRIPLE e) => "Triple-" + (event_name' e);
event_name' (MODIFIER_BUTTON (i, e)) => "Button" + (int::to_string i) + "-" + (event_name' e);
event_name' (META e) => "Meta-" + (event_name' e);
event_name' (ALT e) => "Alt-" + (event_name' e);
event_name' (MOD3 e) => "Mod3-" + (event_name' e);
event_name' (MOD4 e) => "Mod4-" + (event_name' e);
event_name' (MOD5 e) => "Mod5-" + (event_name' e);
end;
herein
fun event_name event
=
"<" + (event_name' event) + ">";
end;
/* ***********************************************************************
selectors on Event_Callback's
*********************************************************************** */
fun sel_event (EVENT_CALLBACK (k, c))
=
k;
fun sel_action (EVENT_CALLBACK (k, c))
=
c;
fun get_action_by_name name [] => (\\ e => (); end );
get_action_by_name name (x . xs) =>
if (event_name (sel_event x) == name ) sel_action x;
else get_action_by_name name xs;fi; end;
/* ***********************************************************************
defaults for Event_Callback's
*********************************************************************** */
# DefaultBindPack: Widget_Type -> Key -> String
fun default_bind_pack _ _ = "";
/* ***********************************************************************
updating Event_Callback's
*********************************************************************** */
fun add_one_bind (c, []) => [c];
add_one_bind (c, x . xs) => if (bind_eq x c ) c . xs; else x . add_one_bind (c, xs);fi; end;
fun add old new
=
list::fold_backward add_one_bind old new;
fun delete_one_bind cs c
=
list::filter (not o (bind_eq c)) cs;
fun delete old new
=
map sel_event (fold_forward (basic_utilities::twist (basic_utilities::uncurry (delete_one_bind))) old new);
/* ***********************************************************************
Event_Callback's ==> Tcl
*********************************************************************** */
# packOneWindowBind: Window_ID -> Event_Callback -> String
fun pack_one_window_bind w (EVENT_CALLBACK (e, _))
=
if (gui_state::is_init_window w)
"bind . " + (event_name e) + " { if {\"%W\" == \".\"} {" +
com::comm_to_tcl + " \"WinNaming " + w + " " + (event_name e) + " " +
tk_event::show() + " \"}}\n";
else
"bind ." + w + " " + (event_name e) + " { if {\"%W\" == \"." + w +
"\"} {" + com::comm_to_tcl + " \"WinNaming " + w + " " + (event_name e) +
" " + tk_event::show() + " \"}}\n";
fi;
/* packWindow: Window_ID -> Event_Callback List -> String List
*/
fun pack_window w bs
=
map (pack_one_window_bind w) bs;
/* unpackOneWindowBind: TclPath -> Event -> String
*/
fun unpack_one_window_bind tp e
=
"bind " + tp + " " + (event_name e) + " {}";
/* unpackWindow: TclPath -> Event List -> String List
*/
fun unpack_window tp es
=
map (unpack_one_window_bind tp) es;
/* packOneWidgetBind: TclPath -> IntPath -> Event_Callback -> String
*/
fun pack_one_widget_bind tp (w, p) (EVENT_CALLBACK (e, com))
=
"bind " + tp + " " + (event_name e) + " {" + com::comm_to_tcl +
" \"WNaming " + w + " " + p + " " + (event_name e) + " " +
tk_event::show() + " \"}\n";
/* packWidget: TclPath -> IntPath -> Event_Callback List -> String List
*/
fun pack_widget tp ip bs
=
map (pack_one_widget_bind tp ip) bs;
/* packOneCanvasBind: TclPath -> IntPath -> Canvas_Item_ID -> Event_Callback -> String
*/
fun pack_one_canvas_bind tp (w, p) cid (EVENT_CALLBACK (e, com))
=
tp + " bind " + cid + " " + (event_name e) + " {" + com::comm_to_tcl +
" \"CNaming " + w + " " + p + " " + cid + " " + (event_name e) +
" " + tk_event::show() + " \"}\n";
/* packCanvas: TclPath -> IntPath -> Event_Callback List -> String List
*/
fun pack_canvas tp ip cid bs
=
map (pack_one_canvas_bind tp ip cid) bs;
/* packOneTagBind: TclPath -> IntPath -> Text_Item_ID -> Event_Callback -> String
*/
fun pack_one_tag_bind tp (w, p) aid (EVENT_CALLBACK (e, com))
=
tp + " tag bind " + aid + " " + (event_name e) + " {" + com::comm_to_tcl +
" \"TNaming " + w + " " + p + " " + aid + " " + (event_name e) +
" " + tk_event::show() + " \"}\n";
/* packTag: TclPath -> IntPath -> Event_Callback List -> String List
*/
fun pack_tag tp ip tn bs
=
map (pack_one_tag_bind tp ip tn) bs;
/* unpackOneBind: TclPath -> Widget_Type -> Event -> String
*/
fun unpack_one_widget_bind tp wt e
=
"bind " + tp + " " + (event_name e) + " {" + default_bind_pack wt e + "}" +
"\n";
/* unpackWidget: TclPath -> Widget_Type -> Event List -> String List:
*/
fun unpack_widget tp wt es
=
map (unpack_one_widget_bind tp wt) es;
end;
};