XTkPopUpsImpl.mesa
Copyright Ó 1991, 1992 by Xerox Corporation. All rights reserved.
Created by Christian Jacobi, October 14, 1991 9:31:44 pm PDT
Christian Jacobi, October 15, 1992 3:09 pm PDT
DIRECTORY Atom, HelpStrings, Process, Rope, Xl, XlDispatch, XlTQOps, XTk, XTkFriends, XTkHelpStrings, XTkHelpShells, XTkOps, XTkPopUps, XTkWidgets;
XTkPopUpsImpl:
CEDAR
MONITOR
IMPORTS Atom, HelpStrings, Process, Rope, Xl, XlDispatch, XlTQOps, XTk, XTkOps, XTkFriends, XTkHelpShells, XTkHelpStrings, XTkWidgets
EXPORTS XTkPopUps
SHARES XlDispatch ~
BEGIN OPEN XTkPopUps;
dynamicPopUpFlag: XTk.WidgetFlagKey ~ wf3;
myShellKey: REF ~ NEW[INT]; --used on pop shell widgets; value is REF DynamicRec
myBaseKey: REF ~ NEW[INT]; --used on base button widgets; value is REF StaticRec
myChoiceKey: REF ~ NEW[INT]; --used on choice widgets
buttonReleaseFilter: Xl.EventFilter ~ Xl.CreateEventFilter[buttonRelease];
filter: Xl.EventFilter ~ Xl.CreateEventFilter[buttonPress, buttonRelease, enterNotify, leaveNotify];
IsDynamicPopShell:
PROC [w: XTk.Widget]
RETURNS [
BOOL] = {
RETURN [w#NIL AND XTk.GetWidgetFlag[w, dynamicPopUpFlag]]
};
PositionAndScreen:
PROC [connection: Xl.Connection]
RETURNS [pos: Xl.Point, s: Xl.Screen] = {
pointerQuery: Xl.PointerReply ¬ Xl.QueryPointer[connection, Xl.nullWindow];
pos ¬ pointerQuery.pos;
s ¬ Xl.QueryScreen[connection, pointerQuery.root];
IF s=NIL THEN s ¬ Xl.FirstScreen[connection]
};
RemovePriviledgedMatch:
PROC [c: Xl.Connection, dyn:
REF DynamicRec] = {
m: Xl.Match ~ dyn.priviledgedMatch;
IF m#
NIL
THEN {
dyn.priviledgedMatch ¬ NIL;
IF Xl.Alive[c] THEN XlDispatch.RemovePriviledgedMatch[c, m];
};
};
RemovePops: XTk.WidgetNotifyProc = {
Make sure we re-enable poping, even on widget destruction due to external causes.
dyn: REF DynamicRec ~ NARROW[registerData];
dyn.popShell ¬ NIL;
DestroyIncludingCascaded[dyn];
};
TearDown:
PUBLIC
PROC [carrier: PopCarrier] = {
WITH carrier
SELECT
FROM
static: REF StaticRec => DestroyIncludingAncestorsAndCascaded[static.currentDynamic];
w: XTk.Widget => {
root: XTk.Widget ~ XTk.RootWidget[w];
--only base widgets have the "myBaseKey" property
WITH XTk.GetWidgetProp[w, myBaseKey]
SELECT
FROM
static: REF StaticRec => DestroyIncludingAncestorsAndCascaded[static.currentDynamic];
ENDCASE => {};
IF IsDynamicPopShell[root] THEN DestroyIncludingAncestorsAndCascaded[DynamicFromShell[root]];
};
dyn: REF DynamicRec => DestroyIncludingAncestorsAndCascaded[dyn];
ENDCASE => {}
};
StaticRec:
TYPE =
RECORD [
--representant of PseudoBase; 1 per latent pop up menu
currentDynamic: REF DynamicRec ¬ NIL, --monitored
enteredBase: BOOL ¬ FALSE, <<modified in one proc only>>
createClosure: WidgetCreateClosure,
registerData: REF ¬ NIL,
image: REF ¬ NIL,
internalTQ: Xl.TQ, --proposal for dyn.rootTQ
base: XTk.Widget,
help: Rope.ROPE ¬ NIL,
helpHandle: HelpStrings.Handle ¬ NIL,
header: Rope.ROPE ¬ NIL
];
DynamicRec:
TYPE =
RECORD [
--dynamic; new each time it pops up
enteredShell: BOOL ¬ FALSE,
destructionStarted: BOOL ¬ FALSE,
static: REF StaticRec,
rootTQ: Xl.TQ,
popShell: XTk.Widget,
cascadedChild: REF DynamicRec ¬ NIL,
parent: REF DynamicRec ¬ NIL,
image: REF ¬ NIL,
priviledgedMatch: Xl.Match ¬ NIL
];
NotifyClosure:
TYPE =
RECORD [
w: XTk.Widget,
notifyTQ: Xl.TQ,
notify: XTk.WidgetNotifyProc,
registerData, callData: REF
];
BuildDynamic:
ENTRY
PROC [static:
REF StaticRec, parent:
REF DynamicRec, image:
REF]
RETURNS [dyn:
REF DynamicRec ¬
NIL] = {
Sets up the data structure and the tq's but not yet the widget
IF parent#NIL AND parent.destructionStarted THEN RETURN;
IF static#
NIL
THEN {
oldD: REF DynamicRec ¬ static.currentDynamic;
IF oldD#
NIL
THEN {
IF oldD.static=static AND ~oldD.destructionStarted THEN RETURN [NIL];
InternalDestroyIncludingCascaded[oldD];
};
dyn ¬ NEW[DynamicRec];
dyn.static ¬ static;
dyn.image ¬ image;
dyn.rootTQ ¬ static.internalTQ;
IF parent#
NIL
THEN {
dyn.parent ¬ parent;
InternalDestroyIncludingCascaded[parent.cascadedChild];
parent.cascadedChild ¬ dyn;
IF dyn.rootTQ=NIL THEN dyn.rootTQ ¬ parent.rootTQ;
};
IF dyn.rootTQ=NIL THEN dyn.rootTQ ¬ Xl.CreateTQ[order: XTk.rootLockingOrder];
static.currentDynamic ¬ dyn;
};
};
DestroyIncludingCascaded:
ENTRY
PROC [dyn:
REF DynamicRec] = {
IF dyn#NIL THEN InternalDestroyIncludingCascaded[dyn];
};
InternalDestroyIncludingCascaded:
INTERNAL
PROC [dyn:
REF DynamicRec] = {
WHILE dyn#
NIL
DO
next: REF DynamicRec ~ dyn.cascadedChild;
parent: REF DynamicRec ~ dyn.parent;
static: REF StaticRec ~ dyn.static;
dyn.destructionStarted ¬ TRUE;
dyn.cascadedChild ¬ NIL; dyn.parent ¬ NIL;
IF parent#
NIL
AND parent.cascadedChild=dyn
THEN {
parent.cascadedChild ¬ NIL;
};
IF static.currentDynamic=dyn THEN static.currentDynamic ¬ NIL;
ForkDestroy[dyn];
dyn ¬ next;
ENDLOOP;
};
DestroyIncludingAncestorsAndCascaded:
ENTRY
PROC [dyn:
REF DynamicRec] = {
--Data structure maintenace is monitored
--Widget destruction is forked
IF dyn#
NIL
THEN {
WHILE dyn.parent#NIL DO dyn ¬ dyn.parent ENDLOOP;
InternalDestroyIncludingCascaded[dyn];
};
};
ForkDestroy:
INTERNAL
PROC [dyn:
REF DynamicRec] = {
--Fork destruction so it may be initialized from within monitored region
shell: XTk.Widget ~ dyn.popShell;
dyn.popShell ¬ NIL;
IF IsDynamicPopShell[shell] THEN Xl.Enqueue[dyn.rootTQ <<doesn't matter which>>, Destroy, shell];
};
Destroy: Xl.EventProcType = {
shell: XTk.Widget ~ NARROW[clientData];
IF IsDynamicPopShell[shell] THEN XTkWidgets.DestroyShell[shell];
};
DoNotify:
PROC [nc:
REF NotifyClosure, ev: Xl.Event] = {
IF nc.notifyTQ=
NIL
THEN
TRUSTED {Process.Detach[
FORK
QueuedDoNotify[event: ev, clientData: nc, tq: NIL]
]}
ELSE Xl.Enqueue[tq: nc.notifyTQ, proc: QueuedDoNotify, data: nc, event: ev];
};
QueuedDoNotify: <<clientData.notifyTQ>> Xl.EventProcType = {
nc: REF NotifyClosure ~ NARROW[clientData];
nc.notify[event: event, widget: nc.w, registerData: nc.registerData, callData: nc.callData];
};
ActualPopUp:
PROC [dyn:
REF DynamicRec, ev: Xl.Event, point: Xl.Point ¬ [-1, -1], screen: Xl.Screen ¬
NIL, dynamic:
BOOL ¬
TRUE, helpHandle:
REF ¬
NIL] = {
h: HelpStrings.Handle;
static: REF StaticRec ~ dyn.static;
base: XTk.Widget ¬ static.base;
createClosure: WidgetCreateClosure ¬ static.createClosure;
shell, child: XTkWidgets.Widget;
szh: REF XTkWidgets.ICCCMHints;
compensate: Xl.Size ¬ [0, 0]; --compensate for window manager decorations
IF dyn.destructionStarted OR createClosure=NIL THEN RETURN;
shell ¬ XTkWidgets.CreateShell[dontQueryGeometry: TRUE, rootTQ: dyn.rootTQ, windowHeader: static.header, iconName: static.header, standardMigration: ~dynamic];
szh ¬ XTkWidgets.GetHints[shell];
XTk.PutWidgetProp[shell, myShellKey, dyn];
IF screen=
NIL
AND ev=
NIL
THEN {
XTkWidgets.BindScreenShell[shell, NIL];
screen ¬ shell.screenDepth.screen;
}
ELSE {
c: Xl.Connection ¬ IF screen#NIL THEN c ¬ screen.connection ELSE c ¬ ev.connection;
IF screen=
NIL
OR point.x<0
OR point.y<0
THEN {
p: Xl.Point;
[p, screen] ¬ PositionAndScreen[c]; --no damage if screen switched
IF point.x<0 THEN point.x ¬ p.x;
IF point.y<0 THEN point.y ¬ p.y;
};
XTkWidgets.BindScreenShell[shell, c, screen.root];
};
IF point.x>=0
AND point.y>=0
THEN {
szh.wmNormalHints.userPos ¬ szh.wmNormalHints.clientPos ¬ TRUE;
};
dyn.popShell ¬ shell;
IF base#
NIL
THEN {
h ¬ XTkHelpStrings.GetHandle[base];
szh.transientFor ¬ XTk.RootWidget[base];
};
WITH helpHandle
SELECT
FROM
handle: HelpStrings.Handle => h ¬ handle
ENDCASE => {};
IF dynamic
THEN {
parent: REF DynamicRec ¬ dyn.parent;
IF parent=
NIL
OR ~IsDynamicPopShell[parent.popShell]
THEN {
m: Xl.Match ¬ NEW[Xl.MatchRep ¬ [proc: PriviledgedUpEvent, handles: buttonReleaseFilter, tq: dyn.rootTQ, data: dyn]];
dyn.priviledgedMatch ¬ m;
XlDispatch.AddPriviledgedMatch[screen.connection, m];
}
ELSE {
IF h=NIL THEN h ¬ XTkHelpShells.CreateHelpWithPopShell[parent.popShell];
};
XTk.SetWidgetFlag[shell, dynamicPopUpFlag, TRUE];
XTk.AddPermanentMatch[
shell,
[proc: PopShellEvent, handles: filter, tq: dyn.rootTQ, data: dyn],
[buttonPress: TRUE, buttonRelease: TRUE, enterWindow: TRUE, leaveWindow: TRUE]
];
shell.attributes.overrideRedirect ¬ true;
shell.attributes.saveUnder ¬ true;
shell.s.geometry.borderWidth ¬ 3;
}
ELSE {
compensate ¬ [-1, -10]
};
IF h=NIL THEN h ¬ XTkHelpShells.CreateHelpWithPopShell[shell];
XTkHelpStrings.SetHandle[shell, h];
XTk.RegisterNotifier[shell, XTk.postStopFastAccessKey, RemovePops, dyn];
child ¬ createClosure.creator[parent: shell, closureData: createClosure.closureData, registerData: static.registerData, image: dyn.image, event: ev];
XTkWidgets.SetShellChild[shell, child];
BEGIN
--Do set window manager flags anyway, for the case that callback might have undone overrideRedirect
preferred: Xl.Geometry ¬ XTkFriends.PreferredSizeLR[shell]; --not yet realized!
szh.wmNormalHints.userSize ¬ szh.wmNormalHints.clientSize ¬ TRUE;
point.x ¬ MAX[MIN[point.x, screen.sizeInPixels.width - preferred.size.width - compensate.width], 0];
point.y ¬ MAX[MIN[point.y, screen.sizeInPixels.height - preferred.size.height - compensate.height], 0];
shell.s.geometry.pos ¬ point;
szh.wmNormalHints.obsoletePos ¬ point;
szh.wmNormalHintsChanged ¬ TRUE;
szh.transientForChanged ¬ TRUE;
END;
IF dyn.destructionStarted THEN RETURN;
--this is root thread, so realization will not conflict with destruction
XTkWidgets.RealizeShell[shell];
HelpStrings.MakeVisible[h, shell];
};
PopUp:
PUBLIC
PROC [pseudoBase: PseudoBase, event: XTk.Event, parentCarrier: PopCarrier ¬
NIL, image:
REF ¬
NIL, pos: Xl.Point ¬ [-1, -1]] = {
time: Xl.TimeStamp ¬ Xl.currentTime;
rootWindow: Xl.Window ¬ Xl.nullWindow;
screen: Xl.Screen ¬ NIL;
WITH event
SELECT
FROM
bp: Xl.ButtonPressEvent => {
time ¬ bp.timeStamp;
IF bp.sameScreen THEN rootWindow ¬ bp.root;
};
en: Xl.EnterNotifyEvent => {
time ¬ en.timeStamp;
IF en.sameScreen THEN rootWindow ¬ en.root;
};
ENDCASE => ERROR;
IF Xl.SetButtonGrabOwner[event.connection, time, pseudoBase]=succeeded
THEN {
static: REF StaticRec ~ NARROW[pseudoBase];
dyn: REF DynamicRec;
parent: REF DynamicRec ¬ NIL;
WITH parentCarrier
SELECT
FROM
static: REF StaticRec => parent ¬ static.currentDynamic;
w: XTk.Widget => {
root: XTk.Widget ¬ XTk.RootWidget[w];
IF IsDynamicPopShell[root] THEN parent ¬ DynamicFromShell[root];
};
dyn: REF DynamicRec => parent ¬ dyn;
ENDCASE => {};
dyn ¬ BuildDynamic[static, parent, image];
IF dyn#
NIL
THEN {
IF rootWindow#Xl.nullWindow THEN screen ¬ Xl.QueryScreen[event.connection, rootWindow.drawable];
ActualPopUp[dyn: dyn, ev: event, point: pos, screen: screen, dynamic: TRUE];
};
};
};
DynamicFromShell:
PROC [root: XTk.Widget]
RETURNS [
REF DynamicRec ¬
NIL] = {
--only shells will have the "myShellKey" property
WITH XTk.GetWidgetProp[root, myShellKey]
SELECT
FROM
dyn: REF DynamicRec => RETURN[dyn];
ENDCASE => {};
};
SimplePopUpWithRegularShell:
PUBLIC
PROC [list: ChoiceList, defaultNotify: XTk.WidgetNotifyProc, notifyTQ: XTk.
TQ ¬
NIL, screen: Xl.Screen ¬
NIL, pos: Xl.Point ¬ [-1, -1], registerData:
REF ¬
NIL, event: Xl.Event ¬
NIL, header: Rope.
ROPE ¬
NIL, helpHandle:
REF ¬
NIL] = {
createMenu: WidgetCreateClosure ~ WidgetCreateClosureFromChoiceList[list, defaultNotify, notifyTQ];
PopUpWithRegularShell[createMenu, screen, pos, registerData, NIL, event, header, helpHandle]
};
PopUpWithRegularShell:
PUBLIC
PROC [createMenu: WidgetCreateClosure, screen: Xl.Screen, pos: Xl.Point ¬ [-1, -1], registerData:
REF ¬
NIL, image:
REF ¬
NIL, event: Xl.Event ¬
NIL, header: Rope.
ROPE ¬
NIL, helpHandle:
REF ¬
NIL] = {
dyn: REF DynamicRec;
static: REF StaticRec ¬ NewPopStatic[];
static.image ¬ image;
static.registerData ¬ registerData;
static.createClosure ¬ createMenu;
static.header ¬ header;
dyn ¬ BuildDynamic[static, NIL, image];
IF dyn#
NIL
THEN {
ActualPopUp[dyn: dyn, screen: screen, point: pos, ev: event, dynamic: FALSE, helpHandle: helpHandle];
};
};
TestUpnessNow:
ENTRY Xl.EventProcType = {
dyn: REF DynamicRec ¬ NARROW[clientData];
WHILE dyn#
NIL
AND ~dyn.enteredShell
AND ~dyn.static.enteredBase
AND dyn.cascadedChild=
NIL
DO
parent: REF DynamicRec ¬ dyn.parent;
IF parent=NIL THEN RETURN;
IF ~IsDynamicPopShell[parent.popShell] THEN RETURN;
InternalDestroyIncludingCascaded[dyn];
dyn ¬ parent;
ENDLOOP
};
TestUpnessVerySoon: Xl.EventProcType = {
--Check inbetween to reduce chance of tearing it down. An occasional miss doesn't matter as the user will certainly cause other levenotifyEvents
dyn: REF DynamicRec ~ NARROW[clientData];
IF dyn#
NIL
AND ~dyn.destructionStarted
AND dyn.parent#
NIL
AND ~dyn.enteredShell
AND ~dyn.static.enteredBase
AND dyn.cascadedChild=
NIL
THEN
XlTQOps.EnqueueSoon[150, dyn.rootTQ <<any tq would do>>, TestUpnessNow, dyn]
};
TestUpnessSoon:
PROC [dyn:
REF DynamicRec] = {
IF dyn#
NIL
THEN
XlTQOps.EnqueueSoon[150, dyn.rootTQ <<any tq would do>>, TestUpnessVerySoon, dyn]
};
SetStyle:
PROC [base: XTk.Widget, style:
ATOM] = {
IF base#NIL AND XTk.HasClassKey[base, $Label] THEN XTkWidgets.SetStyleKey[base, style];
};
BaseButtonEvent: <<on static internalTQ>> Xl.EventProcType = {
static: REF StaticRec ~ NARROW[clientData];
base: XTk.Widget ~ static.base;
SELECT event.type
FROM
buttonPress => {
SetStyle[base, $BlackOnGray];
PopUp[static, event, base, static.image];
};
buttonRelease => {
DestroyIncludingAncestorsAndCascaded[static.currentDynamic];
IF base#
NIL
THEN {
IF static.enteredBase
THEN {
static.enteredBase ¬ FALSE;
SelectOnly[base, event];
};
SetStyle[base, NIL];
};
};
leaveNotify => {
lne: Xl.LeaveNotifyEvent ~ NARROW[event];
SetStyle[base, NIL];
SELECT lne.detail
FROM
ancestor, virtual, nonlinear, nonlinearVirtual => {
static.enteredBase ¬ FALSE;
TestUpnessSoon[static.currentDynamic];
};
inferior => {};
ENDCASE => {};
HelpStrings.Clear[static.helpHandle, static.help];
};
enterNotify => {
ene: Xl.EnterNotifyEvent ~ NARROW[event];
state: Xl.SetOfKeyButMask ~ ene.state;
IF base#
NIL
AND (state.button1
OR state.button2
OR state.button3
OR state.button4
OR state.button5)
THEN {
root: XTk.Widget ~ XTk.RootWidget[base];
static.enteredBase ¬ TRUE;
IF IsDynamicPopShell[root]
THEN {
rightShift: NAT ~ 32;
width: INT ~ base.actual.size.width;
pos: Xl.Point ¬ ene.rootP;
--put it to the right a little
IF ene.eventP.x>=0
AND ene.eventP.x<width
THEN {
rightLimit: NAT ~ MIN[width, rightShift];
shift: INT ¬ (width - ene.eventP.x) / 4;
IF ene.eventP.x<rightLimit
THEN
shift ¬ MAX[shift, (rightLimit - ene.eventP.x)];
pos.x ¬ pos.x + shift;
};
--put it at the same height
IF ene.eventP.y>=0
AND ene.eventP.y<base.actual.size.height
THEN {
pos.y ¬ pos.y - ene.eventP.y
};
SetStyle[base, $BlackOnGray];
HelpStrings.Display[static.helpHandle, static.help];
PopUp[static, event, root, static.image, pos];
};
};
};
ENDCASE => {};
};
PopShellEvent: <<on dyn.rootTQ>> Xl.EventProcType = {
dyn: REF DynamicRec ~ NARROW[clientData];
SELECT event.type
FROM
leaveNotify => {
lne: Xl.LeaveNotifyEvent ~ NARROW[event];
SELECT lne.detail
FROM
ancestor, virtual, nonlinear, nonlinearVirtual => {
dyn.enteredShell ¬ FALSE;
TestUpnessSoon[dyn];
};
inferior => {};
ENDCASE => {}
};
enterNotify => dyn.enteredShell ¬ TRUE;
buttonRelease => DestroyIncludingAncestorsAndCascaded[dyn];
ENDCASE => {};
};
PriviledgedUpEvent: <<tq doesn't matter>> Xl.EventProcType = {
dyn: REF DynamicRec ~ NARROW[clientData];
SELECT event.type
FROM
buttonRelease => {
RemovePriviledgedMatch[event.connection, dyn];
DestroyIncludingAncestorsAndCascaded[dyn];
};
ENDCASE => {};
};
NewPopStatic:
PROC [internalTQ: Xl.
TQ ¬
NIL]
RETURNS [
REF StaticRec] = {
static: REF StaticRec ~ NEW[StaticRec];
IF internalTQ=NIL THEN internalTQ ¬ Xl.CreateTQ[order: XTk.rootLockingOrder];
static.internalTQ ¬ internalTQ;
RETURN [static];
};
CreatePseudoBase:
PUBLIC
PROC [registerData:
REF ¬
NIL]
RETURNS [pseudoBase: PseudoBase] = {
static: REF StaticRec ¬ NewPopStatic[];
static.registerData ¬ registerData;
RETURN [static];
};
AssertBase:
ENTRY
PROC [base: XTk.Widget]
RETURNS [
REF StaticRec¬
NIL] = {
IF base#
NIL
THEN
WITH XTk.GetWidgetProp[base, myBaseKey]
SELECT
FROM
static: REF StaticRec => RETURN [static];
ENDCASE => {
static: REF StaticRec ~ NewPopStatic[];
XTk.AddPermanentMatch[base, [proc: BaseButtonEvent, handles: filter, tq: static.internalTQ, data: static], [ownerGrabButton: TRUE, buttonPress: TRUE, buttonRelease: TRUE, enterWindow: TRUE, leaveWindow: TRUE]];
static.base ¬ base;
XTk.PutWidgetProp[base, myBaseKey, static];
XTkOps.CallAndRegisterOnPostRealize[base, PostRealized, static];
RETURN [static];
};
};
PostRealized: XTk.WidgetNotifyProc = {
static: REF StaticRec ~ NARROW[registerData];
static.helpHandle ¬ XTkHelpStrings.GetHandle[widget];
};
MakeItBase:
PUBLIC
PROC [base: XTk.Widget, registerData:
REF ¬
NIL, createMenu: WidgetCreateClosure ¬
NIL, image:
REF ¬
NIL, help: Rope.
ROPE ¬
NIL] = {
static: REF StaticRec ~ AssertBase[base];
static.registerData ¬ registerData;
static.createClosure ¬ createMenu;
static.image ¬ image;
static.help ¬ help;
};
CreateSimplePopUpButton:
PUBLIC
PROC [text: Rope.
ROPE ¬
NIL, list: ChoiceList, defaultNotify: XTk.WidgetNotifyProc, notifyTQ: XTk.
TQ ¬
NIL, registerData:
REF ¬
NIL, help: Rope.
ROPE ¬
NIL]
RETURNS [button: XTk.Widget] = {
createMenu: WidgetCreateClosure ~ WidgetCreateClosureFromChoiceList[list, defaultNotify, notifyTQ];
button ¬ CreatePopUpButton[text, createMenu, registerData, NIL, help];
};
CreatePopUpButton:
PUBLIC
PROC [text: Rope.
ROPE ¬
NIL, createMenu: WidgetCreateClosure, registerData:
REF ¬
NIL, image:
REF ¬
NIL, help: Rope.
ROPE ¬
NIL]
RETURNS [button: XTk.Widget] = {
button ¬ XTkWidgets.CreateLabel[text: text];
MakeItBase[button, registerData, createMenu, image];
};
GetPopStatic:
PROC [carrier: PopCarrier]
RETURNS [
REF StaticRec ¬
NIL] = {
WITH carrier
SELECT
FROM
static: REF StaticRec => RETURN [static];
w: XTk.Widget => {
WITH XTk.GetWidgetProp[w, myBaseKey]
SELECT
FROM
static: REF StaticRec => RETURN [static];
ENDCASE => {};
};
ENDCASE => {}
};
SetMenuCreator:
PUBLIC
PROC [carrier: PopCarrier, createMenu: WidgetCreateClosure] = {
--Re-registers pop up callback.
static: REF StaticRec ~ GetPopStatic[carrier];
static.createClosure ¬ createMenu; --ok to crash if static=NIL
};
SetHelp:
PUBLIC
PROC [carrier: PopCarrier, help: Rope.
ROPE] = {
static: REF StaticRec ~ GetPopStatic[carrier];
static.help ¬ help; --ok to crash if static=NIL
};
RegisterBaseSelection:
PUBLIC
PROC [base: XTk.Widget, notify: XTk.WidgetNotifyProc, registerData, callData:
REF ¬
NIL, notifyTQ: XTk.
TQ ¬
NIL] = {
notifyClosure: REF NotifyClosure ¬ NIL;
IF notify#
NIL
THEN notifyClosure ¬
NEW[NotifyClosure ¬ [
w: base, notifyTQ: notifyTQ, notify: notify, registerData: registerData, callData: callData
]];
XTk.PutWidgetProp[base, myChoiceKey, notifyClosure];
};
ToRope:
PROC [x:
REF
ANY, default: Rope.
ROPE ¬
NIL]
RETURNS [Rope.
ROPE] = {
WITH x
SELECT
FROM
r: Rope.ROPE => RETURN [r];
r: REF TEXT => RETURN [Rope.FromRefText[r]];
a: ATOM => RETURN [Atom.GetPName[a]];
ENDCASE => RETURN [default]
};
ChoiceListData: TYPE = RECORD [defaultNotify: XTk.WidgetNotifyProc, cl: ChoiceList, notifyTQ: XTk.TQ ¬ NIL, registerData: REF];
ChoiceListCreateContents: CreateWidgetProc = {
container: XTkWidgets.Widget ~ XTkWidgets.CreateYStack[];
WITH closureData
SELECT
FROM
cld:
REF ChoiceListData => {
FOR cl: ChoiceList ¬ cld.cl, cl.rest
WHILE cl#
NIL
DO
child: XTkWidgets.Widget ¬ NIL;
notify: XTk.WidgetNotifyProc ¬ cl.first.notify;
impl: REF ¬ cl.first.impl;
key: REF ¬ cl.first.key;
text: Rope.ROPE ¬ ToRope[cl.first.image, NIL];
IF notify=NIL THEN notify ¬ cld.defaultNotify;
IF impl=
NIL
THEN {
help: Rope.ROPE ¬ ToRope[cl.first.help, NIL];
IF key=NIL THEN key ¬ cl.first.image;
child ¬ XTkWidgets.CreateButton[text: text, hitProc: notify, registerData: registerData, callData: key, tq: cld.notifyTQ, help: help];
}
ELSE
WITH impl
SELECT
FROM
cl2: ChoiceList => {
closure: WidgetCreateClosure ~ WidgetCreateClosureFromChoiceList[list: cl2, defaultNotify: notify, notifyTQ: cld.notifyTQ];
IF text=NIL THEN text ¬ "more...";
child ¬ CreatePopUpButton[text: text, createMenu: closure, registerData: registerData, image: cl.first.image];
IF key#
NIL
THEN
RegisterBaseSelection[base: child, notify: cld.defaultNotify, notifyTQ: cld.notifyTQ, registerData: registerData, callData: key];
};
wcc: WidgetCreateClosure => {
IF wcc.creator=ChoiceListCreateContents
THEN {
IF text=NIL THEN text ¬ "more...";
child ¬ CreatePopUpButton[text: text, createMenu: wcc, registerData: registerData, image: cl.first.image];
}
ELSE {
IF key=NIL THEN key ¬ cl.first.image;
child ¬ wcc.creator[parent: container, closureData: wcc.closureData, registerData: registerData, image: image];
IF child#
NIL
THEN
XTk.PutWidgetProp[child, myChoiceKey, NEW[NotifyClosure ¬ [w: child, notifyTQ: cld.notifyTQ, notify: notify, registerData: registerData, callData: key]]]
};
};
ENDCASE => {};
IF child#NIL THEN XTkWidgets.AppendChild[container, child];
ENDLOOP;
};
ENDCASE => ERROR;
RETURN [container];
};
WidgetCreateClosureFromChoiceList:
PUBLIC
PROC [list: ChoiceList, defaultNotify: XTk.WidgetNotifyProc, notifyTQ: XTk.
TQ ¬
NIL]
RETURNS [closure: WidgetCreateClosure] = {
cld: REF ChoiceListData ~ NEW[ChoiceListData ¬ [defaultNotify: defaultNotify, cl: list, notifyTQ: notifyTQ]];
closure ¬ NEW[WidgetCreateClosureRec ¬ [ChoiceListCreateContents, cld]];
};
Select:
PUBLIC
PROC [choice: XTk.Widget, event: XTk.Event] = {
root: XTk.Widget ¬ XTk.RootWidget[choice];
TearDown[root];
SelectOnly[choice, event];
};
SelectOnly:
PROC [choice: XTk.Widget, event: XTk.Event] = {
--Select an entry without calling TearDown
WITH XTk.GetWidgetProp[choice, myChoiceKey]
SELECT
FROM
nc: REF NotifyClosure => DoNotify[nc, event];
ENDCASE => {};
};
NullNotify: PUBLIC XTk.WidgetNotifyProc = {};
END.