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 = {
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];
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] = {
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] = {
IF dyn#NIL THEN {
WHILE dyn.parent#NIL DO dyn ¬ dyn.parent ENDLOOP;
InternalDestroyIncludingCascaded[dyn];
};
};

ForkDestroy: INTERNAL PROC [dyn: REF DynamicRec] = {
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
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;
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] = {
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 = {
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;
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;
};
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] = {
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] = {
WITH XTk.GetWidgetProp[choice, myChoiceKey] SELECT FROM
nc: REF NotifyClosure => DoNotify[nc, event];
ENDCASE => {};
};
NullNotify: PUBLIC XTk.WidgetNotifyProc = {};

END.

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

Make sure we re-enable poping, even on widget destruction due to external causes.
--only base widgets have the "myBaseKey" property
Sets up the data structure and the tq's but not yet the widget
--Data structure maintenace is monitored
--Widget destruction is forked
--Fork destruction so it may be initialized from within monitored region 
--Do set window manager flags anyway, for the case that callback might have undone overrideRedirect 
--this is root thread, so realization will not conflict with destruction
--only shells will have the "myShellKey" property

--Check inbetween to reduce chance of tearing it down.  An occasional miss doesn't matter as the user will certainly cause other levenotifyEvents
--put it to the right a little
--put it at the same height
--Re-registers pop up callback.  

--Select an entry without calling TearDown

�Êt–
(cedarcode) style•NewlineDelimiter

