## pulldown-menu-button.pkg
# Compiled by:
# src/lib/x-kit/widget/xkit-widget.sublib### "Truth is the daughter of time,
### not of authority."
###
### -- Francis Bacon
stipulate
include threadkit; # threadkit is from src/lib/src/lib/thread-kit/src/core-thread-kit/threadkit.pkg #
package pu = popup_menu; # popup_menu is from src/lib/x-kit/widget/menu/popup-menu.pkg package ts = toggleswitches; # toggleswitches is from src/lib/x-kit/widget/leaf/toggleswitches.pkg package wg = widget; # widget is from src/lib/x-kit/widget/basic/widget.pkg package wa = widget_attribute; # widget_attribute is from src/lib/x-kit/widget/lib/widget-attribute.pkg package wy = widget_style; # widget_style is from src/lib/x-kit/widget/lib/widget-style.pkg package xg = xgeometry; # xgeometry is from src/lib/std/2d/xgeometry.pkg #
package xc = xclient; # xclient is from src/lib/x-kit/xclient/xclient.pkgherein
package pulldown_menu_button
: (weak) Pulldown_Menu_Button # Pulldown_Menu_Button is from src/lib/x-kit/widget/menu/pulldown-menu-button.api {
fun make_pulldown_menu_button root_window (label, menu)
=
{ w_slot = make_mailslot ();
r_slot = make_mailslot ();
all_bttns = map xc::MOUSEBUTTON [1, 2, 3, 4, 5];
name = wy::make_view { name => wy::style_name ["menuButton"],
aliases => []
};
args = [ (wa::relief, wa::RELIEF_VAL wg::FLAT),
(wa::label, wa::STRING_VAL label)
];
bttn = ts::label_button
( root_window,
( name,
wg::style_of root_window
),
args
)
(fn _ = ());
fun pre_fn () = ts::set_button_on_off_flag (bttn, TRUE);
fun post_fn () = ts::set_button_on_off_flag (bttn, FALSE);
fun query arg
=
{ put_in_mailslot (w_slot, arg);
take_from_mailslot r_slot;
};
fun pos (pu::WHERE_INFO { screen_point=> xg::POINT { col=>sx, row=>sy },
window_point=> xg::POINT { col=>x, row=>y },
timestamp,
mouse_button
},
xg::SIZE { high, ... }
)
=
pu::PUT_POPUP_MENU_UPPERLEFT_ON_SCREEN
(xg::POINT { col=>sx-x, row=>sy-y+high+1 } );
my (widget, mailop)
=
pu::attach_positioned_menu_to_widget (ts::as_widget bttn, all_bttns, menu, query);
fun menu_realize { window, window_size, kidplug }
=
{ kidplug -> xc::KIDPLUG { from_mouse', from_other', ... };
m_slot = make_mailslot ();
c_slot = make_mailslot ();
fun do_mouse envelope
=
{ case (xc::envelope_contents envelope)
#
xc::MOUSE_FIRST_DOWN _ => pre_fn ();
xc::MOUSE_LAST_UP _ => post_fn ();
_ => ();
esac;
put_in_mailslot (m_slot, envelope);
};
fun do_mom (envelope, size)
=
case (xc::envelope_contents envelope)
#
xc::ETC_RESIZE (xg::BOX { wide, high, ... } )
=>
{ put_in_mailslot (c_slot, envelope);
xg::SIZE { wide, high };
};
_ => { put_in_mailslot (c_slot, envelope);
size;
};
esac;
fun loop window_size
=
loop (
do_one_mailop [
from_mouse' ==> (fn mailop = { do_mouse mailop; window_size; }),
from_other' ==> (fn mailop = do_mom (mailop, window_size)),
take_from_mailslot' w_slot ==> (fn msg = { put_in_mailslot (r_slot, pos (msg, window_size)); window_size; })
]
);
make_thread "menu_button" .{
#
loop window_size;
};
wg::realize_fn widget
{
window,
window_size,
kidplug => xc::replace_other
( xc::replace_mouse (kidplug, take_from_mailslot' m_slot),
take_from_mailslot' c_slot
)
};
};
menu_widget
=
wg::make_widget
{
root_window,
args => fn () = { background => NULL },
realize => menu_realize,
size_preference_thunk_of
=>
wg::size_preference_thunk_of widget
};
(menu_widget, mailop);
};
};
end;