[climacs-cvs] CVS update: climacs/packages.lisp climacs/gui.lisp climacs/esa.lisp
Dave Murray
dmurray at common-lisp.net
Tue Sep 6 21:30:35 UTC 2005
Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv5074
Modified Files:
packages.lisp gui.lisp esa.lisp
Log Message:
Initial implementation of Where Is (C-h w) and
Describe Bindings (C-h b); renamed Describe Key (C-h k)
to Describe Key Briefly (C-h c) and added new
help-table to ESA.
Also, changed set-key to not clobber defined commands in
command tables, fixed some minor errors in gui.lisp,
and included keyboard-macro-table and help-table in
global-climacs-table's inheritance list.
Date: Tue Sep 6 23:30:34 2005
Author: dmurray
Index: climacs/packages.lisp
diff -u climacs/packages.lisp:1.80 climacs/packages.lisp:1.81
--- climacs/packages.lisp:1.80 Thu Sep 1 02:21:08 2005
+++ climacs/packages.lisp Tue Sep 6 23:30:33 2005
@@ -193,6 +193,7 @@
#:*numeric-argument-p* #:*current-gesture*
#:esa-top-level #:simple-command-loop
#:global-esa-table #:keyboard-macro-table
+ #:help-table
#:set-key))
(defpackage :climacs-gui
Index: climacs/gui.lisp
diff -u climacs/gui.lisp:1.186 climacs/gui.lisp:1.187
--- climacs/gui.lisp:1.186 Thu Sep 1 03:05:51 2005
+++ climacs/gui.lisp Tue Sep 6 23:30:33 2005
@@ -56,7 +56,8 @@
(define-application-frame climacs (standard-application-frame
esa-frame-mixin)
((buffers :initform '() :accessor buffers))
- (:command-table (global-climacs-table :inherit-from (global-esa-table)))
+ (:command-table (global-climacs-table :inherit-from (global-esa-table keyboard-macro-table
+ help-table)))
(:menu-bar nil)
(:panes
(window (let* ((extended-pane
@@ -350,7 +351,7 @@
(define-named-command com-transpose-objects ()
(transpose-objects (point (current-window))))
-(set-key 'com-transponse-objects 'global-climacs-table
+(set-key 'com-transpose-objects 'global-climacs-table
'((#\t :control)))
(define-named-command com-backward-object ((count 'integer :prompt "Number of Objects"))
@@ -1276,7 +1277,9 @@
(define-named-command com-browse-url ()
(let ((url (accept 'url :prompt "Browse URL")))
#+ (and sbcl darwin)
- (sb-ext:run-program "/usr/bin/open" `(,url) :wait nil)))
+ (sb-ext:run-program "/usr/bin/open" `(,url) :wait nil)
+ #+ (and openmcl darwin)
+ (ccl:run-program "/usr/bin/open" `(,url) :wait nil)))
(define-named-command com-set-mark ()
(let ((pane (current-window)))
@@ -1525,7 +1528,7 @@
(kill-ring-standard-push *kill-ring* (region-to-sequence (point pane) (mark pane)))))
(set-key 'com-copy-region 'global-climacs-table
- '((#\w :control)))
+ '((#\w :meta)))
(define-named-command com-rotate-yank ()
(let* ((pane (current-window))
@@ -1940,7 +1943,7 @@
(kill-ring-standard-push *kill-ring* (region-to-sequence point mark))
(delete-region point mark)))
-(set-key `(com-kill-sentence *numeric-argument-marker*)
+(set-key `(com-kill-sentence ,*numeric-argument-marker*)
'global-climacs-table
'((#\k :meta)))
@@ -1990,7 +1993,7 @@
(backward-page point count)
(forward-page point count))))
-(set-key 'com-backward-page 'global-climacs-table
+(set-key `(com-backward-page ,*numeric-argument-marker*) 'global-climacs-table
'((#\x :control) (#\[)))
(define-named-command com-mark-page ((count 'integer :prompt "Move how many pages")
Index: climacs/esa.lisp
diff -u climacs/esa.lisp:1.16 climacs/esa.lisp:1.17
--- climacs/esa.lisp:1.16 Mon Sep 5 09:06:33 2005
+++ climacs/esa.lisp Tue Sep 6 23:30:34 2005
@@ -234,49 +234,6 @@
(t nil)))))
do (redisplay-frame-panes frame)))
-(defun read-gestures-for-help (command-table)
- (loop for gestures = (list (esa-read-gesture))
- then (nconc gestures (list (esa-read-gesture)))
- for item = (find-gestures-with-inheritance gestures command-table)
- unless item
- do (return (values nil gestures))
- when (eq (command-menu-item-type item) :command)
- do (return (values (command-menu-item-value item)
- gestures))))
-
-(defun describe-key (pane)
- (let ((command-table (command-table pane)))
- (multiple-value-bind (command gestures)
- (read-gestures-for-help command-table)
- (when (consp command)
- (setf command (car command)))
- (display-message "~{~A ~}~:[is not bound~;runs the command ~:*~A~]"
- (mapcar #'gesture-name gestures)
- (or (command-line-name-for-command
- command command-table :errorp nil)
- command)))))
-
-(defgeneric gesture-name (gesture))
-
-(defmethod gesture-name ((char character))
- (or (char-name char)
- char))
-
-(defmethod gesture-name ((ev keyboard-event))
- (let ((key-name (keyboard-event-key-name ev))
- (modifiers (event-modifier-state ev)))
- (with-output-to-string (s)
- (loop for (modifier name) on (list
- ;(+alt-key+ "A-")
- +hyper-key+ "H-"
- +super-key+ "s-"
- +meta-key+ "M-"
- +control-key+ "C-")
- by #'cddr
- when (plusp (logand modifier modifiers))
- do (princ name s))
- (princ key-name s))))
-
(defmethod redisplay-frame-panes :around ((frame esa-frame-mixin) &key force-p)
(declare (ignore force-p))
(when (null (remaining-keys *application-frame*))
@@ -363,6 +320,8 @@
(find-keystroke-item event table :errorp nil))))
(defun set-key (command table gestures)
+ (unless (consp command)
+ (setf command (list command)))
(let ((gesture (car gestures)))
(cond ((null (cdr gestures))
(add-command-to-command-table
@@ -403,12 +362,196 @@
(set-key 'com-extended-command 'global-esa-table '((#\x :meta)))
-(define-command (com-describe-key :name t :command-table global-esa-table) ()
- (display-message "Describe key:")
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; Help
+
+(defun read-gestures-for-help (command-table)
+ (loop for gestures = (list (esa-read-gesture))
+ then (nconc gestures (list (esa-read-gesture)))
+ for item = (find-gestures-with-inheritance gestures command-table)
+ unless item
+ do (return (values nil gestures))
+ when (eq (command-menu-item-type item) :command)
+ do (return (values (command-menu-item-value item)
+ gestures))))
+
+(defun describe-key-briefly (pane)
+ (let ((command-table (command-table pane)))
+ (multiple-value-bind (command gestures)
+ (read-gestures-for-help command-table)
+ (when (consp command)
+ (setf command (car command)))
+ (display-message "~{~A ~}~:[is not bound~;runs the command ~:*~A~]"
+ (mapcar #'gesture-name gestures)
+ (or (command-line-name-for-command
+ command command-table :errorp nil)
+ command)))))
+
+(defgeneric gesture-name (gesture))
+
+(defmethod gesture-name ((char character))
+ (or (char-name char)
+ char))
+
+(defun translate-name-and-modifiers (key-name modifiers)
+ (with-output-to-string (s)
+ (loop for (modifier name) on (list
+ ;(+alt-key+ "A-")
+ +hyper-key+ "H-"
+ +super-key+ "s-"
+ +meta-key+ "M-"
+ +control-key+ "C-")
+ by #'cddr
+ when (plusp (logand modifier modifiers))
+ do (princ name s))
+ (princ (if (typep key-name 'character)
+ (or (char-name key-name)
+ key-name)
+ key-name) s)))
+
+(defmethod gesture-name ((ev keyboard-event))
+ (let ((key-name (keyboard-event-key-name ev))
+ (modifiers (event-modifier-state ev)))
+ (translate-name-and-modifiers key-name modifiers)))
+
+(defmethod gesture-name ((gesture list))
+ (cond ((eq (car gesture) :keyboard)
+ (translate-name-and-modifiers (second gesture) (third gesture)))
+ ;; punt on this for now
+ (t nil)))
+
+(defun find-keystrokes-for-command (command command-table)
+ (let ((keystrokes '()))
+ (labels ((helper (command command-table prefix)
+ (map-over-command-table-keystrokes
+ #'(lambda (menu-name keystroke item)
+ (declare (ignore menu-name))
+ (cond ((and (eq (command-menu-item-type item) :command)
+ (eq (car (command-menu-item-value item)) command))
+ (push (cons keystroke prefix) keystrokes))
+ ((eq (command-menu-item-type item) :menu)
+ (helper command (command-menu-item-value item) (cons keystroke prefix)))
+ (t nil)))
+ command-table)))
+ (helper command command-table nil)
+ keystrokes)))
+
+(defun find-keystrokes-for-command-with-inheritance (command start-table)
+ (let ((keystrokes '()))
+ (labels ((helper (table)
+ (let ((keys (find-keystrokes-for-command command table)))
+ (when keys (push keys keystrokes))
+ (dolist (subtable (command-table-inherit-from
+ (find-command-table table)))
+ (helper subtable)))))
+ (helper start-table))
+ keystrokes))
+
+(defun find-all-keystrokes-and-commands (command-table)
+ (let ((results '()))
+ (labels ((helper (command-table prefix)
+ (map-over-command-table-keystrokes
+ #'(lambda (menu-name keystroke item)
+ (declare (ignore menu-name))
+ (cond ((eq (command-menu-item-type item) :command)
+ (push (cons (cons keystroke prefix)
+ (command-menu-item-value item))
+ results))
+ ((eq (command-menu-item-type item) :menu)
+ (helper (command-menu-item-value item) (cons keystroke prefix)))
+ (t nil)))
+ command-table)))
+ (helper command-table nil)
+ results)))
+
+(defun sort-by-name (list)
+ (sort list #'string< :key (lambda (item) (symbol-name (second item)))))
+
+(defun sort-by-keystrokes (list)
+ (sort list (lambda (a b)
+ (cond ((and (characterp a)
+ (characterp b))
+ (char< a b))
+ ((characterp a)
+ t)
+ ((characterp b)
+ nil)
+ (t (string< (symbol-name a)
+ (symbol-name b)))))
+ :key (lambda (item) (second (first (first item))))))
+
+(defun describe-bindings (stream command-table
+ &optional (sort-function #'sort-by-name))
+ (formatting-table (stream)
+ (loop for (keys command)
+ in (funcall sort-function (find-all-keystrokes-and-commands
+ command-table))
+ do (formatting-row (stream)
+ (formatting-cell (stream :align-x :right)
+ (with-text-style (stream '(:sans-serif nil nil))
+ (format stream "~A"
+ (or (command-line-name-for-command command
+ command-table
+ :errorp nil)
+ command))))
+ (formatting-cell (stream)
+ (with-drawing-options (stream :ink +dark-blue+
+ :text-style '(:fix nil nil))
+ (format stream "~&~{~A~^ ~}"
+ (mapcar #'gesture-name (reverse keys))))))
+ count command into length
+ finally (change-space-requirements stream
+ :height (* length (stream-line-height stream)))
+ (scroll-extent stream 0 0))))
+
+;;; help commands
+
+(define-command-table help-table)
+
+(define-command (com-describe-key-briefly :name t :command-table help-table) ()
+ (display-message "Describe key briefly:")
(redisplay-frame-panes *application-frame*)
- (describe-key (car (windows *application-frame*))))
+ (describe-key-briefly (car (windows *application-frame*))))
+
+(set-key 'com-describe-key-briefly 'help-table '((#\h :control) (#\c)))
+
+(define-command (com-where-is :name t :command-table help-table) ()
+ (let* ((command-table (command-table (car (windows *application-frame*))))
+ (command
+ (handler-case
+ (accept
+ `(command-name :command-table
+ ,command-table)
+ :prompt "Where is command")
+ (error () (progn (beep)
+ (display-message "No such command")
+ (return-from com-where-is nil)))))
+ (keystrokes (find-keystrokes-for-command-with-inheritance command command-table)))
+ (display-message "~A is ~:[not on any key~;~:*on ~{~A~^, ~}~]"
+ (command-line-name-for-command command command-table)
+ (mapcar (lambda (keys)
+ (format nil "~{~A~^ ~}"
+ (mapcar #'gesture-name (reverse keys))))
+ (car keystrokes)))))
+
+(set-key 'com-where-is 'help-table '((#\h :control) (#\w)))
+
+(define-command (com-describe-bindings :name t :command-table help-table)
+ ((sort-by-keystrokes 'boolean :prompt "Sort by keystrokes?"))
+ (let* ((window (car (windows *application-frame*)))
+ (stream (open-window-stream
+ :label (format nil "Help: Describe Bindings")
+ :input-buffer (climi::frame-event-queue *application-frame*)
+ :width 400))
+ (command-table (command-table window)))
+ (describe-bindings stream command-table
+ (if sort-by-keystrokes
+ #'sort-by-keystrokes
+ #'sort-by-name))))
-(set-key 'com-describe-key 'global-esa-table '((#\h :control) (#\k)))
+(set-key `(com-describe-bindings ,*numeric-argument-p*) 'help-table '((#\h :control) (#\b)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
More information about the Climacs-cvs
mailing list