Update of /project/mcclim/cvsroot/mcclim/ESA In directory clnet:/tmp/cvs-serv30581/ESA

Modified Files: esa-io.lisp esa.lisp packages.lisp utils.lisp Log Message: Added build-menu function and define-menu-table macro to ESA.

Used these to define menu tables. ESA's multigesture-keystroke mechanism clobbers the normal command tables menu, so we can't use that. Also, I think explicitly specifying the contents, order and structure of a menu is a good idea.

--- /project/mcclim/cvsroot/mcclim/ESA/esa-io.lisp 2008/01/15 16:24:23 1.8 +++ /project/mcclim/cvsroot/mcclim/ESA/esa-io.lisp 2008/01/29 22:59:30 1.9 @@ -313,3 +313,11 @@ (set-key `(com-write-buffer ,*unsupplied-argument-marker*) 'esa-io-table '((#\x :control) (#\w :control)))

+(define-menu-table esa-io-menu-table (esa-io-table global-esa-table) + `(com-find-file ,*unsupplied-argument-marker*) + `(com-find-file-read-only ,*unsupplied-argument-marker*) + 'com-save-buffer + `(com-write-buffer ,*unsupplied-argument-marker*) + `(com-set-visited-file-name ,*unsupplied-argument-marker*) + :divider + 'com-quit) --- /project/mcclim/cvsroot/mcclim/ESA/esa.lisp 2008/01/28 17:03:28 1.17 +++ /project/mcclim/cvsroot/mcclim/ESA/esa.lisp 2008/01/29 22:59:30 1.18 @@ -1518,6 +1518,14 @@ 'help-table '((#\h :control) (#\a)))

+(define-menu-table help-menu-table (help-table) + 'com-where-is + '(com-describe-bindings nil) + '(com-describe-bindings t) + 'com-describe-key + `(com-describe-command ,*unsupplied-argument-marker*) + `(com-apropos-command ,*unsupplied-argument-marker*)) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Keyboard macros @@ -1561,6 +1569,11 @@ (set-key `(com-call-last-kbd-macro ,*numeric-argument-marker*) 'keyboard-macro-table '((#\x :control) #\e))

+(define-menu-table keyboard-macro-menu-table (keyboard-macro-table) + 'com-start-kbd-macro + 'com-end-kbd-macro + `(com-call-last-kbd-macro ,*unsupplied-argument-marker*)) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; example application --- /project/mcclim/cvsroot/mcclim/ESA/packages.lisp 2008/01/28 17:03:29 1.14 +++ /project/mcclim/cvsroot/mcclim/ESA/packages.lisp 2008/01/29 22:59:30 1.15 @@ -23,7 +23,7 @@ ;;; Package definitions for ESA.

(defpackage :esa-utils - (:use :clim-lisp :clim-mop) + (:use :clim-lisp :clim-mop :clim) (:export #:with-gensyms #:once-only #:unlisted @@ -45,6 +45,7 @@ #:capitalize #:ensure-array-size #:values-max-min + #:build-menu #:define-menu-table #:observable-mixin #:add-observer #:remove-observer #:observer-notified #:notify-observers @@ -95,14 +96,14 @@ #:com-quit #:com-extended-command

;; Help commands - #:help-table + #:help-table #:help-menu-table #:com-describe-key-briefly #:com-where-is #:com-describe-bindings #:com-describe-key #:com-describe-command #:com-apropos-command

;; Keyboard macro commands - #:keyboard-macro-table + #:keyboard-macro-table #:keyboard-macro-menu-table #:com-start-macro #:com-end-macro #:com-call-last-macro))

@@ -125,7 +126,7 @@ #:frame-write-buffer #:write-buffer #:buffer-writing-error #:buffer #:filepath #:filepath-is-directory - #:esa-io-table + #:esa-io-table #:esa-io-menu-table #:com-find-file #:com-find-file-read-only #:com-read-only #:com-set-visited-file-name #:com-save-buffer #:com-write-buffer)) --- /project/mcclim/cvsroot/mcclim/ESA/utils.lisp 2008/01/29 14:36:00 1.10 +++ /project/mcclim/cvsroot/mcclim/ESA/utils.lisp 2008/01/29 22:59:30 1.11 @@ -261,6 +261,68 @@ `(call-method ,(first around) (,@(rest around) (make-method ,form))) form))))

+(defun build-menu (command-tables &rest commands) + "Create a command table inheriting commands from +`command-tables', which must be a list of command table +designators. The created command table will have a menu +consisting of `commands', elements of which must be one of: + + * A named command accessible in one of `command-tables'. This may + either be a command name, or a cons of a command name and + arguments. The command will appear directly in the menu. + + * A list of the symbol `:menu' and something that will evaluate + to a command table designator. This will create a submenu + showing the name and menu of the designated command table. + + * A list of the symbol `:submenu', a string, and a &rest list + of the same form as `commands'. This is equivalent to `:menu' + with a call to `build-menu' with `command-tables' and + the specified list as arguments. + + * A symbol `:divider', which will present a horizontal divider + line. + + An error of type`command-table-error' will be signalled if a +command cannot be found in any of the provided command tables." + (labels ((get-command-name (command) + (or (loop for table in command-tables + for name = (command-line-name-for-command command table :errorp nil) + when name return name) + (error 'command-table-error + :format-string "Command ~A not found in any provided command table" + :format-arguments (list command)))) + (make-menu-entry (entry) + (cond ((and (listp entry) + (eq (first entry) :menu)) + (list (command-table-name (find-command-table (second entry))) + :menu (second entry))) + ((and (listp entry) + (eq (first entry) :submenu)) + (list (second entry) + :menu (apply #'build-menu command-tables + (cddr entry)))) + ((eq entry :divider) + '(nil :divider :line)) + (t (list (get-command-name (command-name (listed entry))) + :command entry))))) + (make-command-table nil + :inherit-from command-tables + :menu (mapcar #'make-menu-entry commands)))) + +(defmacro define-menu-table (name (&rest command-tables) &body commands) + "Define a command table with a menu named `name' and containing +`commands'. `Command-tables' must be a list of command table +designators containing the named commands that will be included +in the menu. `Commands' must have the same format as the +`commands' argument to `build-menu'. If `name' already names a +command table, the old definition will be destroyed." + `(make-command-table ',name + :inherit-from (list (build-menu ',command-tables + ,@commands)) + :inherit-menu t + :errorp nil)) + (defclass observable-mixin () ((%observers :accessor observers :initform '()))