Update of /project/climacs/cvsroot/esa In directory clnet:/tmp/cvs-serv15009
Modified Files: esa.lisp Log Message: Moved more help functionality into base ESA. There is now a gf HELP-STREAM FRAME TITLE that provides the stream for the help commands to operate on. The basic method provides a separate output window. (Climacs provides a typeout pane.)
ESA help commands now comprise: Describe Key Briefly C-h c Where Is C-h w Describe Bindings C-h b Describe Key C-h k Describe Command C-h f Apropos Command C-h a
Command docstrings should consist of a first line with a short description, followed by paragraphs separated by a double #\Newline. (There is no need to put a second #\Newline between the first line and the rest of the docstring. The rest of the docstring will be wrapped to the [initial] width of the help stream.)
Much of this was just moving Mr Henriksen's code to ESA.
--- /project/climacs/cvsroot/esa/esa.lisp 2006/05/12 18:51:54 1.18 +++ /project/climacs/cvsroot/esa/esa.lisp 2006/05/13 16:48:04 1.19 @@ -643,7 +643,7 @@ (define-command-table global-esa-table)
(define-command (com-quit :name t :command-table global-esa-table) () - "Exit Climacs. + "Exit. First ask if modified buffers should be saved. If you decide not to save a modified buffer, you will be asked to confirm your decision to exit." (frame-exit *application-frame*))
@@ -673,6 +673,16 @@ ;;; ;;; Help
+(defgeneric help-stream (frame title)) + +(defmethod help-stream (frame title) + (open-window-stream + :label title + :input-buffer (#+mcclim climi::frame-event-queue + #-mcclim silica:frame-input-buffer + *application-frame*) + :width 400)) + (defun read-gestures-for-help (command-table) (loop for gestures = (list (esa-read-gesture)) then (nconc gestures (list (esa-read-gesture))) @@ -786,6 +796,16 @@ (helper start-table)) results))
+(defun find-all-commands-and-keystrokes-with-inheritance (start-table) + (let ((results '())) + (map-over-command-table-commands + (lambda (command) + (let ((keys (find-keystrokes-for-command-with-inheritance command start-table))) + (push (cons command keys) results))) + start-table + :inherited t) + results)) + (defun sort-by-name (list) (sort list #'string< :key (lambda (item) (symbol-name (if (listp (cdr item)) @@ -831,31 +851,56 @@
(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 + be a symbol bound to a function, to `stream'. If no documentation can be found, this fact will be printed to the 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))))))) + (let* ((command-documentation (or (documentation command-name 'function) + "This command is not documented.")) + (first-newline (position #\Newline command-documentation)) + (first-line (subseq command-documentation 0 first-newline))) + ;; First line is special + (format stream "~A~%" first-line) + (when first-newline + (let* ((rest (subseq command-documentation first-newline)) + (paras (delete "" + (loop for start = 0 then (+ 2 end) + for end = (search '(#\Newline #\Newline) rest :start2 start) + collecting + (nsubstitute #\Space #\Newline (subseq rest start end)) + while end) + :test #'string=))) + (dolist (para paras) + (terpri stream) + (let ((words (loop with length = (length para) + with index = 0 + with start = 0 + while (< index length) + do (loop until (>= index length) + while (member (char para index) '(#\Space #\Tab)) + do (incf index)) + (setf start index) + (loop until (>= index length) + until (member (char para index) '(#\Space #\Tab)) + do (incf index)) + until (= start index) + collecting (string-trim '(#\Space #\Tab #\Newline) + (subseq para start index))))) + (loop with margin = (stream-text-margin stream) + with space-width = (stream-character-width stream #\Space) + with current-width = 0 + for word in words + for word-width = (stream-string-width stream word) + when (> (+ word-width current-width) + margin) + do (terpri stream) + (setf current-width 0) + do (princ word stream) + (princ #\Space stream) + (incf current-width (+ word-width space-width)))) + (terpri stream)))))))
(defun describe-command-binding-to-stream (gesture command &key (command-table (find-applicable-command-table *application-frame*)) @@ -872,27 +917,34 @@ command-table))) (with-text-style (stream '(:sans-serif nil nil)) (princ "The gesture " stream) - (with-text-style (stream '(:fix nil nil)) + (with-drawing-options (stream :ink +dark-blue+ + :text-style '(: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) + (with-text-style (stream '(nil :bold nil)) + (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)) + (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)))) + (print-docstring-for-command command-name command-table stream) + (scroll-extent stream 0 0))))
-(defun describe-command-to-stream (command-name &key - (command-table (esa:find-applicable-command-table *application-frame*)) - (stream *standard-output*)) +(defun describe-command-to-stream + (command-name &key + (command-table (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))) (with-text-style (stream '(:sans-serif nil nil)) - (present command-name `(command-name :command-table ,command-table) :stream stream) + (with-text-style (stream '(nil :bold 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) @@ -905,14 +957,16 @@ (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)) + do (with-drawing-options (stream :ink +dark-blue+ + :text-style '(: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)))) + (print-docstring-for-command command-name command-table stream) + (scroll-extent stream 0 0))))
;;; help commands
@@ -950,16 +1004,10 @@
(define-command (com-describe-bindings :name t :command-table help-table) ((sort-by-keystrokes 'boolean :prompt "Sort by keystrokes?")) - "Pop up a help window showing which keys invoke which commands. + "Show which keys invoke which commands. Without a numeric prefix, sorts the list by command name. With a numeric prefix, sorts by key." - (let* ((window (car (windows *application-frame*))) - (stream (open-window-stream - :label (format nil "Help: Describe Bindings") - :input-buffer (#+mcclim climi::frame-event-queue - #-mcclim silica:frame-input-buffer - *application-frame*) - :width 400)) - (command-table (command-table window))) + (let ((stream (help-stream *application-frame* (format nil "Help: Describe Bindings"))) + (command-table (find-applicable-command-table *application-frame*))) (describe-bindings stream command-table (if sort-by-keystrokes #'sort-by-keystrokes @@ -967,6 +1015,117 @@
(set-key `(com-describe-bindings ,*numeric-argument-p*) 'help-table '((#\h :control) (#\b)))
+(define-command (com-describe-key :name t :command-table help-table) + () + "Display documentation for the command invoked by a given gesture sequence. +When invoked, this command will wait for user input. If the user inputs a gesture +sequence bound to a command available in the syntax of the current buffer, +documentation and other details will be displayed in a typeout pane." + (let ((command-table (find-applicable-command-table *application-frame*))) + (display-message "Describe Key:") + (redisplay-frame-panes *application-frame*) + (multiple-value-bind (command gestures) + (read-gestures-for-help command-table) + (let ((gesture-name (format nil "~{~A~#[~; ~; ~]~}" + (mapcar #'gesture-name gestures)))) + (if command + (let ((out-stream + (help-stream *application-frame* + (format nil "~10THelp: Describe Key for ~A" gesture-name)))) + (describe-command-binding-to-stream gesture-name command + :command-table command-table + :stream out-stream)) + (display-message "Unbound gesture: ~A" gesture-name)))))) + +(set-key 'com-describe-key + 'help-table + '((#\h :control) (#\k))) + +(define-command (com-describe-command :name t :command-table help-table) + ((command 'command-name :prompt "Describe command")) + "Display documentation for the given command." + (let* ((command-table (find-applicable-command-table *application-frame*)) + (out-stream (help-stream *application-frame* + (format nil "~10THelp: Describe Command for ~A" + (command-line-name-for-command command + command-table + :errorp nil))))) + (describe-command-to-stream command + :command-table command-table + :stream out-stream))) + +(set-key `(com-describe-command ,*unsupplied-argument-marker*) + 'help-table + '((#\h :control) (#\f))) + +(define-presentation-to-command-translator describe-command + (command-name com-describe-command help-table + :gesture :select + :documentation "Describe command") + (object) + (list object)) + +(define-command (com-apropos-command :name t :command-table help-table) + ((words '(sequence string) :prompt "Search word(s)")) + "Shows commands with documentation matching the search words. +Words are comma delimited. When more than two words are given, the documentation must match any two." + ;; 23.8.6 "It is unspecified whether accept returns a list or a vector." + (setf words (coerce words 'list)) + (when words + (let* ((command-table (find-applicable-command-table *application-frame*)) + (results (loop for (function . keys) + in (find-all-commands-and-keystrokes-with-inheritance + command-table) + when (consp function) + do (setq function (car function)) + when (let ((documentation (or (documentation function 'function) "")) + (score 0)) + (cond + ((> (length words) 1) + (loop for word in words + until (> score 1) + when (or + (search word (symbol-name function) + :test #'char-equal) + (search word documentation :test #'char-equal)) + do (incf score) + finally (return (> score 1)))) + (t (or + (search (first words) (symbol-name function) + :test #'char-equal) + (search (first words) documentation :test #'char-equal))))) + collect (cons function keys)))) + (if (null results) + (display-message "No results for ~{~A~^, ~}" words) + (let ((out-stream (help-stream *application-frame* + (format nil "~10THelp: Apropos ~{~A~^, ~}" + words)))) + (loop for (command . keys) in results + for documentation = (or (documentation command 'function) + "Not documented.") + do (with-text-style (out-stream '(:sans-serif :bold nil)) + (present command + `(command-name :command-table ,command-table) + :stream out-stream)) + (with-drawing-options (out-stream :ink +dark-blue+ + :text-style '(:fix nil nil)) + (format out-stream "~30T~:[M-x ... RETURN~;~:*~{~A~^, ~}~]" + (mapcar (lambda (keystrokes) + (format nil "~{~A~^ ~}" + (mapcar #'gesture-name (reverse keystrokes)))) + (car keys)))) + (with-text-style (out-stream '(:sans-serif nil nil)) + (format out-stream "~&~2T~A~%" + (subseq documentation 0 (position #\Newline documentation)))) + count command into length + finally (change-space-requirements out-stream + :height (* length (stream-line-height out-stream))) + (scroll-extent out-stream 0 0))))))) + +(set-key `(com-apropos-command ,*unsupplied-argument-marker*) + 'help-table + '((#\h :control) (#\a))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Keyboard macros