## 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 package 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/old/menu/popup-menu.pkg package ts = toggleswitches; # toggleswitches is from src/lib/x-kit/widget/old/leaf/toggleswitches.pkg package wg = widget; # widget is from src/lib/x-kit/widget/old/basic/widget.pkg package wa = widget_attribute_old; # widget_attribute_old is from src/lib/x-kit/widget/old/lib/widget-attribute-old.pkg package wy = widget_style_old; # widget_style_old is from src/lib/x-kit/widget/old/lib/widget-style-old.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.pkgherein
package pulldown_menu_button
: (weak) Pulldown_Menu_Button # Pulldown_Menu_Button is from src/lib/x-kit/widget/old/menu/pulldown-menu-button.api {
fun make_pulldown_menu_button root_window (label, menu)
=
{ w_slot = make_mailslot ();
r_slot = make_mailslot ();
all_buttons = 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)
];
button = ts::label_button
( root_window,
( name,
wg::style_of root_window
),
args
)
(\\ _ = ());
fun pre_fn () = ts::set_button_on_off_flag (button, TRUE);
fun post_fn () = ts::set_button_on_off_flag (button, FALSE);
fun query arg
=
{ put_in_mailslot (w_slot, arg);
#
take_from_mailslot r_slot;
};
fun pos (pu::WHERE_INFO { screen_point=> { col=>sx, row=>sy },
window_point=> { col=>x, row=>y },
timestamp,
mouse_button
},
{ high, ... }: g2d::Size
)
=
pu::PUT_POPUP_MENU_UPPERLEFT_ON_SCREEN
({ col=>sx-x, row=>sy-y+high+1 } );
(pu::attach_positioned_menu_to_widget (ts::as_widget button, all_buttons, menu, query))
->
(widget, mailop);
fun realize_widget { 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::get_contents_of_envelope 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::get_contents_of_envelope envelope)
#
xc::ETC_RESIZE ({ wide, high, ... }: g2d::Box)
=>
{ put_in_mailslot (c_slot, envelope);
{ wide, high };
};
_ => { put_in_mailslot (c_slot, envelope);
size;
};
esac;
fun loop window_size
=
loop (
do_one_mailop [
from_mouse' ==> (\\ mailop = { do_mouse mailop; window_size; }),
from_other' ==> (\\ mailop = do_mom (mailop, window_size)),
take_from_mailslot' w_slot ==> (\\ msg = { put_in_mailslot (r_slot, pos (msg, window_size)); window_size; })
]
);
make_thread "menu_button" {.
#
loop window_size;
};
wg::realize_widget 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 => \\ () = { background => NULL },
realize_widget,
size_preference_thunk_of
=>
wg::size_preference_thunk_of widget
};
(menu_widget, mailop);
};
};
end;