[gsharp-cvs] CVS update: gsharp/esa.lisp
Christophe Rhodes
crhodes at common-lisp.net
Sat Oct 1 09:37:33 UTC 2005
Update of /project/gsharp/cvsroot/gsharp
In directory common-lisp.net:/tmp/cvs-serv1751
Modified Files:
esa.lisp
Log Message:
Merge climacs' version of esa
Date: Sat Oct 1 11:37:32 2005
Author: crhodes
Index: gsharp/esa.lisp
diff -u gsharp/esa.lisp:1.4 gsharp/esa.lisp:1.5
--- gsharp/esa.lisp:1.4 Mon Aug 8 02:22:07 2005
+++ gsharp/esa.lisp Sat Oct 1 11:37:32 2005
@@ -301,7 +301,7 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
-;;; comand table manipulation
+;;; command table manipulation
(defun ensure-subtable (table gesture)
(let* ((event (make-instance
@@ -319,15 +319,20 @@
(command-menu-item-value
(find-keystroke-item event table :errorp nil))))
-
(defun set-key (command table gestures)
- (if (null (cdr gestures))
- (add-command-to-command-table
- command table :keystroke (car gestures) :errorp nil)
- (set-key command
- (ensure-subtable table (car gestures))
- (cdr gestures))))
-
+ (unless (consp command)
+ (setf command (list command)))
+ (let ((gesture (car gestures)))
+ (cond ((null (cdr gestures))
+ (add-command-to-command-table
+ command table :keystroke gesture :errorp nil)
+ (when (and (listp gesture)
+ (find :meta gesture))
+ (set-key command table (list (list :escape) (remove :meta gesture)))))
+ (t (set-key command
+ (ensure-subtable table gesture)
+ (cdr gestures))))))
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; standard key bindings
@@ -357,6 +362,209 @@
(set-key 'com-extended-command 'global-esa-table '((#\x :meta)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; 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 find-all-keystrokes-and-commands-with-inheritance (start-table)
+ (let ((results '()))
+ (labels ((helper (table)
+ (let ((res (find-all-keystrokes-and-commands table)))
+ (when res (setf results (nconc res results)))
+ (dolist (subtable (command-table-inherit-from
+ (find-command-table table)))
+ (helper subtable)))))
+ (helper start-table))
+ 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-with-inheritance
+ 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-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-bindings ,*numeric-argument-p*) 'help-table '((#\h :control) (#\b)))
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Keyboard macros
@@ -420,7 +628,7 @@
esa-frame-mixin)
()
(:panes
- (win (let* ((my-pane
+ (window (let* ((my-pane
(make-pane 'example-pane
:width 900 :height 400
:display-function 'display-my-pane
@@ -434,12 +642,12 @@
(scrolling ()
my-pane)
my-info-pane)))
- (int (make-pane 'example-minibuffer-pane :width 900)))
+ (minibuffer (make-pane 'example-minibuffer-pane :width 900)))
(:layouts
(default
(vertically (:scroll-bars nil)
- win
- int)))
+ window
+ minibuffer)))
(:top-level (esa-top-level)))
(defun display-my-pane (frame pane)
More information about the Gsharp-cvs
mailing list