˜
codeš
œ™Kšœ
Ïe
œ7™BKš
œ<™<K™.K™—šÏk	œŠ
˜“
K˜—šÏn
œžœ
ž˜Kšžœ~˜…
Kšžœ
˜Kšžœ˜—Kšžœ
žœ˜K˜Kš
œ,˜,Kšœžœžœ
žœÏc4˜PKšœžœžœ
žœ 6˜QKšœ
žœžœ
žœ ˜5K˜Kš
œJ˜JKš
œd˜dK˜šŸœžœžœžœ˜:Kšžœžœ
žœ(˜9K˜—K˜šŸœžœžœ#˜^K˜KK˜K˜2Kšžœžœ
žœ˜,K˜—K˜šŸœžœžœ˜HKš
œ#˜#šžœžœ
žœ˜Kšœžœ
˜Kšžœ
žœ)˜<Kš
œ˜—K˜—K˜šŸ
œ˜$Kš
œQ™QKšœžœžœ˜+Kšœžœ
˜Kš
œ˜K˜—K˜šŸœžœ
žœ˜/šžœ	žœ
ž˜KšœžœJ˜Uš
œ˜Kš
œ%˜%Kš
œ1™1šžœ!žœ
ž˜0KšœžœJ˜UKšžœ˜—Kšžœžœ>˜]K˜—Kšœžœ9˜AKšžœ˜
—Kš
œ˜—K˜šœžœžœ 6˜QKšœžœžœ ˜1Kšœ
žœžœ˜8Kš
œ#˜#Kšœžœžœ
˜Kšœžœžœ
˜Kšœžœ ˜,Kš
œ˜Kšœžœžœ
˜Kšœ!žœ
˜%Kšœ
žœž˜Kš
œ˜K˜—šœžœžœ #˜@Kšœžœžœ
˜Kšœžœžœ
˜!Kšœžœ˜Kšœžœ
˜Kš
œ˜Kšœžœžœ
˜$Kšœžœžœ
˜Kšœžœžœ
˜Kšœž˜ Kš
œ˜K˜—šœžœžœ˜Kš
œ˜Kšœ
žœ
˜Kš
œ˜Kšœž˜Kš
œ˜—K˜šŸœžœ
žœ
žœžœžœžœžœžœ˜|Kš
œ>™>Kš
žœžœ
žœžœ
žœ
˜8šžœžœ
žœ˜Kšœžœ$˜-šžœžœ
žœ˜Kš
žœžœžœ
žœžœ˜EKš
œ'˜'K˜—Kšœžœ
˜Kš
œ˜Kš
œ˜Kš
œ ˜ šžœžœ
žœ˜Kš
œ˜Kš
œ7˜7Kš
œ˜Kšžœžœ
žœ˜2Kš
œ˜—Kšžœžœ
žœ7˜MKš
œ˜K˜—K˜—K˜šŸœžœ
žœžœ˜>Kšžœžœ
žœ'˜6Kš
œ˜—K˜šŸ œžœ
žœžœ˜Išžœžœ
žœ
˜Kšœžœ ˜)Kšœžœ˜$Kšœžœ˜#Kšœžœ
˜Kšœžœžœ
˜*šžœžœ
žœžœ˜1Kšœžœ˜K˜—Kšžœžœžœ˜?Kš
œ˜Kš
œ˜Kšžœ
˜—K˜—šŸ$œžœ
žœžœ˜JKš
œ(™(Kš
œ™šžœžœ
žœ˜Kšžœžœ
žœžœ
˜1Kš
œ&˜&Kš
œ˜—K˜—K˜šŸœžœ
žœžœ˜4J™IKš
œ!˜!Kšœžœ
˜KšžœžœA˜aKš
œ˜—K˜šŸœ˜Kšœžœ
˜'Kšžœžœ ˜@K˜—K˜šŸœžœžœ!˜8šžœ
žœ˜šžœ
žœžœ
˜"Kšœ.žœ
˜2Kš
œ˜—KšžœH˜L—Kš
œ˜—K˜šŸœ.˜<Kšœžœžœ
˜+Kš
œ\˜\K˜—K˜šŸœžœžœKžœžœžœžœžœ˜›
Kš
œ˜Kšœžœ˜#Kš
œ˜Kš
œ:˜:Kš
œ ˜ Kšœžœ˜Kšœ +˜IKš
žœžœžœ
žœ
žœ˜=Kšœ2žœi˜Ÿ
Kš
œ!˜!Kš
œ*˜*šžœžœ
žœžœ
˜šžœ˜Kšœ"žœ˜'Kš
œ"˜"K˜
—šžœ˜Kš	œžœžœ
žœžœ˜Tš
žœžœ
žœžœžœ˜.Kš
œ˜Kšœ$ ˜BKšžœžœ˜ Kšžœžœ˜ K˜—Kš
œ2˜2Kš
œ˜——šžœžœžœ˜#Kšœ:žœ
˜?K˜—Kš
œ˜šžœžœ
žœ˜Kš
œ#˜#Kš
œ(˜(K˜—šžœžœ
ž˜K˜(Kšžœ˜—šžœ	˜šžœ˜Kšœžœ˜$šžœžœ
žœ%˜5šžœ˜Kšœžœd˜uKš
œ˜Kš
œ5˜5K˜
—šžœ˜Kšžœžœ
žœ;˜HK˜——Kšœ+žœ˜1š
œ˜Kš
œ˜Kšœ.Ïb
œ˜CKš	œžœžœžœžœ
˜NKš
œ˜—Kš
œ)˜)Kš
œ"˜"K˜"K˜
—šžœ˜Kš
œ˜Kš
œ˜——Kšžœžœ
žœ2˜?Kš
œ#˜#Kš
œH˜HKš
ϥ
˜•
Kš
œ'˜'š
ž˜Kš
œd™dKšœ< ˜OKšœ<žœ
˜AKšœ
žœ
žœS˜dKšœ
žœ
žœV˜gK˜Kš
œ&˜&Kšœžœ
˜ Kšœžœ
˜Kšžœ
˜—Kšžœžœ
žœ
˜&Kš œ.™HKš
œ˜Kš
œ"˜"K˜—K˜šŸœžœ
žœHžœ	žœžœ˜Ž
Kš
œ$˜$Kš
œ&˜&Kšœžœ
˜šžœžœ
ž˜š
œ˜Kš
œ˜Kšžœžœ˜+Kš
œ˜—š
œ˜Kš
œ˜Kšžœžœ˜+K˜—Kšžœžœ
˜—šžœEžœ˜MKšœžœ
žœ
˜+Kšœžœ˜Kšœžœžœ
˜šžœžœ
ž˜Kšœžœ-˜8š
œ˜Kš
œ%˜%Kšžœžœ!˜@K˜—Kšœžœ˜$Kšžœ˜—Kš
œ*˜*šžœžœ
žœ˜Kšžœžœ@˜`KšœFžœ˜LK˜—Kš
œ˜—Kš
œ˜—K˜š
Ÿœžœžœžœžœ˜LKš
œ1™1šžœ%žœ
ž˜4Kšœžœžœ˜#Kšžœ˜—Kš
œ˜—K˜šŸœžœ
žœGžœžœžœ*žœžœžœžœžœžœžœ˜�Kš
œc˜cKšœ=žœ˜\Kš
œ˜K™—šŸœžœ
žœ^žœžœ	žœžœžœžœžœžœžœ˜ç
Kšœžœ˜Kšœžœ˜'Kš
œ˜Kš
œ#˜#Kš
œ"˜"Kš
œ˜Kšœžœ	˜'šžœžœ
žœ˜KšœFžœ˜eK˜—Kš
œ˜—K˜šŸ
œžœ˜)Kšœžœžœ
˜)š
žœžœ
žœžœžœžœ
ž˜\Kšœžœ˜$Kšžœžœ
žœ
žœ
˜Kšžœ%žœ
žœ
˜3Kš
œ&˜&Kš
œ
˜
Kš
ž˜—K˜K˜—šŸœ˜(K™‘
Kšœžœžœ
˜)šžœžœ
žœžœžœ
žœžœžœžœ
ž˜Š
Kš
œL˜L—K˜—K˜šŸœžœžœ˜.šžœžœ
žœ
˜Kš
œQ˜Q—Kš
œ˜—K˜šŸœžœžœ˜2Kšžœžœ
žœžœ%˜WK˜—K˜šŸœ/˜>Kšœžœ
žœ
˜+Kš
œ˜šžœž˜š
œ˜Kš
œ˜Kš
œ)˜)K˜—š
œ˜Kš
œ<˜<šžœžœ
žœ˜šžœžœ˜Kšœžœ
˜Kš
œ˜Kš
œ˜—Kšœžœ˜K˜—K˜—š
œ˜Kšœžœ˜)Kšœžœ˜šžœž˜š
œ3˜3Kšœžœ
˜Kš
œ&˜&Kš
œ˜—Kš
œ˜Kšžœ˜—Kš
œ2˜2K˜—š
œ˜Kšœžœ˜)Kš
œ&˜&šžœžœ
žœžœžœžœžœžœ˜lKš
œ(˜(Kšœžœ
˜šžœžœ˜!Kšœžœ˜Kšœžœ˜$Kš
œ˜Kš
œ™šžœžœžœ˜0Kšœžœžœ˜)Kšœžœ˜(šžœžœ
˜ Kšœžœ%˜0—K˜Kš
œ˜—Kš
œ™šžœžœ&žœ˜BKš
œ˜Kš
œ˜—Kš
œ˜Kš
œ4˜4Kš
œ.˜.K˜—K˜—K˜—Kšžœ˜—K˜K˜—šŸ
œ(˜5Kšœžœžœ
˜)šžœž˜š
œ˜Kšœžœ˜)šžœž˜š
œ3˜3Kšœžœ
˜Kš
œ˜Kš
œ˜—Kš
œ˜Kšžœ˜
—K˜—Kšœ#žœ
˜(Kš
œ;˜;Kšžœ˜—K˜K˜—šŸœ,˜>Kšœžœžœ
˜)šžœž˜š
œ˜Kš
œ.˜.Kš
œ*˜*Kš
œ˜—Kšžœ˜—K˜K˜—šŸœžœžœžœžœžœ˜HKšœžœ
žœ˜'Kšžœžœ
žœ7˜MKš
œ˜Kšžœ
˜K˜—K˜šŸœžœ
žœžœžœžœ˜\Kšœžœ˜'Kš
œ#˜#Kšžœ
˜K˜K˜—šŸ
œžœ
žœžœžœžœ˜Išžœžœ
žœ
˜šžœ$žœ
ž˜3Kšœžœžœ
˜)šžœ˜Kšœžœ˜'Kšœ}žœžœžœžœžœ˜Ò
Kš
œ˜Kš
œ+˜+Kš
œ@˜@Kšžœ
˜K˜———K˜—šŸœ˜&Kšœžœ
žœ˜-Kš
œ5˜5Kš
œ˜—K˜šŸ
œžœ
žœ"žœžœ$žœ	žœžœ
žœžœ˜—
Kšœžœ˜)Kš
œ#˜#Kš
œ$˜$Kš
œ˜Kš
œ˜K˜—K˜šŸœžœ
žœ
žœžœGžœžœžœžœ
žœžœžœ˜Ü
Kš
œc˜cKšœ;žœ˜FKš
œ˜K˜—šŸœžœ
žœ
žœžœ1žœžœ	žœžœ
žœžœžœ˜º
Kš
œ,˜,Kš
œ4˜4Kš
œ˜—K˜š
Ÿœžœžœžœ
žœ˜Jšžœ	žœ
ž˜Kšœžœžœ
˜)š
œ˜šžœ!žœ
ž˜0Kšœžœžœ
˜)Kšžœ˜—Kš
œ˜—Kšžœ˜—K˜—K˜šŸœžœ
žœ;˜VK™!Kšœžœ#˜.Kšœ$ ˜?Kš
œ˜K˜—šŸœžœ
žœ"žœ˜?Kšœžœ#˜.Kšœ ˜0Kš
œ˜—K˜šŸœžœ
žœJžœžœžœžœ˜’
Kšœžœžœ
˜'šžœžœ
žœžœ˜8Kš
œ[˜[Kš
œ˜—Kš
œ4˜4Kš
œ˜—K˜šŸœžœžœ
žœžœžœžœžœ˜Kšžœžœ
ž˜Kšœžœžœ˜Kšœžœ
žœžœ˜,Kšœžœžœ˜%Kšžœžœ
˜—Kš
œ˜K˜—KšœžœžœEžœžœžœ˜K˜šŸœ˜.Kš
œ9˜9šžœ
žœ
ž˜šœžœ˜šžœ"žœžœ
ž˜4Kšœžœ
˜Kš
œ/˜/Kšœžœ˜Kšœžœ˜Kšœžœžœ˜.Kšžœžœ
žœ˜.šžœžœ
žœ˜Kšœžœžœ˜-Kšžœžœ
žœ˜%Kš
Ϡ
˜†
K˜
—šžœ
žœžœ
ž˜š
œ˜Kš
œ{˜{Kšžœžœ
žœ˜"Kš
œn˜nšžœžœ
žœ
˜Kš
œ�
˜�
—K˜—š
œ˜šžœ%˜'šžœ˜Kšžœžœ
žœ˜"Kš
œj˜jK˜
—šžœ˜Kšžœžœ
žœ˜%Kš
œo˜ošžœžœ
žœ
˜Kšœ&žœp˜™
—K˜——K˜—Kšžœ˜—Kšžœžœ
žœ*˜;Kšžœ
˜—K˜—Kšžœžœ
˜—Kšžœ
˜K˜K˜—šŸ!œžœ
žœGžœžœžœ#˜©
KšœžœžœP˜mKšœ
žœ;˜HKš
œ˜—K˜šŸœžœ
žœ+˜>Kš
œ*˜*Kš
œ˜Kš
œ˜K˜K™—šŸ
œžœ+˜;K™*šžœ(žœ
ž˜7Kšœžœ&˜-Kšžœ˜—K˜K™—KšŸ
œžœ˜-K˜Kšžœ
˜K˜—…—Plª