Author: junrue Date: Wed Mar 8 16:42:24 2006 New Revision: 33

Added: trunk/src/uitoolkit/widgets/event-source.lisp - copied, changed from r32, trunk/src/uitoolkit/widgets/event-dispatcher.lisp Removed: trunk/src/uitoolkit/widgets/event-dispatcher.lisp Modified: trunk/graphic-forms-uitoolkit.asd trunk/src/packages.lisp trunk/src/tests/uitoolkit/hello-world.lisp trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/uitoolkit/widgets/menu-language.lisp Log: implemented and debugged :callback option for menu language

Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Wed Mar 8 16:42:24 2006 @@ -93,7 +93,7 @@ (:file "event-generics") (:file "layout-generics") (:file "widget-generics") - (:file "event-dispatcher") + (:file "event-source") (:file "widget-utils") (:file "item") (:file "widget")

Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Wed Mar 8 16:42:24 2006 @@ -33,6 +33,16 @@

(in-package #:graphic-forms-system)

+;;; +;;; destination for unique symbols generated by the library +;;; +(defpackage #:graphic-forms.generated + (:nicknames #:gfgen) + (:use #:common-lisp)) + +;;; +;;; package for fundamental stuff shared across the library +;;; (defpackage #:graphic-forms.intrinsics (:nicknames #:gfi) (:use #:common-lisp) @@ -69,6 +79,9 @@ ;; conditions #:disposed-error))

+;;; +;;; package for system-level functionality +;;; (defpackage #:graphic-forms.uitoolkit.system (:nicknames #:gfs) (:shadow #:atom #:boolean) @@ -91,6 +104,9 @@ #:win32-error #:win32-warning))

+;;; +;;; package for graphics functionality +;;; (defpackage #:graphic-forms.uitoolkit.graphics (:nicknames #:gfg) (:shadow #:load #:type) @@ -195,6 +211,9 @@ ;; conditions ))

+;;; +;;; package for UI objects +;;; (defpackage #:graphic-forms.uitoolkit.widgets (:nicknames #:gfw) (:use #:common-lisp)

Modified: trunk/src/tests/uitoolkit/hello-world.lisp ============================================================================== --- trunk/src/tests/uitoolkit/hello-world.lisp (original) +++ trunk/src/tests/uitoolkit/hello-world.lisp Wed Mar 8 16:42:24 2006 @@ -48,23 +48,21 @@ (exit-hello-world))

(defmethod gfw:event-paint ((d hellowin-events) window time gc rect) - (declare (ignorable window time ignore rect)) + (declare (ignorable window time rect)) (setf (gfg:background-color gc) gfg:+color-red+) (setf (gfg:foreground-color gc) gfg:+color-green+) (gfg:draw-text gc "Hello World!" (gfi:make-point)))

-(defclass hellowin-exit-dispatcher (gfw:event-dispatcher) ()) - -(defmethod gfw:event-select ((d hellowin-exit-dispatcher) item time rect) - (declare (ignorable item time rect)) +(defun exit-fn (disp item time rect) + (declare (ignorable disp item time rect)) (exit-hello-world))

(defun run-hello-world-internal () - (let ((menubar nil) - (disp (make-instance 'hellowin-exit-dispatcher))) + (let ((menubar nil)) (setf *hellowin* (make-instance 'gfw:window :dispatcher (make-instance 'hellowin-events))) (gfw:realize *hellowin* nil :style-workspace) - (setf menubar (gfw:defmenusystem ((:item "&File" :submenu ((:item "E&xit" :dispatcher disp)))))) + (setf menubar (gfw:defmenusystem ((:item "&File" + :submenu ((:item "E&xit" :callback #'exit-fn)))))) (setf (gfw:menu-bar *hellowin*) menubar) (gfw:show *hellowin* t)))

Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Wed Mar 8 16:42:24 2006 @@ -157,10 +157,8 @@ (gfw:show victim (not (gfw:visible-p victim))) (gfw:layout *layout-tester-win*))))

