Update of /project/climacs/cvsroot/esa In directory clnet:/tmp/cvs-serv19623
Modified Files: esa.lisp Log Message: Use sans-serif font for documentation, `present' command names in Describe Bindings, remove single linebreaks from docstrings.
--- /project/climacs/cvsroot/esa/esa.lisp 2006/05/10 09:52:05 1.15 +++ /project/climacs/cvsroot/esa/esa.lisp 2006/05/10 16:22:20 1.16 @@ -817,11 +817,9 @@ 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)))) + (present command + `(command-name :command-table ,command-table) + :stream stream))) (formatting-cell (stream) (with-drawing-options (stream :ink +dark-blue+ :text-style '(:fix nil nil)) @@ -832,66 +830,90 @@ :height (* length (stream-line-height stream))) (scroll-extent stream 0 0))))
-(defun print-docstring-for-command (command-name &optional (stream *standard-output*)) +(defun print-docstring-for-command (command-name command-table &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))) + (declare (ignore command-table)) + ;; This needs more regex magic. Also, it is only an interim + ;; solution. + (with-text-style (stream '(:sans-serif nil nil)) + (let ((command-documentation (or (documentation command-name 'function) + "This command is not documented."))) + + ;; Remove single linebreaks but preserve double linebreaks. + (loop for char across command-documentation + with newline = nil + do + (if (char-equal char #\Newline) + (if newline + (progn + (terpri stream) + (terpri stream) + (setf newline nil)) + (setf newline t)) + (progn + (when newline + (princ #\Space stream) + (setf newline nil)) + (princ char stream)))))))
-(defun describe-command-binding-to-stream (gesture-name command &key +(defun describe-command-binding-to-stream (gesture 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 + (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))) + (with-text-style (stream '(:sans-serif nil nil)) + (princ "The gesture " stream) + (with-text-style (stream '(:fix nil nil)) + (princ gesture 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 :command-table ,command-table) :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 command-table 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))) + (with-text-style (stream '(:sans-serif nil nil)) + (present command-name `(command-name :command-table ,command-table) :stream stream) + (princ " calls the function " stream) + (present command-name 'symbol :stream stream) + (princ " and is accessible in " stream) + (if (command-accessible-in-command-table-p command-name command-table) + (present (command-accessible-in-command-table-p command-name command-table) + 'command-table + :stream stream) + (princ "an unknown command table" stream)) + (format stream ".~%") + (when (plusp (length keystrokes)) + (princ "It is bound to " stream) + (loop for gestures-list on (first keystrokes) + do (with-text-style (stream '(:fix nil nil)) + (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 command-table stream))))
;;; help commands