# ml-source-code-viewer.pkg
#
# This is a ML source code viewer, which is a test application for
# the new text widget.
# Compiled by:
# src/lib/x-kit/widget/xkit-widget.sublibstipulate
include package threadkit; # threadkit is from src/lib/src/lib/thread-kit/src/core-thread-kit/threadkit.pkg #
package g2d= geometry2d; # geometry2d is from src/lib/std/2d/geometry2d.pkg #
package xc = xclient; # xclient is from src/lib/x-kit/xclient/xclient.pkg #
package wg = widget; # widget is from src/lib/x-kit/widget/old/basic/widget.pkg #
package vb = view_buffer; # view_buffer is from src/lib/x-kit/widget/old/fancy/graphviz/text/view-buffer.pkg package td = text_display; # text_display is from src/lib/x-kit/widget/old/fancy/graphviz/text/text-display.pkg package tc = text_canvas; # text_canvas is from src/lib/x-kit/widget/old/fancy/graphviz/text/text-canvas.pkgherein
package ml_source_code_viewer: Ml_Source_Code_Viewer { # Ml_Source_Code_Viewer is from src/lib/x-kit/widget/old/fancy/graphviz/text/ml-source-code-viewer.api Plea_Mail
#
= SCROLL_MSG Int
#
| VIEW_MSG
Oneshot_Maildrop
{ view_start: Int,
view_ht: Int,
nlines: Int
};
Viewer
=
VIEWER
{ widget: wg::Widget,
text_display: Oneshot_Maildrop( td::Text_Display ),
plea_slot: Mailslot( Plea_Mail )
};
Face = FACE { font: Null_Or( xc::Font ),
color: Null_Or( xc::Color_Spec )
};
fun make_viewer
root_window
{
src,
font,
comm_face,
kw_face,
sym_face,
id_face,
background
}
=
VIEWER {
text_display => oneshot,
plea_slot => plea_slot,
widget
=>
wg::make_widget
{
args => (\\ () = { background => NULL }), # Added 2009-12-28 CrT just to get it to compile
root_window,
realize_widget,
size_preference_thunk_of
=>
\\ () = { col_preference => wg::INT_PREFERENCE { start_at=>0, step_by=>1, min_steps=>10, best_steps=>80*char_width, max_steps=>NULL },
row_preference => wg::INT_PREFERENCE { start_at=>0, step_by=>1, min_steps=>20, best_steps=>24*line_high, max_steps=>NULL }
}
}
}
where
oneshot = make_oneshot_maildrop ();
plea_slot = make_mailslot ();
(xc::font_high font)
->
{ ascent, descent };
line_high = ascent + descent;
char_width = xc::text_width font "m";
fun realize_widget { kidplug, window, window_size as { high, ... }}
=
{ put_in_oneshot (oneshot, text_display);
# x_debug::make_thread "viewer::server" server;
();
}
where
canvas
=
tc::make_text_canvas
{
window,
size => window_size,
font,
foreground => NULL,
background => (THE background)
};
fun make_tb (FACE { font, color } )
=
{ fun mk traits
=
tc::make_typeball (canvas, traits);
case (font, color)
#
(NULL, NULL ) => mk [];
(THE f, NULL ) => mk [tc::TBV_FONT f];
(NULL, THE c) => mk [tc::TBV_FOREGROUND c];
(THE f, THE c) => mk [tc::TBV_FONT f, tc::TBV_FOREGROUND c];
esac;
};
pool = vb::make_view_buffer
{
src,
nrows => high % line_high,
font,
char_width,
ascent,
descent,
line_high,
#
fill_tb => tc::make_typeball (canvas, [tc::TBV_FOREGROUND background]),
#
comment_tb => make_tb comm_face,
keyword_tb => make_tb kw_face,
symbol_tb => make_tb sym_face,
ident_tb => make_tb id_face
};
text_display
=
td::make_text_display { canvas, text => pool, size => window_size };
redraw = td::redraw text_display;
scroll_up = td::scroll_up text_display;
scroll_down = td::scroll_down text_display;
# Clear and fill in the region
# vacated by a scroll operation:
#
fun fill_in { vacated, damage }
=
{ td::clear_box text_display vacated;
#
redraw (vacated ! (block_until_mailop_fires damage));
};
my xc::KIDPLUG { from_other', ... }
=
xc::ignore_mouse_and_keyboard kidplug;
fun do_mom envelope
=
case (xc::get_contents_of_envelope envelope)
#
xc::ETC_REDRAW damage
=>
redraw damage;
xc::ETC_RESIZE ({ wide, high, ... }: g2d::Box)
=>
td::resize (text_display, { wide, high } );
xc::ETC_OWN_DEATH
=>
{ # v_debug::pr ["viewer::die\n"];
shut_down_thread_scheduler winix__premicrothread::process::success;
};
_ => ();
esac;
fun do_plea (VIEW_MSG reply_oneshot)
=>
put_in_oneshot (reply_oneshot, vb::get_view pool);
do_plea (SCROLL_MSG new_top)
=>
{ (vb::get_view pool)
->
{ view_start, view_ht, nlines };
vb::set_view_top (pool, new_top);
(vb::get_view pool)
->
{ view_start => new_top, ... };
if (new_top != view_start)
# Scroll needed:
delta = new_top - view_start;
my { wide, high }
=
td::size_of text_display;
if (abs delta >= view_ht)
tc::clear canvas;
redraw [{ col=>0, row=>0, wide, high } ];
elif (delta < 0)
fill_in (scroll_down -delta);
else
fill_in (scroll_up delta);
fi;
fi;
};
end;
fun server ()
=
for (;;) {
#
do_one_mailop [
#
from_other'
==>
do_mom,
take_from_mailslot' plea_slot
==>
do_plea
];
};
end;
end; # fun make_viewer
fun as_widget (VIEWER { widget, ... } )
=
widget;
fun view_of (VIEWER { plea_slot, ... } )
=
{ oneshot = make_oneshot_maildrop ();
#
put_in_mailslot (plea_slot, VIEW_MSG oneshot);
get_from_oneshot oneshot;
};
fun scroll_view (VIEWER { plea_slot, ... }, new_top)
=
put_in_mailslot (plea_slot, SCROLL_MSG new_top);
}; # package viewer
end;