-(defclass flow-modifier-menu-dispatcher (gfw:event-dispatcher) ()) - -(defmethod gfw:event-activate ((d flow-modifier-menu-dispatcher) menu time) - (declare (ignore time)) +(defun flow-mod-callback (disp menu time) + (declare (ignore disp time)) (gfw:clear-all menu) (let ((it nil) (margin-menu (gfw:defmenusystem ((:item "Top" @@ -186,29 +184,26 @@ (gfw:check it t) (gfw:append-item menu "Wrap" nil nil)))

-(defclass layout-tester-exit-dispatcher (gfw:event-dispatcher) ()) - -(defmethod gfw:event-select ((d layout-tester-exit-dispatcher) item time rect) - (declare (ignorable item time rect)) +(defun exit-layout-callback (disp item time rect) + (declare (ignorable disp item time rect)) (exit-layout-tester))

(defun run-layout-tester-internal () (setf *widget-counter* 0) (let ((menubar nil) - (exit-disp (make-instance 'layout-tester-exit-dispatcher)) (pack-disp (make-instance 'pack-layout-dispatcher)) (add-btn-disp (make-instance 'add-child-dispatcher)) (add-text-label-disp (make-instance 'add-child-dispatcher :widget-class 'gfw::text-label :subtype :text-label)) (rem-menu-disp (make-instance 'child-menu-dispatcher :sub-disp-class 'remove-child-dispatcher)) (vis-menu-disp (make-instance 'child-menu-dispatcher :sub-disp-class 'visibility-child-dispatcher - :check-test-fn #'gfw:visible-p)) - (mod-layout-menu-disp (make-instance 'flow-modifier-menu-dispatcher))) + :check-test-fn #'gfw:visible-p))) (setf *layout-tester-win* (make-instance 'gfw:window :dispatcher (make-instance 'layout-tester-events) :layout-manager (make-instance 'gfw:flow-layout))) (gfw:realize *layout-tester-win* nil :style-workspace) (setf menubar (gfw:defmenusystem ((:item "&File" - :submenu ((:item "E&xit" :dispatcher exit-disp))) + :submenu ((:item "E&xit" + :callback #'exit-layout-callback))) (:item "&Children" :submenu ((:item "Add" :submenu ((:item "Button" :dispatcher add-btn-disp) @@ -218,7 +213,7 @@ (:item "Visible" :dispatcher vis-menu-disp :submenu ((:item ""))))) (:item "&Window" - :submenu ((:item "Modify Layout" :dispatcher mod-layout-menu-disp + :submenu ((:item "Modify Layout" :callback #'flow-mod-callback :submenu ((:item ""))) (:item "Select Layout" :submenu ((:item "Flow")))

Copied: trunk/src/uitoolkit/widgets/event-source.lisp (from r32, trunk/src/uitoolkit/widgets/event-dispatcher.lisp) ============================================================================== --- trunk/src/uitoolkit/widgets/event-dispatcher.lisp (original) +++ trunk/src/uitoolkit/widgets/event-source.lisp Wed Mar 8 16:42:24 2006 @@ -1,5 +1,5 @@ ;;;; -;;;; event-dispatcher.lisp +;;;; event-source.lisp ;;;; ;;;; Copyright (C) 2006, Jack D. Unrue ;;;; All rights reserved. @@ -33,50 +33,36 @@

(in-package :graphic-forms.uitoolkit.widgets)

-(defun dispatcher-for-activate-callback (class fn) - (lispworks:with-unique-names (arg0 arg1 arg2) - (let ((gf (clos:ensure-generic-function 'gfw:event-activate - :lambda-list (list arg0 arg1 arg2)))) - (c2mop:ensure-method gf - `(lambda (,arg0 ,arg1 ,arg2) (funcall ,fn ,arg0 ,arg1 ,arg2)) - :specializers (list class - (find-class 'gfw:event-source) - (find-class 'integer)))))) - -(defun dispatcher-for-arm-callback (class fn) - (lispworks:with-unique-names (arg0 arg1 arg2) - (let ((gf (clos:ensure-generic-function 'gfw:event-arm - :lambda-list (list arg0 arg1 arg2)))) - (c2mop:ensure-method gf - `(lambda (,arg0 ,arg1 ,arg2) (funcall ,fn ,arg0 ,arg1 ,arg2)) - :specializers (list class - (find-class 'gfw:event-source) - (find-class 'integer)))))) - -(defun dispatcher-for-select-callback (class fn) - (lispworks:with-unique-names (arg0 arg1 arg2 arg4) - (let ((gf (clos:ensure-generic-function 'gfw:event-select - :lambda-list (list arg0 arg1 arg2 arg4)))) - (c2mop:ensure-method gf - `(lambda (,arg0 ,arg1 ,arg2 ,arg4) (funcall ,fn ,arg0 ,arg1 ,arg2 ,arg4)) - :specializers (list class - (find-class 'gfw:item) - (find-class 'integer) - (find-class 'gfi:rectangle)))))) - -(defun defdispatcher (callbacks) - (let ((class (clos:ensure-class (gensym "EDCLASS") :direct-superclasses '(event-dispatcher)))) +(defconstant +callback-info+ '((gfw:event-activate . (gfw:event-source integer)) + (gfw:event-arm . (gfw:event-source integer)) + (gfw:event-select . (gfw:item integer gfi:rectangle)))) + +(defun make-specializer-list (disp-class arg-info) + (let ((tmp (mapcar #'find-class arg-info))) + (push disp-class tmp) + tmp)) + +(defun define-dispatcher (callbacks) + (let* ((*print-gensym* nil) + (class (clos:ensure-class (gentemp "EDCLASS" :gfgen) + :direct-superclasses '(event-dispatcher)))) (loop for pair in callbacks - do (cond - ((eq (car pair) 'gfw:event-activate) - (dispatcher-for-activate-callback class (cdr pair))) - ((eq (car pair) 'gfw:event-arm) - (dispatcher-for-arm-callback class (cdr pair))) - ((eq (car pair) 'gfw:event-select) - (dispatcher-for-select-callback class (cdr pair))) - (t - (error 'gfs:toolkit-error :detail (format nil "unsupported event method for callbacks: ~a" - (car pair)))))) + do (let* ((method-sym (car pair)) + (fn (cdr pair)) + (arg-info (cdr (assoc method-sym +callback-info+))) + (args nil)) + `(unless (or (symbolp ,fn) (functionp ,fn)) + (error 'gfs:toolkit-error + :detail "callback must be function or symbol naming function")) + (if (null arg-info) + (error 'gfs:toolkit-error :detail (format nil + "unsupported event method for callbacks: ~a" + method-sym))) + (dotimes (i (1+ (length arg-info))) + (push (gentemp "ARG" :gfgen) args)) + (c2mop:ensure-method (clos:ensure-generic-function method-sym :lambda-list args) + `(lambda ,args (funcall ,fn ,@args)) + :specializers (make-specializer-list class arg-info)))) class))

(defmethod initialize-instance :after ((src event-source) &key callbacks &allow-other-keys) @@ -85,5 +71,5 @@ pointer. As such, this constitutes a specification for a new event-dispatcher \ object and associated methods." (unless (null callbacks) - (let ((class (defdispatcher callbacks))) + (let ((class (define-dispatcher callbacks))) (setf (dispatcher src) (make-instance (class-name class))))))

Modified: trunk/src/uitoolkit/widgets/menu-language.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu-language.lisp (original) +++ trunk/src/uitoolkit/widgets/menu-language.lisp Wed Mar 8 16:42:24 2006 @@ -41,7 +41,7 @@ (gfw:defmenusystem ((:item "&File" :submenu ((:item "&Open...") (:item "&Save..." :disabled) (:item :separator) - (:item "E&xit"))) + (:item "E&xit" :callback #'some-fn))) (:item "&Options" :submenu ((:item "&Enabled" :checked) (:item "&Tools" :submenu ((:item "&Fonts" :disabled) (:item "&Colors"))))) @@ -49,7 +49,7 @@ |#

;;; -;;; basic infrastructure +;;; base class and generic functions ;;;

(defclass base-menu-generator () @@ -80,10 +80,15 @@ (and (consp form) (eq (car form) :item)))

+;;; +;;; menu system form parser +;;; + (defun process-item-form (form generator-sym) (if (not (item-form-p form)) (error 'gfs:toolkit-error :detail (format nil "form ~a not a menu item definition" form))) - (let ((cmds nil) + (let ((callback nil) + (code nil) (checked nil) (disabled nil) (disp nil) @@ -91,14 +96,20 @@ (label nil) (sep nil) (sub nil) + (cb-tmp nil) (disp-tmp nil) (image-tmp nil) (sub-tmp nil)) (loop for opt in form do (cond + ((not (null cb-tmp)) + (setf callback opt) + (setf cb-tmp nil) + (setf disp nil)) ((not (null disp-tmp)) (setf disp opt) - (setf disp-tmp nil)) + (setf disp-tmp nil) + (setf callback nil)) ((not (null image-tmp)) (setf image opt) (setf image-tmp nil)) @@ -107,6 +118,8 @@ (setf sub-tmp nil)) ((and (not (eq opt :item)) (null label)) (setf label opt)) + ((eq opt :callback) + (setf cb-tmp t)) ((eq opt :checked) (setf checked t)) ((eq opt :disabled) @@ -131,6 +144,14 @@ (error 'gfs:toolkit-error :detail "image cannot be set for separators or submenus")) (if (null image) (error 'gfs:toolkit-error :detail "missing image object"))) + (when callback + (if sep + (error 'gfs:toolkit-error :detail "callbacks cannot be set for separators")) + (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))))))) (when disp (if sep (error 'gfs:toolkit-error :detail "dispatchers cannot be set for separators")) @@ -140,35 +161,39 @@ (if (or checked image sep (not (listp sub))) (error 'gfs:toolkit-error :detail "invalid option for submenu"))) (cond - (sep (push `(define-separator ,generator-sym) cmds)) + (sep (push `(define-separator ,generator-sym) code)) (sub (push `(define-submenu ,generator-sym ,label ,disp - ,disabled) cmds) + ,disabled) code) (loop for subform in sub - do (setf cmds (append (process-item-form subform generator-sym) cmds))) - (push `(complete-submenu ,generator-sym) cmds)) + do (setf code (append (process-item-form subform generator-sym) code))) + (push `(complete-submenu ,generator-sym) code)) (t (push `(define-item ,generator-sym ,label ,disp ,disabled ,checked - ,image) cmds))) - cmds)) + ,image) code))) + code)) + +;;; +;;; code generation +;;;

(defun generate-menusystem-code (sexp generator-sym) - (let ((cmds nil)) + (let ((code nil)) (mapcar #'(lambda (var) - (setf cmds (append (process-item-form var generator-sym) cmds))) + (setf code (append (process-item-form var generator-sym) code))) sexp) - (reverse cmds))) + (reverse code)))

(defclass win32-menu-generator (base-menu-generator) ())

(defmethod initialize-instance :after ((gen win32-menu-generator) &key) (let ((m (make-instance 'menu :handle (gfs::create-menu)))) (put-widget (thread-context) m) - (setf (menu-stack-of gen) (list m)))) + (push m (menu-stack-of gen))))

(defmethod define-item ((gen win32-menu-generator) label dispatcher disabled checked image) (let* ((owner (first (menu-stack-of gen))) @@ -195,9 +220,12 @@ (defmethod complete-submenu ((gen win32-menu-generator)) (pop (menu-stack-of gen)))

+;;; +;;; top-level API for the menu language +;;; + (defmacro defmenusystem (sexp) - (let* ((gen (gensym)) - (cmds (generate-menusystem-code sexp gen))) + (let ((gen (gensym))) `(let ((,gen (make-instance 'win32-menu-generator))) - ,@cmds + ,@(generate-menusystem-code sexp gen) (pop (menu-stack-of ,gen)))))