text.sa
Generated by gen_html_sa_files from ICSI. Contact gomes@icsi.berkeley.edu for details
---------------------------> Sather 1.1 source file <--------------------------
-- text.sa: Text widget
-- Author: Benedict A. Gomes <gomes@samosa.ICSI.Berkeley.EDU>
-- Copyright (C) 1995, International Computer Science Institute
-- text.sa,v 1.1 1995/11/15 03:36:50 gomes Exp
--
-- 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.
--Classes
-- TK_TEXT Text widget that consists of an outer frame + optional
-- scrollbars + an actual text widget
-- TK_TEXT_TAG Tag used for annotating sections of text
-- TK_TEXT_TAG_CFG Specification of text characterists that are
-- associated with a particular text tag.
-- TK_TEXT_CB Structure that is passed to callback routines that are
-- associated with a text widget
-- TK_INDEX Text index used to denote a particular location in the text
class TK_TEXT_CFG
class TK_TEXT_CFG is
include TK_WIDGET_CFG_INCL
background->background,
foreground->foreground,
char_height->char_height,
char_width->char_width,
-- cursor->cursor,
font->font,
borderwidth->borderwidth,
padx->padx,
pady->pady,
justify_left->justify_left,justify_right->justify_right,
justify_center->justify_center,
relief_none->relief_none,relief_raised->relief_raised,
relief_sunken->relief_sunken,
relief_flat->relief_flat,relief_ridge->relief_ridge,
relief_groove->relief_groove,
normal->normal,disable->disable,
insertwidth->insertwidth,
insertborderwidth->insertborderwidth,
highlightbackground->highlightbackground,
highlightcolor->highlightcolor,
highlightthickness->highlightthickness,
selectborderwidth->selectborderwidth,
selectforeground->selectforeground,
selectbackground->selectbackground;
attr hscroll,vscroll: BOOL; -- Treated differently
hscroll(v: BOOL): SAME is hscroll := v; return self end;
vscroll(v: BOOL): SAME is vscroll := v; return self end;
no_wrap is config("wrap","none") end;
char_wrap is config("wrap","char") end;
word_wrap is config("wrap","word") end;
no_wrap:SAME is no_wrap; return self; end;
char_wrap: SAME is char_wrap; return self; end;
word_wrap:SAME is word_wrap; return self; end;
std: SAME is return new.hscroll(true).vscroll(true) end;
end;
class TK_TEXT < $TK_WIDGET
class TK_TEXT < $TK_WIDGET is
-- A text widget that corresponds to a TK text widget
-- The widget must first be created, either using the default create
-- routine, or the full creation routine that supplies a
-- parent widget, text configuration options and packing information
--
-- Eg: t ::= #TK_TEXT(#TK_ROOT_WINDOW,"mytext",#TK_TEXT_CFG,#TK_PACK);
--
-- Once created, text may be inserted into the widget at locations
-- that are specified using TINDEX es.
-- A TINDEX indicates a location in the text widget in a number
-- of ways - see the interface to TINDEX.
--
-- Eg. t.insert_at(TINDEX::at(1,0,"text");
--
-- Ranges of text may also be tagged using a TEXT_TAG, either
-- at insertion or later on by specifying positions
--
-- Callbacks, basically bound routines, may then be associated
-- with a particular text tag
--
-- mytag ::= #TK_TEXT_TAG("mytag");
-- t.bind(mytag,EVENT_INCLUDE::enter,bind(myput(_)));
--
-- The callback routine myput is of the form
-- myput(arg: TEXT_CB) is
-- -- do something with arg
--
-- end;
-- It is best to use TK_TEXT widgets by first including GUI_UTIL
-- which makes many commonly used functions conveniently accessible.
-- Implementation
-- Creates a text widget called <text name>
-- embedded in a frame with the name "frame"+<text name>
-- There may be auxilliary scrollbars as well.
include TK_SCROLL_WIDGET_INCL{TK_TEXT_CFG};
private attr tag_callbacks: TK_WIDGET_CALLBACKS{ROUT{TK_TEXT_CB}};
private const tk_widget_type: STR := "text";
private default_init(c: TK_TEXT_CFG) is
-- By default, use scrollbars
tag_callbacks := #;
if c.vscroll then vscroll end;
if c.hscroll then hscroll end;
end;
plus(text: $STR) is
insert_at(TK_INDEX::end_pos,text.str);
see(TK_INDEX::end_pos)
end;
plus(text: $STR):SAME is plus(text); return self; end;
configure_tag(t: TK_TEXT_TAG,c: TK_TEXT_TAG_CFG) is
-- Configure the text associated with the tag "t" to have the
-- properties specified by the configuration "c".
eval(actual_widget_name," tag configure ",t.str,c.str);
end;
insert_tagged(position: TK_INDEX,text: STR, tags: ARRAY{TK_TEXT_TAG}) is
-- Insert text "text" with the tags "tags" at the location indicated
-- by "position"
eval(actual_widget_name,"insert",
position.str,quote(text),tag_str(tags))
end;
insert_at(position: TK_INDEX,text:STR) is
-- Insert untagged text at "position"
eval("textInsert",actual_widget_name,position.str,quote(text));
end;
delete(from,to: TK_INDEX) is
eval(actual_widget_name,"delete",from.str,to.str);
end;
get(from,to: TK_INDEX): STR is
return GUI_APP_END::eval(actual_widget_name+" get "+from.str+" "+to.str);
end;
see(index: TK_INDEX) is
-- Make index visible
eval(actual_widget_name,"see",index.str);
end;
add_tag(t: TK_TEXT_TAG,from,to: TK_INDEX) is
-- Add a tag "t" to the text from "from" to "to"
eval(actual_widget_name,"tag add",t.str,from.str,to.str);
end;
bind_event(t: TK_TEXT_TAG,event: $TK_EVENT, action: ROUT{TK_TEXT_CB}) is
action_id ::= tag_callbacks.register(action,"textaction");
eval(actual_widget_name,"tag bind",t.str,quote(event.str),
quote("sather "+actual_widget_name+" "+action_id+" %b %x %y "));
end;
-- ------------------- INTERNAL DETAILS --------------------------
act_on(id: INT,cb: ARRAY{STR}) is
-- Internal GUI interface. Do not use explicitly
-- Go through the args - convert them into a TEXT_CB and then
-- call the appropriate function
-- 0 = id 1 = button 2 = x 3 = y
if cb.size < 4 then raise "Not enough arguments to canvas cb!" end;
res: TK_TEXT_CB := #;
rout:ROUT{TK_TEXT_CB} := tag_callbacks.get_action(id);
res.button_number := int_if_poss(cb[1],-1);
res.x := int_if_poss(cb[2],-1);
res.y := int_if_poss(cb[3],-1);
if debug then deb("Calling rout:"+res.str); end;
rout.call(res);
if debug then deb("Called rout"); end;
end;
private tag_str(tags: ARRAY{TK_TEXT_TAG}): STR is
tag_list ::= " { ";
loop tag_list := tag_list+" "+tags.elt!.str; end;
tag_list := tag_list+" }";
return tag_list
end;
end; -- class TK_TEXT
class TK_TEXT_CB
class TK_TEXT_CB is
-- Structure that is passed to all text callback routines.
-- Not all these fields will be valid for all types of events.
-- See the tk documentation for "bind"
attr button_number: INT;
attr x: INT;
attr y: INT;
create: SAME is return new end;
str: STR is
return "button_number="+button_number+",x="+x+",y="+y;
end;
end;
immutable class TK_TEXT_TAG
immutable class TK_TEXT_TAG is
-- A tag used to indicate a region of characters in a TK_TEXT widget
-- Text tags are used in binding callbacks
include TK_TAG_INCL;
end;
class TK_TEXT_TAG_CFG
class TK_TEXT_TAG_CFG is
-- Specify configuration options for the text associated with a particular
-- text tag
private attr relief,justify,font: STR;
private attr overstrike_str,underline_str: STR;
-- The following attributes may be set directly
attr background,foreground: STR;
attr borderwidth: FLT;
-- The following may be used, but don't yet have "function" versions
-- that return self...
attr lmargin,lmargin2,rmargin,rmargin2,spacing1,spacing2,spacing3: FLT;
attr offset: FLT;
-- No interface as yet
private attr bgstipple,fgstipple,tabs: STR;
create: SAME is
-- Give all options either uninitialized (nil) or default values.
res ::= new;
fnil ::= FLT::nil;
res.borderwidth := fnil;
res.lmargin := fnil; res.lmargin2 := fnil;
res.rmargin := fnil; res.rmargin2 := fnil;
res.spacing1 := fnil; res.spacing2 := fnil; res.spacing3 := fnil;
res.offset := fnil; res.borderwidth := fnil;
return res;
end;
foreground(s: STR): SAME is foreground := s; return self end;
background(s: STR): SAME is background := s; return self end;
borderwidth(i: FLT): SAME is borderwidth(i); return self end;
font(f: STR): SAME is font(f); return self end;
justify_right is justify := "right" end;
justify_left is justify := "left" end; -- Default
justify_center is justify := "center" end;
justify_right: SAME is justify_right; return self; end;
justify_left: SAME is justify_left; return self end;
justify_center: SAME is justify_center; return self; end;
private relief_none is relief := " none" end;
private relief_raised is relief := " raised" end;
private relief_sunken is relief := " sunken" end;
private relief_flat is relief := " flat" end;
private relief_ridge is relief := " ridge" end;
private relief_groove is relief := " groove" end;
private relief_none:SAME is relief_none; return self; end;
private relief_raised:SAME is relief_raised; return self; end;
private relief_sunken:SAME is relief_sunken; return self; end;
private relief_flat:SAME is relief_flat; return self; end;
private relief_ridge:SAME is relief_ridge; return self; end;
private relief_groove:SAME is relief_groove; return self; end;
overstrike(b:BOOL) is
if b then overstrike_str:="true" else overstrike_str:="false" end;
end;
underline(b:BOOL) is
if b then underline_str:="true" else underline_str:="false" end;
end;
overstrike(b:BOOL):SAME is overstrike(b); return self end;
underline(b:BOOL):SAME is underline(b); return self end;
str: STR is
return ""
+pair("background",background)
+pair("foreground",foreground)
+pair("borderwidth",borderwidth)
+pair("relief",relief)
+pair("justify",justify)
+pair("overstrike",overstrike_str)
+pair("underline",underline_str)
+pair("offset",offset)
+pair("rmargin",rmargin) +pair("rmargin2",rmargin2)
+pair("spacing1",spacing1) +pair("spacing2",spacing2)
+pair("spacing3",spacing3)
+pair("lmargin1",lmargin) +pair("lmargin2",lmargin2)
--+pair("-bgstipple",bgstipple) +pair("-fgstipple ",fgstipple)
--+pair("-tabs",tabs)
end;
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;
end;
class TK_INDEX
class TK_INDEX is
-- A text index indicates a particular position in a text widget
readonly attr internal_str: STR;
str: STR is return "\""+internal_str+"\""; end;
private create(s: STR): SAME is
res ::= new; res.internal_str := s; return res;
end;
-- Index associated with position on line "line" and character "ch"
first(tag: TK_TEXT_TAG): SAME is return #(tag.str+".first"); end;
last(tag: TK_TEXT_TAG): SAME is return #(tag.str+".last") end;
-- Error if no characters currently have this "tag"
at_location(x,y: INT): SAME is return #("@"+x+","+y); end;
-- The character that covers the pixel with coods (x,y) in the text
mark: SAME is return #(" mark") end;
end_pos: SAME is return #("end") end;
at(line,ch: INT): SAME is return #(line.str+"."+ch); end;
-- Line counting starts at "1" and character counting starts at "0"
-- I dislike this, but I think it is better to remain consistent with
-- the Tk documentation
forward_chars(n: INT): SAME pre n >= 0 is return m(" + "+n+" chars"); end;
backward_chars(n: INT): SAME pre n >= 0 is return m(" - "+n+" chars"); end;
forward_lines(n: INT): SAME pre n>=0 is return m(" + "+n+" lines"); end;
backward_lines(n: INT): SAME pre n>=0 is return m(" - "+n+" lines"); end;
line_start: SAME is return m(" linestart") end;
line_end: SAME is return m(" lineend") end;
word_start: SAME is return m(" wordstart") end;
word_end: SAME is return m(" wordend") end;
private m(modifier_str: STR): SAME is
return #(internal_str+" "+modifier_str);
end;
end; -- class TK_INDEX