[mcclim-cvs] CVS mcclim/ESA
thenriksen
thenriksen at common-lisp.net
Tue Jan 29 22:59:30 UTC 2008
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
+ , at commands))
+ :inherit-menu t
+ :errorp nil))
+
(defclass observable-mixin ()
((%observers :accessor observers
:initform '()))
More information about the Mcclim-cvs
mailing list