## util_window.pkg
## (C) 1997, 1998, Bremen Institute for Safe Systems, Universitaet Bremen
## Author: cxl
# Compiled by:
# src/lib/tk/src/toolkit/sources.sublib# *************************************************************************
# Windows for errors, warnings, user confirmation and text entry.
#
# A better version of util_window.pkg
# *************************************************************************
### "It is wrong always, everywhere, and for anyone,
### to believe anything upon insufficient evidence."
###
### -- William Kingdon Clifford
package uw: (weak) Util_Window # Util_Window is from src/lib/tk/src/toolkit/util_window.api{
include package tk;
include package basic_utilities;
# -- Configuration section -------------------------------------------
# Width (in pixels) and font for error, warning and confirmation wins
my
msg_font = NORMAL_FONT []; my
msg_width = 180; my
button_relief = RAISED; my
button_width = 5; my
button_font = SANS_SERIF [];
fun error_icon_filenm ()
=
winix__premicrothread::path::cat (tk::get_lib_path(), "images/stop.gif");
fun warning_icon_filenm ()
=
winix__premicrothread::path::cat (tk::get_lib_path(), "images/warning.gif");
fun info_icon_filenm ()
=
winix__premicrothread::path::cat (tk::get_lib_path(), "images/info.gif");
my
info_time_out
=
10; # Info windows stay up at least this long
my
enter_text_font
=
TYPEWRITER [LARGE];
# -- End of configuration section ------------------------------------
fun errwrnwidgs (iconpath, msg, cc)
=
[ LABEL {
widget_id => make_widget_id (),
packing_hints => [PACK_AT LEFT, FILL ONLY_Y],
traits => [ICON (FILE_IMAGE (iconpath, make_image_id()))],
event_callbacks => []
},
FRAME {
widget_id => make_widget_id(),
packing_hints => [PACK_AT TOP, FILL XY],
event_callbacks => [],
traits => [],
subwidgets => PACKED [
MESSAGE {
widget_id => make_widget_id (),
packing_hints => [ PAD_X 20,
PAD_Y 20,
PACK_AT TOP,
FILL ONLY_X
],
traits => [ TEXT msg,
WIDTH msg_width,
FONT msg_font
],
event_callbacks => []
},
BUTTON {
widget_id => make_widget_id(),
packing_hints => [PACK_AT RIGHT],
event_callbacks => [],
traits => [ TEXT "Continue",
CALLBACK cc,
RELIEF button_relief,
WIDTH button_width,
FONT button_font
]
}
]
}
];
fun errwrnwin (title, iconpath, msg, cc)
=
{ wid = make_window_id ();
fun close ()
=
{ close_window wid;
cc()
;};
make_window {
window_id => wid,
traits => [WINDOW_TITLE title, TRANSIENTS_LEADER NULL],
subwidgets => PACKED (errwrnwidgs (iconpath, msg, close)),
event_callbacks => [],
init => null_callback
};
};
fun error msg
=
open_window (errwrnwin("Error Message",
error_icon_filenm(), msg, k0));
fun warning msg = open_window (errwrnwin("Warning Message",
warning_icon_filenm(), msg, k0));
fun error_cc (msg, cc) = open_window (errwrnwin("Error Message",
error_icon_filenm(), msg, cc));
fun warning_cc (msg, cc) = open_window (errwrnwin("Warning Message",
warning_icon_filenm(), msg, cc));
# --- Confirmation [ OK ] [ Cancel ] --------------------------------
my
button_conf
=
[ WIDTH button_width,
RELIEF button_relief,
FONT button_font
];
fun ok_cancel_buttons (window, fate)
=
{ fun cc () = { close_window window; fate();};
fun no () = (close_window window);
FRAME {
widget_id => make_widget_id (),
packing_hints => [PACK_AT BOTTOM, FILL ONLY_X],
traits => [],
event_callbacks => [],
subwidgets => PACKED [
BUTTON {
widget_id => make_widget_id(),
packing_hints => [ PAD_X 10,
PAD_Y 15,
PACK_AT LEFT
],
traits => [ TEXT "Cancel",
CALLBACK no]@
button_conf,
event_callbacks => []
},
BUTTON {
widget_id => make_widget_id (),
packing_hints => [ PAD_X 10,
PAD_Y 15,
PACK_AT RIGHT
],
traits => [TEXT "OK", CALLBACK cc] @ button_conf,
event_callbacks => []
}
]
};
};
fun confirm (msg, cc)
=
{
window = make_window_id();
pic = LABEL {
widget_id => make_widget_id(),
packing_hints=> [PACK_AT LEFT, FILL ONLY_Y],
traits=> [ICON (FILE_IMAGE (warning_icon_filenm(),
make_image_id()))],
event_callbacks=> []
};
msg = MESSAGE {
widget_id => make_widget_id (),
packing_hints => [PACK_AT TOP, FILL XY],
traits => [TEXT msg, WIDTH msg_width, FONT msg_font],
event_callbacks => []
};
frm = FRAME {
widget_id => make_widget_id (),
subwidgets=> PACKED [msg, ok_cancel_buttons (window, cc)],
packing_hints=> [PACK_AT TOP, FILL ONLY_X, EXPAND TRUE],
traits=> [], event_callbacks=> [] };
open_window (make_window { window_id => window,
traits =>[WINDOW_TITLE "Please Confirm Or Abort",
TRANSIENTS_LEADER NULL],
subwidgets => PACKED [pic, frm],
event_callbacks => [],
init => null_callback } );
};
# --- display a text --------------------------------------------------
fun disp_window (winid, title, cc, disp_widg)
=
{ fun quit_but window
=
FRAME {
widget_id=> make_widget_id(),
subwidgets => PACKED [
BUTTON { widget_id=> make_widget_id(),
packing_hints=> [PACK_AT RIGHT,
PAD_X 10, PAD_Y 10],
traits=> [TEXT "Close",
CALLBACK (\\ () = close_window window)]@
(button_conf),
event_callbacks=> [] } ],
packing_hints=> [PACK_AT BOTTOM, FILL ONLY_X],
event_callbacks=> [], traits=> []
};
winid
then
open_window (make_window { window_id => winid,
traits => [WINDOW_TITLE title],
subwidgets => PACKED [quit_but winid, disp_widg],
event_callbacks => [],
init => \\ ()=> cc (get_widget_id disp_widg); end } );
};
fun display' { window_id, widget_id, title, width, height, text, cc }
=
# Add scroll button if text is longer than height
# !! This doesn't quite work, since it doesn't take into account
# line wrapping-- hence disabled XXX BUGGO FIXME
{ scb = if (.rows (get_livetext_rows_cols text)
>=
height
)
AT_LEFT;
else NOWHERE;fi ;
ignore (disp_window (window_id, title, cc,
TEXT_WIDGET { widget_id=> widget_id,
scrollbars=> AT_RIGHT, live_text=> text,
packing_hints=> [PACK_AT TOP, FILL XY,
EXPAND TRUE],
traits=> [ACTIVE FALSE,
BORDER_THICKNESS 1, WIDTH width,
HEIGHT height],
event_callbacks=> [] } ));
};
fun display_id { window_id, widget_id, title, width, height, text }
=
display'{ window_id=> window_id, widget_id=> widget_id, title, width,
height, text, cc=> \\ _ = () };
fun display { title, width, height, text, cc }
=
display' {
window_id => make_window_id (),
widget_id => make_widget_id (),
title,
width,
height,
text,
cc=> cc
};
# --- informative messages --------------------------------------------
fun infofrm msg
=
{ pic = LABEL { widget_id=> make_widget_id(),
packing_hints=> [PACK_AT LEFT, FILL ONLY_Y, EXPAND TRUE,
PAD_X 10, PAD_Y 10],
traits=> [ICON (FILE_IMAGE (info_icon_filenm(),
make_image_id()))],
event_callbacks => []
};
w = if (string::size msg < 80 ) [WIDTH 100]; else []; fi;
FRAME { widget_id=> make_widget_id(),
subwidgets=> PACKED [pic,
MESSAGE { widget_id=> make_widget_id(),
packing_hints=> [PACK_AT TOP, FILL XY,
EXPAND TRUE],
traits => w @ [TEXT msg, FONT msg_font],
event_callbacks => [] } ],
traits=> [], event_callbacks=> [], packing_hints=> [] };
};
fun info_cc msg
=
{ frm = infofrm msg;
w = make_window_id ();
# to make sure the info message stays on
# for at least timeout seconds: start timer...
owt = timer::start_real_timer ();
open_window (
make_window {
window_id => w,
traits => [WINDOW_TITLE "Information"],
subwidgets => PACKED [frm],
event_callbacks => [],
init => null_callback
}
);
\\ ()
=
if (is_open w)
# Window is still up; check if
# it stayed up long enough:
#
elapsd = timer::check_real_timer owt;
timeout = time::from_seconds (int::to_large info_time_out);
if (time::(<) (elapsd, timeout))
ignore (posix::sleep
(time::(-) (timeout, elapsd)));
fi;
close_window w;
fi;
};
fun info msg
=
{
frm = infofrm msg;
ignore (
disp_window (
make_window_id (),
"Information",
\\ _=> (); end ,
frm
)
);
};
# ---- enter windows ------------------------------------
fun buttons (window, twids, fate)
=
# This and OkCancelButtons above are remarkably similar, but
# I don't know how to implement this in terms of OkCancelButtons:
{ fun cc ()
=
{ txts = map get_tcl_text twids;
close_window window;
fate txts;
};
fun no ()
=
close_window window;
FRAME {
widget_id => make_widget_id(),
subwidgets => PACKED
[ BUTTON { widget_id=> make_widget_id(),
packing_hints=> [PACK_AT LEFT, PAD_X 5, PAD_Y 5],
traits=> [TEXT "Cancel", CALLBACK no]@button_conf,
event_callbacks=> [] },
BUTTON { widget_id=> make_widget_id(),
packing_hints=> [PACK_AT RIGHT, PAD_X 5, PAD_Y 5],
traits=> [TEXT "OK", CALLBACK cc]@button_conf,
event_callbacks=> [] } ],
packing_hints=> [PACK_AT BOTTOM, FILL ONLY_X], event_callbacks=> [], traits=> [] };
};
fun enter_text0 {
title,
prompt,
default,
widgetsbelow,
width,
heights,
headers,
cc
}
=
{ window = make_window_id ();
twids = list::from_fn (length heights, \\ _ => make_widget_id(); end );
# Make sure there's enough headers:
hds = headers @ list::from_fn (length heights,
\\ _ => ""; end );
prmpt = LABEL {
widget_id => make_widget_id(),
packing_hints => [PACK_AT TOP, FILL ONLY_X, EXPAND TRUE],
traits => [TEXT prompt, WIDTH width],
event_callbacks => []
};
fun ewtxt ((w, h), p)
=
{
tw = TEXT_WIDGET {
widget_id => w,
scrollbars => AT_RIGHT,
live_text => string_to_livetext default,
packing_hints => [PACK_AT TOP, EXPAND TRUE],
event_callbacks => [],
traits => [RELIEF RAISED, BORDER_THICKNESS 2,
WIDTH width, HEIGHT h,
FONT enter_text_font]
};
if (p == "")
[tw];
else
[ LABEL { widget_id=> make_widget_id(),
packing_hints=> [PACK_AT TOP, EXPAND TRUE, FILL ONLY_X],
traits=> [TEXT p], event_callbacks=> [] }, tw];
fi;
};
txwdgs = list::cat (paired_lists::map ewtxt
(paired_lists::zip (twids, list::reverse heights),
hds));
bws = FRAME {
widget_id => make_widget_id(),
subwidgets => PACKED (
buttons (window, twids, cc) .
(map (\\ w=> update_widget_packing_hints w
[PACK_AT TOP]; end ) widgetsbelow)),
packing_hints => [PACK_AT BOTTOM, FILL ONLY_X, EXPAND TRUE],
traits => [], event_callbacks=> []
};
fun init ()
=
();
open_window (
make_window {
window_id => window,
traits => [WINDOW_TITLE title],
subwidgets => PACKED ([bws, prmpt]@txwdgs),
event_callbacks => [],
init
}
);
};
# Convert function on singleton lists of strings to function on strings
fun list2s cc (t . _)=> cc t;
list2s cc _ => cc ""; end;
fun enter_text { title, prompt, default, height, width, cc }
=
enter_text0 { title, prompt, default,
widgetsbelow => [], heights => [height], headers => [""],
width, cc => list2s cc
};
fun enter_line { title, prompt, default, width, cc }
=
{
window = make_window_id ();
twid = make_widget_id ();
w_here = size prompt > width * 2
?? [PACK_AT LEFT, FILL ONLY_Y, EXPAND TRUE]
:: [PACK_AT TOP, FILL ONLY_X, EXPAND TRUE];
prmpt = LABEL {
widget_id => make_widget_id(),
packing_hints => w_here, event_callbacks=> [],
traits => [TEXT prompt]
};
entln = TEXT_ENTRY {
widget_id => twid,
packing_hints => [PACK_AT LEFT],
traits => [ RELIEF RIDGE,
WIDTH width,
BORDER_THICKNESS 2,
FONT enter_text_font
],
event_callbacks => [ EVENT_CALLBACK (
KEY_PRESS("Return"),
\\ _ => { txt= get_tcl_text twid;
{ close_window window;
cc txt;};
}; end
)
]
};
open_window (
make_window {
window_id => window,
traits => [WINDOW_TITLE title],
subwidgets => PACKED [
FRAME {
widget_id => make_widget_id(),
subwidgets => PACKED [prmpt, entln],
packing_hints => [PACK_AT TOP, FILL ONLY_X],
traits => [],
event_callbacks => []
},
buttons (window, [twid],
list2s cc)
],
event_callbacks => [],
init => \\ _ = insert_text
twid default (MARK (1, 0))
}
);
};
};