Author: junrue Date: Sun Jul 9 16:38:15 2006 New Revision: 189

Modified: trunk/docs/manual/api.texinfo trunk/docs/manual/reference.texinfo trunk/src/uitoolkit/widgets/control.lisp trunk/src/uitoolkit/widgets/event-source.lisp trunk/src/uitoolkit/widgets/menu-item.lisp trunk/src/uitoolkit/widgets/menu-language.lisp trunk/src/uitoolkit/widgets/menu.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp Log: abstracted :callback setup somewhat for controls; added related documentation

Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Sun Jul 9 16:38:15 2006 @@ -178,12 +178,22 @@ classes.

@anchor{button} -@deftp Class button -This @ref{control} class represents selectable controls that invoke -the @ref{event-select} method defined for an @ref{event-dispatcher} -associated with the @code{button}. +@deftp Class button callback-event-name +This @ref{control} class represents selectable controls that generate +an event when clicked. +@table @var +@item callback-event-name +This is an (@code{:allocation :class}) slot that holds a symbol +identifying an event function (e.g., @ref{event-select}). See +@ref{event-source} for more details on this slot. +@end table +@deffn Initarg :callback +The @sc{function} value supplied via this initarg will be +used as the implementation of @ref{event-select} in an +@ref{event-dispatcher} configured for the @code{button}. +@end deffn @deffn Initarg :image -Supplies an image to be used as the @code{button} label. +Supplies an image to be used as the @code{button}'s label. @end deffn @deffn Initarg :style @table @code @@ -229,7 +239,43 @@ @anchor{control} @deftp Class control brush-color brush-handle font pixel-point maximum-size minimum-size text-color The base class for widgets having pre-defined native behavior. It derives from -@ref{widget}. +@ref{widget}.@*@* +@strong{Note:} application code should not manipulate @code{control} slots +directly, unless defining a new @code{control} type as an extension to +Graphic-Forms. +@table @var +@item brush-color +If set, this @ref{color} object is used as the @code{control}'s background color +when the @code{control} needs to be redrawn. +@item brush-handle +This is a native handle for a Win32 @sc{brush} that is used when customizing +the @code{control}'s background color. +@item font +This is a @ref{font} object for customizing the text of a @code{control}. +@item pixel-point +This is a @ref{point} object specifying a pixel in an @ref{image} +associated with a @code{control}, for the purpose of determining what +color to use for transparency. +@item maximum-size +This is a @ref{size} object that places a maximum constraint on the +size that a @ref{layout-manager} may set for the @code{control}. It +may be @sc{nil} if no such constraint has been set. +@item minimum-size +This is a @ref{size} object that places a minimum constraint on the +size that a @ref{layout-manager} may set for the @code{control}. It +may be @sc{nil} if no such constraint has been set. +@item text-color +If set, this color object is used as the @code{control}'s foreground text +color when the @code{control} needs to be redrawn. +@end table +@deffn Initarg :callback +This initarg associates a @sc{function} with an @ref{event-dispatcher} +subclass that is generated behind the scenes and then instantiated to +serve as the @code{control}'s event dispatcher. Each @code{control} +subclass specifies the particular event function (e.g., @ref{event-select}) +that this callback will implement; see the documentation for specific +@code{control} subclasses for more information on this initarg. +@end deffn @end deftp

@anchor{dialog} @@ -281,13 +327,24 @@ @end deftp

@anchor{edit} -@deftp Class edit +@deftp Class edit callback-event-name This subclass of @ref{control} represents a rectangular area that permits the user to enter and edit text. The @ref{event-focus-gain} and @ref{event-focus-loss} methods of each @code{edit control}'s @ref{event-dispatcher} are invoked when focus is given or taken away. The @ref{event-modify} method is invoked when the user edits content. +@table @var +@item callback-event-name +This is an (@code{:allocation :class}) slot that holds a symbol +identifying an event function (e.g., @ref{event-modify}). See +@ref{event-source} for more details on this slot. +@end table +@deffn Initarg :callback +The @sc{function} value supplied via this initarg will be +used as the implementation of @ref{event-modify} in an +@ref{event-dispatcher} configured for the @code{edit control}. +@end deffn @deffn Initarg :style @table @code @item :auto-hscroll @@ -346,15 +403,33 @@ behalf of @ref{widget}s. Applications define subclasses of @code{event-dispatcher} and implement one or more of the @ref{event functions} specializing on each such application-defined subclass in -order to implement desired behavior. +order to implement desired behavior. @xref{event-source}. @end deftp

