[graphic-forms-cvs] r33 - in trunk: . src src/tests/uitoolkit src/uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Wed Mar 8 21:42:25 UTC 2006
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 , at 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)))
- , at cmds
+ ,@(generate-menusystem-code sexp gen)
(pop (menu-stack-of ,gen)))))
More information about the Graphic-forms-cvs
mailing list