Update of /project/climacs/cvsroot/esa In directory clnet:/tmp/cvs-serv496

Modified Files: packages.lisp esa.lisp Log Message: Added command and command-binding description functions.

--- /project/climacs/cvsroot/esa/packages.lisp 2006/04/08 23:36:44 1.2 +++ /project/climacs/cvsroot/esa/packages.lisp 2006/05/02 18:01:49 1.3 @@ -9,6 +9,9 @@ #:esa-top-level #:simple-command-loop #:global-esa-table #:keyboard-macro-table #:help-table + #:describe-command-binding-to-stream + #:describe-command-to-stream + #:gesture-name #:set-key #:find-applicable-command-table))

--- /project/climacs/cvsroot/esa/esa.lisp 2006/04/30 11:59:03 1.8 +++ /project/climacs/cvsroot/esa/esa.lisp 2006/05/02 18:01:49 1.9 @@ -639,6 +639,67 @@ :height (* length (stream-line-height stream))) (scroll-extent stream 0 0))))

+(defun print-docstring-for-command (command-name &optional (stream *standard-output*)) + "Print documentation for `command-name', which should + be a symbol bound to a function, to `stream. If no + documentation can be found, this fact will be printed to the stream." + ;; Eventually, we should try to parse the docstring and hyperlink + ;; it to other relevant symbols. + (let ((command-documentation (or (documentation command-name 'function) + "This command is not documented."))) + (princ command-documentation stream))) + +(defun describe-command-binding-to-stream (gesture-name command &key + (command-table (find-applicable-command-table *application-frame*)) + (stream *standard-output*)) + "Describe `command' as invoked by `gesture' to `stream'." + (let* ((command-name (if (listp command) + (first command) + command)) + (command-args (if (listp command) + (rest command))) + (real-command-table (or (command-accessible-in-command-table-p + command-name + command-table) + command-table))) + (princ "The gesture " stream) + (with-text-face (stream :italic) + (princ gesture-name stream)) + (princ " is bound to the command " stream) + (if (command-present-in-command-table-p command-name real-command-table) + (present command-name 'command-name :stream stream) + (present command-name 'symbol :stream stream)) + (princ " in " stream) + (present real-command-table 'command-table :stream stream) + (format stream ".~%") + (when command-args + (apply #'format stream "This binding invokes the command with the arguments ~@{~A~^, ~}.~%" command-args)) + (terpri stream) + (print-docstring-for-command command-name stream))) + +(defun describe-command-to-stream (command-name &key + (command-table (esa:find-applicable-command-table *application-frame*)) + (stream *standard-output*)) + "Describe `command' to `stream'." + (let ((keystrokes (find-keystrokes-for-command-with-inheritance command-name command-table))) + (present command-name 'command-name :stream stream) + (princ " calls the function " stream) + (present command-name 'symbol :stream stream) + (princ " and is accessible in " stream) + (present (command-accessible-in-command-table-p command-name command-table) 'command-table + :stream stream) + (format stream ".~%") + (when (plusp (length keystrokes)) + (princ "It is bound to " stream) + (loop for gestures-list on (first keystrokes) + do (format stream "~{~A~^ ~}" + (mapcar #'gesture-name (reverse (first gestures-list)))) + when (not (null (rest gestures-list))) + do (princ ", " stream))) + (terpri stream) + (terpri stream) + (print-docstring-for-command command-name stream))) + ;;; help commands

(define-command-table help-table)