widget.sa
Generated by gen_html_sa_files from ICSI. Contact gomes@icsi.berkeley.edu for details
---------------------------> Sather 1.1 source file <--------------------------
-- widget.sa: Widget abstract and helper classes
-- Author: Benedict A. Gomes <gomes@samosa.ICSI.Berkeley.EDU>
-- Copyright (C) 1995, International Computer Science Institute
-- COPYRIGHT NOTICE: This code is provided WITHOUT ANY WARRANTY
-- and is subject to the terms of the SATHER LIBRARY GENERAL PUBLIC
-- LICENSE contained in the file: Sather/Doc/License of the
-- Sather distribution. The license is also available from ICSI,
-- 1947 Center St., Suite 600, Berkeley CA 94704, USA.
abstract class $TK_WIDGET
abstract class $TK_WIDGET is
-- Widget abstraction. Most widgets correspond directly to their
-- Tk equivalents, but some consist of a frame + the Tk widget + optional
-- scroll bars. The standard widgets get their functionality from
-- TK_WIDGET_INCL, whereas these scrollable widgets use SCOLLABLE_WIDGET_INCL
widget_name: STR;
-- The name of the widget itself. With one exception, the widget name
-- and the path name are the same. The exception is the root window
-- "." Its widget name is "." but the path used by its children is ""
-- Beware of this difference when destroying windows, binding events
-- to windows etc.
path_name: STR;
-- The name of the path to the widget, including the widget itself.
-- Used for creating children of a widget
act_on(id: INT,args: ARRAY{STR});
-- Internal working of the widget - this routine is called by GUI_APP_END
-- whenever the widget gets a callback
end; -- abstract class $TK_WIDGET
class TK_GEN_WIDGET < $TK_WIDGET
class TK_GEN_WIDGET < $TK_WIDGET is
-- Widget used as a handle for tk widgets that don't have a full
-- fledged sather version
readonly attr widget_name: STR;
readonly attr path_name: STR;
create(widget_name,path_name: STR): SAME is
res ::= new;
res.widget_name := widget_name;
res.path_name := path_name;
return res;
end;
act_on(id: INT,args: ARRAY{STR}) is
raise("No actions may be performed on TK_GEN_WIDGETS");
end;
end;
partial class TK_WIDGET_INCL{CFGINFO < $TK_WIDGET_CFG}
partial class TK_WIDGET_INCL{CFGINFO < $TK_WIDGET_CFG} is
-- Note that SatherGui widgets may consist of an outer frame
-- and some auxilliary widgets (such as scroll bars) in addition
-- to the "actual_widget"
--
-- path_name refers to the path to the outermost frame
-- widget_name is the sams as the path name except for the root window
-- in which case the widget name is "." and the path name is ""
-- actual_widget_name refers to the widget proper - the actual
-- text widget or canvas widget (for example) to which all
-- configuration options must apply.
private attr bindings: A_LIST{ROUT{TK_EVENT_INFO}}; -- Store the bindings
readonly attr parent: $TK_WIDGET;
readonly attr path_name: STR; -- refers to the path to the outermost frame
-- which may contain scrollbars etc.
readonly attr name: STR; -- name of the full path to the widget proper
-- ------------------- Descendants sould redefine -----------------
stub tk_widget_type: STR;
-- Specifies the tk name of the widget
private default_init(c: CFGINFO) is end;
-- Default initialization hook
private default_packing: TK_PACK is
return TK_PACK::top_grow_horiz_n_vert
end;
-- Default packing
private default_config: CFGINFO is return CFGINFO::std end;
-- Default configuration information
-- ------------------- ------------------------------------------
widget_name: STR is return path_name end;
-- In the default case the path and widget names are the same
private actual_widget_name: STR is return widget_name end;
-- Sometimes the "real" tk widget is nested within an outer
-- frame. Configuration options must then be passed to the
-- "actual" widget.
-- Different versions of the create routine
create: SAME
is
-- Create a new widget with default options under the root window
parent ::= TK_TOPLEVEL::root_window;
res ::= #SAME(parent);
return res;
end;
create(parent: $TK_WIDGET): SAME is
-- Create a new widget, specifying a particular parent widget/window.
return create(parent,default_packing);
end;
create(parent: $TK_WIDGET,np: STR): SAME is
-- Create a new widget, specifying a particular parent and a
-- name for the widget. The name "np" controls what tcl name is
-- used and is only useful just for debugging purposes
return create(parent,np,default_packing);
end;
create(parent: $TK_WIDGET,cf: CFGINFO): SAME is
-- Create a new widget
-- Arg parent specifies the parent window/widget. This could
-- be a #TK_ROOTWINDOW or a TK_TOPLEVEL
-- toplevel_win ::= #TK_TOPLEVEL;
-- this_win := #<some widget class>(toplevel_win,
-- Arg cf specifies a configuration option that should be used
-- by this widget. This routine is declared in TK_WIDGET_INCL
-- where the type of the configuration option is a type parameter
-- CFGINFO, which is usually set to <widget_name>TK__CFG
return create(parent,"widget",cf,default_packing);
end;
create(parent: $TK_WIDGET,pack: TK_PACK): SAME is
-- Create a new widget
-- Arg parent specifies the container parent window/widget
-- Arg pack specifies the location of the widget within the
-- parent (packing).
return create(parent,"widget",default_config,pack);
end;
create(parent: $TK_WIDGET,cf: CFGINFO,pack: TK_PACK): SAME is
-- Create a new widget.
-- Arg parent specifies the container parent window/widget
-- Arg cf specifies configuration options (a parameter of
-- TK_WIDGET_INCL)
-- Arg pack specifies the packing options
return create(parent,"widget",cf,pack);
end;
create(parent: $TK_WIDGET,np: STR, pack: TK_PACK): SAME is
-- Create a new widget.
-- Arg parent specifies the container parent window/widget
-- Arg np is used to specify a widget name for debugging
-- Arg pack specifies the packing options
return create(parent,np,default_config,pack);
end;
create(parent:$TK_WIDGET,np:STR,cf: CFGINFO,pack:TK_PACK): SAME is
-- Actual widget creation routine. All the rest are wrappers.
-- Arg parent specifies the container parent window/widget
-- Arg np is used to specify a widget name for debugging
-- Arg cf specifies configuration options (a parameter of
-- TK_WIDGET_INCL)
-- Arg pack specifies the packing options
-- Returns a configured, packed widget
res ::= new;
res.bindings := #;
name ::= fix_tcl_name(np)+'u'+UNIQ::next;
deb("Creating widget named:"+name+" specfied name:"+np);
res.init(parent,name,cf);
res.register;
eval(res.actual_widget_name,"configure", cf.str);
if pack.str.size > 3 then
-- If packing is explicitly set to a short empty string,
-- don't pack
eval("pack",res.widget_name,pack.str);
end;
return res;
end;
private init(prnt: $TK_WIDGET,nm: STR,cf: CFGINFO) is
parent := prnt;
name := nm;
if ~void(parent) then path_name := parent.path_name+"."+nm;
else path_name := "."+nm end;
eval(tk_widget_type,path_name);
default_init(cf);
end;
is_eq(o:$TK_WIDGET): BOOL is return SYS::ob_eq(self,o); end;
configure(cf: CFGINFO) is
-- Reconfigure the widget with the new configuration "cf"
-- Unstated parameters of "cf" remain unchanged
eval(actual_widget_name,"configure",cf.str);
end;
destroy is
-- Destroy the widget associated with self
eval("destroy ",widget_name);
end;
bind_event(event: $TK_EVENT,action: ROUT{TK_EVENT_INFO}) is
-- Bind the event "event" to the action "action", a bound
-- routine which takes an EVENT_INFO as an argument
-- The first argument to the callback is an index in to
-- the list of bindings that corresponds to this "action"
action_index: INT := bindings.size; -- = Index of the next binding
deb("Binding an action with index:"+action_index+"\n");
bindings.append(action);
eval("bind "+widget_name+' '+event.str+' '+" \" sather "
+widget_name+" " +action_index+" "+event.cb_str+"\"");
end;
act_on(id: INT,args: ARRAY{STR}) is
-- Peform the action associated with the index "id".
if id >= bindings.size then
raise "Internal error in widget! Binding "+id+" is out of range";
else
deb("Acting on:"+id+" in widget:"+widget_name);
func ::= bindings[id];
event_info ::= #TK_EVENT_INFO(args);
deb("Event info:"+event_info.str);
func.call(event_info);
end;
end;
private fix_tcl_name(s: STR): STR is
-- SEF:Eliminate problems with tcl name, returning the empty
-- string if necessary.
res ::= #FSTR("");
loop c ::= s.elt!;
if c.is_alpha then res := res+c.lower; end;
end;
return res.str;
end;
private register is
-- Register this widget with the widget map so that subsequent
-- callbacks that belong to this widget may be directed here.
TK_WIDGET_MAP::register(actual_widget_name,self);
end;
private err(s: STR) is
-- Print out an error message.
#ERR+"**************************************************\n";
#ERR+s+"\n";
#ERR+"In widget:"+widget_name+"\n";
#ERR+"**************************************************\n";
end;
private deb(s: STR) is GUI_APP_END::deb(s) end;
-- Print out a debugging message
private debug: BOOL is return GUI_APP_END::debug end;
-- Return the value of the debug flag
private int_if_poss(s: STR,default: INT): INT is
-- Convert the string "s" to an integer and return it, if possible.
-- If an error occurs in the conversion, return the "default" value
c ::= #STR_CURSOR(s);
res ::= c.int;
if c.has_error then return default else return res end;
end;
private flt_if_poss(s: STR,default: FLT): FLT is
-- Convert the string "s" to a float and return it, if possible.
-- If an error occurs in the conversion, return the "default" value
c ::= #STR_CURSOR(s);
res ::= c.get_flt;
if c.has_error then return default else return res end;
end;
private arr_str(a: ARRAY{STR}): STR is
-- Print out an array version of the string, since ARRAY
-- does not have a .str routien in the standar library.
res ::= ""; loop res := res+" "+a.elt!; end; return res;
end;
-- Wrapper routines to make it easier to perform an eval
private eval(a1: $STR) is GUI_APP_END::eval(a1.str); end;
private eval(a1,a2: $STR) is GUI_APP_END::eval(a1.str.append(" ",a2.str));
end;
private eval(a1,a2,a3: $STR) is
GUI_APP_END::eval(a1.str.append(" ",a2.str," ",a3.str));
end;
private eval(a1,a2,a3,a4: $STR) is
GUI_APP_END::eval(a1.str.append(" ",a2.str," ",a3.str," ",a4.str));
end;
private eval(a1,a2,a3,a4,a5: $STR) is
GUI_APP_END::eval(a1.str+" "+a2.str+" "+a3.str+" "+a4.str+" "+a5.str);
end;
private quote(s:STR): STR is return "{".append(s,"}") end;
-- Return a (tcl) quoted version of the string "s"
private join(a1,a2: $STR): STR is
res ::= #FSTR("");
if ~void(a1) then res := res + " " + a1.str; end;
if ~void(a2) then res := res + " " + a2.str; end;
return res.str;
end;
end;
partial class TK_SCROLL_WIDGET_INCL{CFGINFO < $TK_WIDGET_CFG}
partial class TK_SCROLL_WIDGET_INCL{CFGINFO < $TK_WIDGET_CFG} is
-- Include class for widgets that have an "outer" frame in addition
-- to the widget proper. The outer frame can hold scrollbars, if
-- needed.
include TK_WIDGET_INCL{CFGINFO};
readonly attr frame: TK_FRAME; -- Outer frame that holds widget + scrolls
readonly attr actual_widget_name: STR; -- Name of the actual widget
readonly attr hscroll_name,vscroll_name: STR; -- Scroll bar names
actual_widget: TK_GEN_WIDGET is
return #TK_GEN_WIDGET(actual_widget_name,actual_widget_name);
end;
-- All "widget" behavior refers to the frame, not the widget itself.
-- To refer to the widget itself, use "actual_widget"
widget_name: STR is return frame.path_name end;
private init(a_parent: $TK_WIDGET,name:STR,cfg: CFGINFO) is
-- Creation of the widget and its frame
parent := a_parent;
init_frame_name ::= name+"frame";
frame := #TK_FRAME(parent,init_frame_name,
TK_FRAME_CFG::std,TK_PACK::none);
path_name := frame.path_name;
actual_widget_name := frame.path_name+"."+name;
eval(tk_widget_type,actual_widget_name); -- Create the widget proper
-- eval(actual_widget_name,"mark set insert 0.0");
eval("pack",actual_widget_name,"-side top -fill both -expand true");
default_init(cfg);
end;
bind_event(event: $TK_EVENT,action: ROUT{TK_EVENT_INFO})
-- Bind the event "event" to the action "action", a bound
-- routine which takes an EVENT_INFO as an argument
-- The first argument to the callback is an index in to
-- the list of bindings that corresponds to this "action"
is
action_index: INT := bindings.size; -- = Index of the next binding
bindings.append(action);
eval("bind "+actual_widget_name+' '+event.str+' '+" \" sather "
+actual_widget_name+" " +action_index+" "+event.cb_str+"\"");
end;
hscroll: SAME is hscroll; return self end;
vscroll: SAME is vscroll; return self end;
hscroll is
-- Create a horizontal scrollbar
if ~void(hscroll_name) then return end;
hscroll_name := widget_name+".hscroll";
eval("scrollbar",hscroll_name,
"-orient horiz -command "+quote(actual_widget_name+" xview"));
eval(actual_widget_name,"configure","-xscrollcommand",
quote(hscroll_name+" set"));
eval("pack",hscroll_name,
"-before "+actual_widget_name+" -side bottom -fill x");
end;
vscroll is
-- Add a vertical scrollbar
if ~void(vscroll_name) then return end;
vscroll_name ::= widget_name+".vscroll";
eval("scrollbar",vscroll_name,"-command "+
quote(actual_widget_name+" yview"));
eval(actual_widget_name,"configure","-yscrollcommand",
quote(vscroll_name+" set"));
eval("pack",vscroll_name,
"-before "+actual_widget_name+" -side right -fill y");
end;
end;
class TK_WIDGET_MAP
class TK_WIDGET_MAP is
-- Mapping between widget names and widgets
-- that is used by the callback mechanism to identify the appropriate
-- target widget of a callback
private shared window_map: FMAP{STR,$TK_WIDGET};
register(window_name: STR, object: $TK_WIDGET) is
if GUI_APP_END::debug then
GUI_APP_END::deb("Registering window:"+window_name)
end;
if void(window_map) then window_map := #; end;
window_map := window_map.insert(window_name,object);
end;
get_widget(window_name: STR): $TK_WIDGET is
if window_map.test(window_name) then
return window_map.get(window_name);
else
raise "Window not registered:"+window_name;
end;
end;
end;
class TK_WIDGET_CALLBACKS{ROUT_ARG}
class TK_WIDGET_CALLBACKS{ROUT_ARG} is
-- Used by widgets to hold a mapping from a callback to
-- an integer "id".
-- Mapping from ids to callbacks.
-- Widgets use one of these to hold their callback information
private attr action_map: FLIST{ROUT_ARG};
private attr action_name: FLIST{STR};
create: SAME is
res ::= new;
res.action_map := #;
res.action_name := #;
return res;
end;
register(action: ROUT_ARG): INT is
-- Register the action "action" and assign it an integer
-- id which can be used to later look up the action.
return register(action,"noname");
end;
register(action: ROUT_ARG,name:STR): INT is
-- Same as the register procedure, but also registers
-- an optional name for the callback which may be helpful
-- during debugging.
if void(action_map) then action_map := # end;
if void(action_name) then action_name := #; end;
action_map := action_map.push(action);
action_name := action_name.push(name);
return (action_map.size);
end;
get_action(id: INT): ROUT_ARG is
-- Returns the bound routine associated with the action identifier "id"
id := id-1;
if id < 0 or id >= action_map.size then
raise "Error: Action id not known!"+id+"\n";
else
action ::= action_map[id];
if GUI_APP_END::debug then
GUI_APP_END::deb("Callback found action for:"+id);
GUI_APP_END::deb("Action name:"+action_name[id]);
end;
return action;
end;
end;
get_action_name(id: INT): STR is
-- Return the debuggin name associated with the action identifier "id"
return action_name[id];
end;
end;
class TK_ARG_UTIL
class TK_ARG_UTIL is
-- Utility for binding argument names and values.
-- Key point: If the value is void, then no string is generated.
-- this is a convenient way to not specify an option
pair(nm:STR,val: STR): STR is
if ~void(val) then return (#FSTR(" ")+"-"+nm+" "+val.str+" ").str;
else return ""; end;
end;
pair(nm:STR,val: FLT): STR is
if ~val.is_nil then return (#FSTR(" ")+"-"+nm+" "+val.str+" ").str;
else return ""; end;
end;
pair(nm: STR,val: TK_ANCHOR): STR is
if ~val.is_nil then return (#FSTR(" ")+"-"+nm+" "+val.str+" ").str;
else return ""; end;
end;
end;
class UNIQ
class UNIQ is
-- Generate unique integers to make strings unique so that
-- we don't rely on string names in sather
private shared gen: INT := 0;
next: INT is gen := gen+1; return gen; end;
end;
immutable class TK_TAG_INCL
immutable class TK_TAG_INCL is
-- Partial TAG class
readonly attr str: STR;
create: SAME is return(#("Unnamed")) end;
create(name: STR): SAME is
-- Generates unique tags. The "name" is just for debugging purposes
res: SAME;
return res.str("tag"+UNIQ::next+name);
end;
end;