@anchor{event-source} -@deftp Class event-source dispatcher +@deftp Class event-source callback-event-name dispatcher This is the base class for user interface objects that generate -events. It derives from @ref{native-object}. The @code{dispatcher} -slot holds an instance of @ref{event-dispatcher} that is responsible -for processing events on behalf of an @code{event-source}. +events@footnote{Actually, events are generated by underlying +native window objects, which are represented in the class hierarchy by +the event-source class}. It derives from @ref{native-object}. +@table @var +@item callback-event-name +This is an (@code{:allocation :class}) slot that holds a symbol +identifying an event function (e.g., @ref{event-select}), to be +supplied along with a function pointer in calls to the internal +@code{define-dispatcher} function. The purpose of this is to +facilitate implementation of shortcuts for defining dispatchers where +definition of a primary event function is sufficient, as is the case +when a @ref{control} class wants to support a @code{:callback} +initarg. The choice of event function is determined by each subclass, +hence this slot is shadowed by each such subclass. Application code +typically is not concerned with this slot, except when an application +defines new kinds of event sources. +@item dispatcher +This slot holds a reference to an instance of @ref{event-dispatcher}, +which has responsibility for handling events on behalf of the event +source object. +@end table @deffn Initarg :callbacks The @code{:callbacks} initarg value specifies an association list where the @code{CAR} of each entry is the symbol of an @code{event-*} @@ -362,10 +437,6 @@ pointer. As such, this constitutes a specification for a new @ref{event-dispatcher} class and associated methods. @end deffn -@deffn Initarg :dispatcher -@end deffn -@deffn Accessor dispatcher -@end deffn @end deftp

@anchor{file-dialog} @@ -634,13 +705,13 @@ @end deftp

@deftp Class menu-item -A subclass of @ref{item} representing a menu item. +A subclass of @ref{item} representing a @ref{menu} item. @end deftp

@anchor{panel} @deftp Class panel Base class for @ref{window}s that are children of @ref{top-level} -@ref{window}s (or other panels). +windows, @ref{dialog}s, or other @code{panel}s. @end deftp

@anchor{root-window} @@ -666,7 +737,7 @@ @end deftp

@anchor{timer} -@deftp Class timer +@deftp Class timer id initial-delay delay A timer is a non-windowed object that generates events at a regular (adjustable) frequency. Applications handle timer events by implementing the @ref{event-timer} generic function. This class

Modified: trunk/docs/manual/reference.texinfo ============================================================================== --- trunk/docs/manual/reference.texinfo (original) +++ trunk/docs/manual/reference.texinfo Sun Jul 9 16:38:15 2006 @@ -149,6 +149,8 @@ @end copying @c %**end of header

+@footnotestyle end + @titlepage @title Graphic-Forms Programming Reference @c @subtitle Version 0.5

Modified: trunk/src/uitoolkit/widgets/control.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/control.lisp (original) +++ trunk/src/uitoolkit/widgets/control.lisp Sun Jul 9 16:38:15 2006 @@ -148,11 +148,11 @@ (defmethod give-focus ((self control)) (gfs::set-focus (gfs:handle self)))

