[climacs-cvs] CVS esa
dmurray
dmurray at common-lisp.net
Sat May 13 16:48:04 UTC 2006
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
More information about the Climacs-cvs
mailing list