<<>> <> <> <> <> <> <<>> DIRECTORY Atom USING [PropList], Xl USING [Attributes, Connection, dontUse, Event, Geometry, MatchList, MatchRep, nullVisual, nullWindow, Point, Screen, ScreenDepth, SetOfEvent, Size, TQ, unspecifiedEvents, Visual, Window]; XTk: CEDAR DEFINITIONS ~ BEGIN OPEN Xl; <<>> <> <<>> <> <> <<>> <> <<>> <> <> <<>> <> <> <> <> <> <> <> <<>> <> <> <> <> <> <> <> <> <> <> <<>> <> <> <> <> <<>> <> <> <> <> <<>> <> <<>> <> <<>> <> <> <> <> <> <<>> <<>> <> <> Event: TYPE = Xl.Event; TQ: TYPE = Xl.TQ; Widget: TYPE = REF WidgetRep; dontUse: INT = Xl.dontUse; rootLockingOrder: INT = 5; --useful if you create your own rootTQ Mapping: TYPE = {mapped, unmapped, unconfigured, dontUse, unmapIfMapped, mapIfUnmapped, unmapIfUnconfigured, mapIfUnconfigured}; <> <> <> <> WidgetSpec: TYPE = RECORD [ <<--Fields useful for initialization of widgets>> class: Class Ź NIL, geometry: Xl.Geometry Ź [], --as requested mapping: Mapping Ź dontUse, --as requested instName: ATOM Ź NIL, --key for database lookup; class might overwrite this clientData: REF Ź NIL --reserved for clients ]; FastAccessState: TYPE = {ok, warned}; <> WindowState: TYPE = {realized, warned, screened, existing, dead}; WidgetRep: TYPE = MONITORED RECORD [ <<--Monitor used for small leaf procedures. The idea is that it this is safer then to have packages use global monitors. This way in case of errors only single widgets wedge and take only a single widgets tree down. This makes debugging easier.>> s: WidgetSpec Ź [], --public read - write depth: INTEGER Ź 0, --public read - write visual: Visual Ź nullVisual, --public read - write attributes: Attributes Ź [], --public read - write flags: PRIVATE WidgetFlags Ź ALL[FALSE], --private to prevent unmonitored access parent: <> Widget Ź NIL, matchListX: PRIVATE LIST OF MatchRep Ź NIL, --permanent matchList1: PRIVATE MatchList Ź NIL, --temporary connection: <> Connection Ź NIL, window: <> Window Ź nullWindow, screenDepth: <> ScreenDepth Ź NIL, fastAccessAllowed: <> FastAccessState Ź warned, -- not monitored. <<--When changed, the new value is automatically set by XTkImpl before class procedures are called. Readonly even to class implementors.>> state: <> WindowState Ź existing, -- (rootTQ+LX)! <<--When changed, the new value is automatically set by XTkImpl before class procedures are called. Readonly even to class implementors.>> actual: <> Xl.Geometry Ź [], --final geometry actualMapping: <> Mapping Ź dontUse, --final visibility (rootTQ) <<--Normally set by class when mapping change is made. >> rootTQ: <> TQ Ź NIL, --initialized on BindScreen notifiers: PRIVATE REF Ź NIL, props: PRIVATE REF Ź NIL, wClassData: PRIVATE SEQUENCE leng: NAT OF REF <<--Every layer in class hierarchy can put some class dependent data here>> ]; CreateWidget: PROC [widgetSpec: WidgetSpec, class: Class Ź NIL, arguments: Atom.PropList Ź NIL] RETURNS [Widget]; <> <> <> <> <<>> DestroyWidget: PROC [widget: Widget, startReconfigureParent: BOOL Ź TRUE]; <> <> <<>> <<>> <> <<>> <> <> WidgetFlagKey: TYPE = {wf0, wf1, wf2, wf3, wf4, wf5, wf6, wf7, wf8, wf9, wf10, wf11, wf12, wf13, wf14, wf15, wf16, wf17, wf18, wf19, wf20, wf21, wf22, wf23, wf24, wf25, wf26, wf27, wf28, wf29, wf30, wf31}; WidgetFlags: TYPE = PACKED ARRAY WidgetFlagKey OF BOOL Ź ALL[FALSE]; SetWidgetFlag: PROC [widget: Widget, key: WidgetFlagKey, value: BOOL Ź TRUE]; GetWidgetFlag: PROC [widget: Widget, key: WidgetFlagKey] RETURNS [BOOL] = INLINE { RETURN [widget.flags[key]]; }; mustReConsiderChildren: WidgetFlagKey = wf0; --Set by any child which wants parent to reconsider its children. preferredSizeFromDB: WidgetFlagKey = wf1; --if this flag is set and the window not realized the database is queried for the preferred size of a widget. Otherwise, and, when the database doesn't provide a value the normal class method is used. preferredSizeCurrent: WidgetFlagKey = wf2; --if this flag is set and the window already is realized the specified size of the widget is to be used. Otherwise the normal class method is used. ClassFlagKey: TYPE = {cf0, cf1, cf2, cf3, cf4, cf5, cf6, cf7, cf8, cf9, cf10, cf11, cf12, cf13, cf14, cf15, cf16, cf17, cf18, cf19, cf20, cf21, cf22, cf23, cf24, cf25, cf26, cf27, cf28, cf29, cf30, cf31}; ClassFlags: TYPE = PACKED ARRAY ClassFlagKey OF BOOL Ź ALL[FALSE]; SetClassFlag: PROC [class: ImplementorClass, key: ClassFlagKey, value: BOOL Ź TRUE]; GetClassFlag: PROC [class: Class, key: ClassFlagKey] RETURNS [BOOL] = INLINE { RETURN [class.flags[key]]; }; <> <<>> GetWidgetProp: PROC [widget: Widget, key: REF] RETURNS [REF]; <> PutWidgetProp: PROC [widget: Widget, key: REF, value: REF Ź NIL]; <> <> <<>> <> <<>> <> <> WidgetNotifyProc: TYPE = PROC [widget: Widget, registerData, callData: REF Ź NIL, event: Event Ź NIL]; <> <> <> <> RegisterNotifier: PROC [widget: Widget, key: REF, procLX: WidgetNotifyProc, registerData: REF Ź NIL]; <> <> UnRegisterNotifier: PROC [widget: Widget, key: REF, procLX: WidgetNotifyProc, registerData: REF Ź NIL]; <> preWindowCreationLRKey: READONLY ATOM; -- Ź $preWindowCreation preWindowCreationKey: READONLY ATOM; -- Ź $preWindowCreation <> <> <<>> postWindowCreationLRKey: READONLY ATOM; -- Ź $postWindowCreation postWindowCreationKey: READONLY ATOM; -- Ź $postWindowCreation <> <> <<>> postConfigureLRKey: READONLY ATOM; -- Ź $postConfigure postConfigureKey: READONLY ATOM; -- Ź $postConfigure <> <> <<>> postWindowDestructionLRKey: READONLY ATOM; -- Ź $postWindowDestruction postWindowDestructionKey: READONLY ATOM; -- Ź $postWindowDestruction <> <> <<>> preStopFastAccessKey: READONLY ATOM; -- Ź $preStopFastAccess <> <> <<>> postStopFastAccessLRKey: READONLY ATOM; -- Ź $postStopFastAccess postStopFastAccessKey: READONLY ATOM; -- Ź $postStopFastAccess <> bindScreenLRKey: PUBLIC ATOM; -- Ź $bindScreen bindScreenKey: PUBLIC ATOM; -- Ź $bindScreen <> <<>> forgetScreenLRKey: PUBLIC ATOM; -- Ź $forgetScreen forgetScreenKey: PUBLIC ATOM; -- Ź $forgetScreen <> <<>> postWidgetDestructionKey: READONLY ATOM; -- Ź $postWidgetDestruction <> <> <> <<>> <> AddPermanentMatch: PROC [widget: Widget, matchRep: MatchRep, generate: SetOfEvent Ź unspecifiedEvents]; <> <> <> <> <> AddTemporaryMatch: PROC [widget: Widget, matchRep: MatchRep, generate: SetOfEvent Ź unspecifiedEvents]; <> <> <> <> <> G: PROC [w, h, b: INT Ź dontUse] RETURNS [Geometry] = INLINE { RETURN [[pos: [dontUse, dontUse], size: [w, h], borderWidth: b]] }; RootWidget: PROC [widget: Widget] RETURNS [Widget]; <> <> <<>> BorderWidth: PROC [widget: Widget] RETURNS [INT]; <> ScreenBound: PROC [widget: Widget] RETURNS [BOOL]; <> <<>> SynchronizeFastAccess: PROC [widget: Widget, protectTQ: TQ]; <> <> <<>> <> <> <> <<>> OrphanProc: TYPE = PROC [orphan: Widget]; <> <> <> <<>> RegisterOrphanProc: PROC [self: Widget, orphanProcLR: OrphanProc Ź NIL]; <> <> <<>> <<>> <> HasClass: PROC [widget: Widget, class: Class] RETURNS [BOOL] = <> INLINE {IF HasProperClass[widget, class] THEN RETURN [TRUE] ELSE RETURN [HasSubClass[widget, class]]}; HasProperClass: PROC [widget: Widget, class: Class] RETURNS [BOOL] = <> INLINE {RETURN [widget.s.class=class]}; HasSubClass: PROC [widget: Widget, class: Class] RETURNS [BOOL]; <> <<>> HasClassKey: PROC [widget: Widget, classKey: ATOM] RETURNS [BOOL] = <> INLINE {IF HasProperClassKey[widget, classKey] THEN RETURN [TRUE] ELSE RETURN [HasSubClassKey[widget, classKey]]}; HasProperClassKey: PROC [widget: Widget, classKey: ATOM] RETURNS [BOOL] = <> INLINE {RETURN [widget.s.class.key=classKey]}; HasSubClassKey: PROC [widget: Widget, classKey: ATOM] RETURNS [BOOL]; <> <<>> ClassName: PROC [widget: Widget] RETURNS [ATOM] = INLINE { <> <> RETURN [widget.s.class.className[widget]] }; <<>> <> <<>> NoteChildChange: PROC [widget: Widget]; <> <> <> <<>> NoteChildChangePropagate: PROC [widget: Widget, top: Widget Ź NIL]; <> <> <<>> NoteGeometryChange: PROC [widget: Widget, geometry: Geometry Ź []]; <> <> <> <> <<>> NoteGeometryChangePropagate: PROC [widget: Widget, geometry: Geometry Ź [], top: Widget Ź NIL]; <> <> <> <> <<>> NoteMappingChange: PROC [widget: Widget, mapping: Mapping Ź dontUse]; <> <> <> <> <<>> NoteMappingChangePropagate: PROC [widget: Widget, mapping: Mapping Ź dontUse, top: Widget Ź NIL]; <> <> <<>> StartReconfigureChildren: PROC [widget: Widget]; <> <> NoteAndStartReconfigure: PROC [widget: Widget, geometry: Geometry Ź [], mapping: Mapping Ź dontUse]; <> <> <> <<>> ShallowInternalEnumerateChildren: PROC [widget: Widget, proc: EachChild, data: REF Ź NIL]; <> <> <> <<>> <> <<... but by widget sub class implementations>> <<** means: called on rootTQ only>> <<++ means: called on any thread>> Class: TYPE = REF READONLY ClassRec; ImplementorClass: TYPE = REF ClassRec; ClassRec: TYPE = RECORD [ key: ATOM Ź NIL, properties: Atom.PropList Ź NIL, --Do not use if you don't understand the inheritance and locking model. classNameHint: ATOM Ź NIL, super: Class Ź NIL, wDataIdx: NAT Ź 0, <<--Index into wClassData of widget for start of fields>> <<--This field is set automatically at class creation; client values are ignored>> wDataNum: NAT Ź 0,--number of subClassData entries in widgets <<--This layer in the class hierarchy occupies fields [wDataIdx..wDataIdx+wDataNum)>> flags: ClassFlags Ź ALL[FALSE], --private to prevent unmonitored access configureLR: PRIVATE ConfigureProc Ź NIL, --** <<--Creation of window(realization), change of mapping, geometry>> <<-- If creation: Connection filled in; preRealizers are called before calling class proc >> <<--If a widget is reconfigured, it has no choice but must do it exactly as requested>> <<--It might reconfigure its children in turn...>> <<--It is ok to default this procedure>> <<--If a non-defaulted configureLR proc wants to inherit, it must do so itself.>> <<--Recursion through widget tree must be provided, it is not built in.>> <<--Interactive access is already stopped externally if window needs to be destroyed.>> actualCreateWindowLR: PRIVATE WidgetProc Ź NIL, --** <<--Used by some ConfigureProc's; especially the default configureLR.>> <<--The actual create window part and eventaul mapping, all widget fields (except widget.window) are already set up by caller.>> destroyWindowLR: PRIVATE TerminateProc Ź NIL, --** <<--Called instead of configureLR when window destruction is requested. >> <<--Subclass chaining and tree recursion automatically.>> removeChildLR: PRIVATE RemoveChildProc Ź NIL, --** <<--Called when child widget needs to be removed. >> <<--It is ok if a widget class does NOT recognize and remove its children.>> <<--Subclass chaining automatically. >> <<--Once widget destruction is started removeChildLR might not be called anymore. >> <<--Caller takes care of stopping and forgetting screen.>> pleaseResizeChild: WidgetNChildProc Ź NIL, <<--Can be called from any child (unsynchronized) on its parent.>> <<--Might be ignored, children resized, or request propagated up the widget tree>> <<--If the proc decides to resize children it must do so on the rootTQ.>> <<--Defaulting this procedure in a root class means ignoring request.>> <<--If a non-defaulted pleaseResizeChild proc wants to inherit, it must do so itself.>> preferredSizeLR: PreferredSizeProc Ź NIL, --** <<--Returns preferred geometry for itself >> <<--maySkip: dimension is not asked for [but might be returned anyway] >> <<--proposed: proposal for dimension >> <<--preferredSizeLR might or might not take advantage of maySkip and proposed>> <<--but any returned value#dontUse might be used even if maySkip was true. >> <<--If a non-defaulted preferredSizeLR proc wants to inherit, it must do so itself>> <<--Environment (screen, connection) must be available>> preStopFastAccess: TerminateProc Ź NIL, --++ <<--If widget is terminated it must stop doing interactions>> <<--Subclass chaining and tree recursion automatically>> fullStopFastAccessLR: FullStopFastAccessProc Ź NIL, --** <<--If widget is terminated it must stop doing interactions>> <<--Subclass chaining and tree recursion automatically>> bindScreenLX: BindScreenProc Ź NIL, --** <<--Subclass chaining and tree recursion automatically>> forgetScreenLR: TerminateProc Ź NIL, --** <<--Subclass chaining and tree recursion automatically>> destroyWidget: WidgetProc Ź NIL, <<--Subclass chaining and optional tree recursion automatically>> internalEnumerateChildren: PRIVATE InternalEnumerateChildrenProc Ź NIL, --++ <<--Shallow enumerates children widgets as used for propagation through widget tree! Not thaught for general client usage. Should be fast, not use locking as it is used in terminators. Used for procedures automatically recursing through widget tree.>> <<--Adding or removing children while enumeration might not be considered in time.>> <<--Chained, in unknown order.>> superWithIEC: PRIVATE Class Ź NIL, <<--Allows to fast stop chaining internalEnumerateChildren>> initInstPart: PRIVATE InitInstancePartProc Ź NIL, <<--Called from CreateWidget only>> <<--Chained: super class first, sub class afterwards>> cursorKey: PRIVATE REF Ź NIL, <<--Used if cursor is illegal at realization time; inherits if NIL>> backgroundKey: PRIVATE REF Ź NIL, <<--Used if background is illegal at realization time; inherits if NIL>> borderColorKey: PRIVATE REF Ź NIL, <<--Used if background is illegal at realization time; inherits if NIL>> eventMask: PRIVATE SetOfEvent Ź unspecifiedEvents, <<--Used for initialization; ors with inherited classes >> className: PRIVATE ClassNameProc Ź NIL, <<--Should return key for database lookup.>> <<--Called anytime any thread.>> createSubClass: PRIVATE CreateSubClassProc Ź NIL, <<--Called in CreateClass only, just before returning>> <<--Chained: Called super class first, sub class afterwards, for every layer in class hierarchy providing this procedure. >> cDataIdx: NAT Ź 0, <<--index into cClassData of class for start of fields>> <<--This field is set automatically at class creation; client values are ignored>> cDataNum: NAT Ź 0,--number of cClassData entries in class <<--This layer in the class hierarchy occupies fields [cDataIdx..cDataIdx+cDataNum)>> cClassData: SEQUENCE leng: NAT OF REF <<--Every layer in class hierarchy can put some data here>> ]; WidgetProc: TYPE = PROC [widget: Widget]; <<>> InitInstancePartProc: TYPE = PROC [widget: Widget, arguments: Atom.PropList]; <<>> InternalEnumerateChildrenProc: TYPE = PROC [self: Widget, classLevel: Class, proc: EachChild, data: REF] RETURNS [stop: BOOL Ź FALSE]; EachChild: TYPE = PROC [parent: Widget, child: Widget, data: REF] RETURNS [stop: BOOL Ź FALSE]; <<>> WidgetNChildProc: TYPE = PROC [widget, child: Widget]; <<--child must be NIL, or, child of widget>> <<>> RemoveChildProc: TYPE = PROC [widget, child: Widget] RETURNS [done: BOOL Ź FALSE]; <<--Conservative: Returns TRUE when child removed; Returns FALSE when child not removed or not found. >> <<>> FullStopFastAccessProc: TYPE = PROC [widget: Widget, protectTQLR: TQProc, reason: TerminationReason]; <<>> TQProc: TYPE = PROC [tq: TQ]; <<>> GeometryOption: TYPE = {x, y, w, h, b}; GeometryRequest: TYPE = PACKED ARRAY GeometryOption OF BOOL Ź ALL[FALSE]; PreferredSizeProc: TYPE = PROC [widget: Widget, mode: ATOM Ź NIL, proposed: Xl.Geometry Ź [], maySkip: GeometryRequest Ź ALL[FALSE]] RETURNS [preferred: Xl.Geometry Ź []]; ConfigureProc: TYPE = PROC [widget: Widget, geometry: Xl.Geometry Ź [], mapping: Mapping Ź dontUse, reConsiderChildren: BOOL Ź FALSE]; <<>> TerminateProc: TYPE = PROC [widget: Widget, reason: TerminationReason]; TerminationReason: TYPE = {normal, errorWindow, errorConnection}; <<--Termination should be propagated to children>> <<--Normal termination should destroy the window>> <<--Other termination should not access the connection; it or the window might be broken>> <<>> BindScreenProc: TYPE = PROC [widget: Widget, rootTQ: TQ, screen: Xl.Screen, screenDepth: Xl.ScreenDepth Ź NIL]; <<>> ClassNameProc: TYPE = PROC [widget: Widget] RETURNS [key: ATOM Ź NIL]; <<--Returns a class name>> <<--this is not unique but handy for class key in database lookup>> <<>> CreateSubClassProc: TYPE = PROC [superClass: Class, newClass: ImplementorClass, bottom: BOOL]; <<--Called when a new class or subclass is generated>> <<--Called chained, super class first>> <<--bottom means: createdClass=superClass>> <> <> BasicMethodsRec: TYPE = RECORD [--used for class creations <<--general fields>> key: ATOM, classNameHint: ATOM Ź NIL, --useful for className super: Class Ź NIL, wDataNum: NAT Ź 0, cDataNum: NAT Ź 0, addFlags: ClassFlags Ź ALL[FALSE], <<--basic methods>> preferredSizeLR: PreferredSizeProc Ź NIL, configureLR: ConfigureProc Ź NIL, actualCreateWindowLR: WidgetProc Ź NIL, destroyWindowLR: TerminateProc Ź NIL, removeChildLR: RemoveChildProc Ź NIL, pleaseResizeChild: WidgetNChildProc Ź NIL, preStopFastAccess: TerminateProc Ź NIL, fullStopFastAccessLR: FullStopFastAccessProc Ź NIL, bindScreenLX: BindScreenProc Ź NIL, forgetScreenLR: TerminateProc Ź NIL, destroyWidget: WidgetProc Ź NIL, internalEnumerateChildren: InternalEnumerateChildrenProc Ź NIL, initInstPart: InitInstancePartProc Ź NIL, <<--usefull for SimpleRealizeOneLevel>> cursorKey: REF Ź NIL, backgroundKey: REF Ź NIL, borderColorKey: REF Ź NIL, eventMask: SetOfEvent Ź unspecifiedEvents, <<>> className: ClassNameProc Ź NIL, createSubClass: CreateSubClassProc Ź NIL ]; END.