-(defmethod initialize-instance :after ((self control) &key callback callbacks disp parent &allow-other-keys) +(defmethod initialize-instance :after ((self control) &key callback callbacks dispatcher parent &allow-other-keys) (if (gfs:disposed-p parent) (error 'gfs:disposed-error)) - (unless (or disp callbacks (not (functionp callback))) - (let ((class (define-dispatcher `((event-select . ,callback))))) + (unless (or dispatcher callbacks (not (functionp callback))) + (let ((class (define-dispatcher (class-name (class-of self)) callback))) (setf (dispatcher self) (make-instance (class-name class))))))

(defmethod (setf maximum-size) :after (max-size (self control))

Modified: trunk/src/uitoolkit/widgets/event-source.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event-source.lisp (original) +++ trunk/src/uitoolkit/widgets/event-source.lisp Sun Jul 9 16:38:15 2006 @@ -35,6 +35,7 @@

(defconstant +callback-info+ '((gfw:event-activate . (gfw:event-source)) (gfw:event-arm . (gfw:event-source)) + (gfw:event-modify . (gfw:event-source)) (gfw:event-select . (gfw:event-source))))

(defun make-specializer-list (disp-class arg-info) @@ -42,10 +43,10 @@ (push disp-class tmp) tmp))

-(defun define-dispatcher (callbacks) - (let* ((*print-gensym* nil) - (class (clos:ensure-class (gentemp "EDCLASS" :gfgen) - :direct-superclasses '(event-dispatcher)))) +(defun define-dispatcher-for-callbacks (callbacks) + (let ((*print-gensym* nil) + (class (clos:ensure-class (gentemp "EDCLASS" :gfgen) + :direct-superclasses '(event-dispatcher)))) (loop for pair in callbacks do (let* ((method-sym (car pair)) (fn (cdr pair)) @@ -65,13 +66,17 @@ :specializers (make-specializer-list class arg-info)))) class))

+(defun define-dispatcher (classname callback) + (let ((proto (c2mop:class-prototype (find-class classname)))) + (define-dispatcher-for-callbacks `((,(callback-event-name-of proto) . ,callback))))) + ;;; ;;; methods ;;;

-(defmethod initialize-instance :after ((self event-source) &key callbacks disp &allow-other-keys) - (unless (or disp (null callbacks)) - (let ((class (define-dispatcher callbacks))) +(defmethod initialize-instance :after ((self event-source) &key callbacks dispatcher &allow-other-keys) + (unless (or dispatcher (null callbacks)) + (let ((class (define-dispatcher-for-callbacks callbacks))) (setf (dispatcher self) (make-instance (class-name class))))))

(defmethod owner :before ((self event-source))

Modified: trunk/src/uitoolkit/widgets/menu-item.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu-item.lisp (original) +++ trunk/src/uitoolkit/widgets/menu-item.lisp Sun Jul 9 16:38:15 2006 @@ -172,7 +172,7 @@ ((null disp) (setf item (make-instance 'menu-item :handle hmenu))) ((functionp disp) - (setf item (make-instance 'menu-item :handle hmenu :callbacks `((gfw:event-select . ,disp))))) + (setf item (make-instance 'menu-item :handle hmenu :callback disp))) ((typep disp 'gfw:event-dispatcher) (setf item (make-instance 'menu-item :handle hmenu :dispatcher disp))) (t @@ -220,6 +220,12 @@ gfs::+mfs-enabled+) gfs::+mfs-enabled+))

+(defmethod initialize-instance :after ((self menu-item) &key callback &allow-other-keys) + (when callback + (unless (typep callback 'function) + (error 'gfs:toolkit-error :detail ":callback value must be a function")) + (setf (dispatcher self) (make-instance (define-dispatcher 'menu-item callback))))) + (defmethod owner ((it menu-item)) (let ((hmenu (gfs:handle it))) (if (gfs:null-handle-p hmenu)

Modified: trunk/src/uitoolkit/widgets/menu-language.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu-language.lisp (original) +++ trunk/src/uitoolkit/widgets/menu-language.lisp Sun Jul 9 16:38:15 2006 @@ -150,8 +150,8 @@ (if (null callback) (error 'gfs:toolkit-error :detail "missing callback argument")) (if sub - (setf disp `(make-instance (define-dispatcher `((gfw:event-activate . ,,callback))))) - (setf disp `(make-instance (define-dispatcher `((gfw:event-select . ,,callback))))))) + (setf disp `(make-instance (define-dispatcher 'gfw:menu ,callback))) + (setf disp `(make-instance (define-dispatcher 'gfw:menu-item ,callback))))) (when disp (if sep (error 'gfs:toolkit-error :detail "dispatchers cannot be set for separators"))

Modified: trunk/src/uitoolkit/widgets/menu.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu.lisp (original) +++ trunk/src/uitoolkit/widgets/menu.lisp Sun Jul 9 16:38:15 2006 @@ -131,7 +131,7 @@ (cond ((null disp)) ((functionp disp) - (let ((class (define-dispatcher `((event-activate . ,disp))))) + (let ((class (define-dispatcher 'gfw:menu disp))) (setf (dispatcher submenu) (make-instance (class-name class))))) ((typep disp 'gfw:event-dispatcher) (setf (dispatcher submenu) disp))

Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Sun Jul 9 16:38:15 2006 @@ -72,14 +72,22 @@ ((dispatcher :accessor dispatcher :initarg :dispatcher - :initform (make-instance 'event-dispatcher))) + :initform (make-instance 'event-dispatcher)) + (callback-event-name + :accessor callback-event-name-of + :initform nil + :allocation :class)) ; subclasses will shadow this slot (:documentation "This is the base class for user interface objects that generate events."))

(defclass item (event-source) ((item-id :accessor item-id :initarg :item-id - :initform 0)) + :initform 0) + (callback-event-name + :accessor callback-event-name-of + :initform 'event-select + :allocation :class)) ; shadowing same slot from event-source (:documentation "The item class is the base class for all non-windowed user interface objects."))

(defclass menu-item (item) () @@ -121,10 +129,18 @@ :initform nil)) (:documentation "The base class for widgets having pre-defined native behavior."))

-(defclass button (control) () +(defclass button (control) + ((callback-event-name + :accessor callback-event-name-of + :initform 'event-select + :allocation :class)) ; shadowing same slot from event-source (:documentation "This class represents selectable controls that issue notifications when clicked."))

-(defclass edit (control) () +(defclass edit (control) + ((callback-event-name + :accessor callback-event-name-of + :initform 'event-modify + :allocation :class)) ; shadowing same slot from event-source (:documentation "This class represents a control in which the user may enter and edit text."))

(defclass label (control) () @@ -146,7 +162,11 @@ :initform (make-array 7 :fill-pointer 0 :adjustable t))) (:documentation "The widget-with-items class is the base class for objects composed of sub-items."))

-(defclass menu (widget-with-items) () +(defclass menu (widget-with-items) + ((callback-event-name + :accessor callback-event-name-of + :initform 'event-activate + :allocation :class)) ; shadowing same slot from event-source (:documentation "The menu class represents a container for menu items (and submenus)."))

(defclass window (widget layout-managed)