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)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;