/[cmucl]/src/hemlock/doccoms.lisp
ViewVC logotype

Contents of /src/hemlock/doccoms.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1 - (show annotations)
Wed May 9 13:03:40 1990 UTC (23 years, 11 months ago) by ram
Branch: MAIN
Initial revision
1 ;;; -*- Log: hemlock.log; Package: Hemlock -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the Spice Lisp project at
5 ;;; Carnegie-Mellon University, and has been placed in the public domain.
6 ;;; Spice Lisp is currently incomplete and under active development.
7 ;;; If you want to use this code or any part of Spice Lisp, please contact
8 ;;; Scott Fahlman (FAHLMAN@CMUC).
9 ;;; **********************************************************************
10 ;;;
11 ;;; Hemlock Documentation and Help commands.
12 ;;; Written by Rob MacLachlan and Bill Chiles.
13 ;;;
14
15 (in-package "HEMLOCK")
16
17
18
19 ;;;; Help.
20
21 (defcommand "Help" (p)
22 "Give helpful information.
23 This command dispatches to a number of other documentation commands,
24 on the basis of a character command."
25 "Prompt for a single character command to dispatch to another helping
26 function."
27 (declare (ignore p))
28 (command-case (:prompt "Doc (Help for Help): "
29 :help "Type a Help option to say what kind of help you want:")
30 (#\A "List all commands, variables and attributes Apropos a keyword."
31 (apropos-command nil))
32 (#\D "Describe a command, given its name."
33 (describe-command-command nil))
34 (#\G "Generic describe, any Hemlock thing (e.g., variables, keys, attributes)."
35 (generic-describe-command nil))
36 (#\V "Describe variable and show its values."
37 (describe-and-show-variable-command nil))
38 (#\C "Describe the command bound to a Character."
39 (describe-key-command nil))
40 (#\L "List the last 60 characters typed."
41 (what-lossage-command nil))
42 (#\M "Describe a mode."
43 (describe-mode-command nil))
44 (#\P "Describe commands with mouse/pointer bindings."
45 (describe-pointer-command nil))
46 (#\W "Find out Where a command is bound."
47 (where-is-command nil))
48 (#\T "Describe a Lisp object."
49 (editor-describe-command nil))
50 ((#\Q :no) "Quits, You don't really want help.")))
51
52 (defcommand "Where Is" (p)
53 "Find what key a command is bound to.
54 Prompts for the command to look for, and says what environment it is
55 available in."
56 "List places where a command is bound."
57 (declare (ignore p))
58 (multiple-value-bind (nam cmd)
59 (prompt-for-keyword (list *command-names*)
60 :prompt "Command: "
61 :help "Name of command to look for.")
62 (let ((bindings (command-bindings cmd)))
63 (with-pop-up-display (s)
64 (cond
65 ((null bindings)
66 (format s "~S may only be invoked as an extended command.~%" nam))
67 (t
68 (format s "~S may be invoked in the following ways:~%" nam)
69 (print-command-bindings bindings s)))))))
70
71
72
73 ;;;; Apropos.
74
75 (defcommand "Apropos" (p)
76 "List things whose names contain a keyword."
77 "List things whose names contain a keyword."
78 (declare (ignore p))
79 (let* ((str (prompt-for-string
80 :prompt "Apropos keyword: "
81 :help
82 "String to look for in command, variable and attribute names."))
83 (coms (find-containing str *command-names*))
84 (vars (mapcar #'(lambda (table)
85 (let ((res (find-containing str table)))
86 (if res (cons table res))))
87 (current-variable-tables)))
88 (attr (find-containing str *character-attribute-names*)))
89 (if (or coms vars attr)
90 (apropos-command-output str coms vars attr)
91 (with-pop-up-display (s :height 1)
92 (format s "No command, attribute or variable name contains ~S."
93 str)))))
94
95 (defun apropos-command-output (str coms vars attr)
96 (declare (list coms vars attr))
97 (with-pop-up-display (s)
98 (when coms
99 (format s "Commands with ~S in their names:~%" str)
100 (dolist (com coms)
101 (let ((obj (getstring com *command-names*)))
102 (write-string com s)
103 (write-string " " s)
104 (print-command-bindings (command-bindings obj) s)
105 (terpri s)
106 (print-short-doc (command-documentation obj) s))))
107 (when vars
108 (when coms (terpri s))
109 (format s "Variables with ~S in their names:~%" str)
110 (dolist (stuff vars)
111 (let ((table (car stuff)))
112 (dolist (var (cdr stuff))
113 (let ((obj (getstring var table)))
114 (write-string var s)
115 (write-string " " s)
116 (let ((*print-level* 2) (*print-length* 3))
117 (prin1 (variable-value obj) s))
118 (terpri s)
119 (print-short-doc (variable-documentation obj) s))))))
120 (when attr
121 (when (or coms vars) (terpri s))
122 (format s "Attributes with ~S in their names:~%" str)
123 (dolist (att attr)
124 (let ((obj (getstring att *character-attribute-names*)))
125 (write-line att s)
126 (print-short-doc (character-attribute-documentation obj) s))))))
127
128 ;;; PRINT-SHORT-DOC takes doc, a function or string, and gets it out on stream.
129 ;;; If doc is a string, this only outputs up to the first newline. All output
130 ;;; is preceded by two spaces.
131 ;;;
132 (defun print-short-doc (doc stream)
133 (let ((str (typecase doc
134 (function (funcall doc :short))
135 (simple-string
136 (let ((nl (position #\newline (the simple-string doc))))
137 (subseq doc 0 (or nl (length doc)))))
138 (t
139 (error "Bad documentation: ~S" doc)))))
140 (write-string " " stream)
141 (write-line str stream)))
142
143
144
145 ;;;; Describe command, key, pointer.
146
147 (defcommand "Describe Command" (p)
148 "Describe a command.
149 Prompts for a command and then prints out it's full documentation."
150 "Print out the command documentation for a command which is prompted for."
151 (declare (ignore p))
152 (multiple-value-bind (nam com)
153 (prompt-for-keyword
154 (list *command-names*)
155 :prompt "Describe command: "
156 :help "Name of a command to document.")
157 (let ((bindings (command-bindings com)))
158 (with-pop-up-display (s)
159 (format s "Documentation for ~S:~% ~A~%"
160 nam (command-documentation com))
161 (cond ((not bindings)
162 (write-line
163 "This can only be invoked as an extended command." s))
164 (t
165 (write-line
166 "This can be invoked in the following ways:" s)
167 (write-string " " s)
168 (print-command-bindings bindings s)
169 (terpri s)))))))
170
171 (defcommand "Describe Key" (p)
172 "Prompt for a sequence of characters. When the first character is typed that
173 terminates a key binding in the current context, describe the command bound
174 to it. When the first character is typed that no longer allows a correct
175 key to be entered, tell the user that this sequence is not bound to anything."
176 "Print out the command documentation for a key which is prompted for."
177 (declare (ignore p))
178 (let ((old-window (current-window)))
179 (unwind-protect
180 (progn
181 (setf (current-window) hi::*echo-area-window*)
182 (hi::display-prompt-nicely "Describe key: " nil)
183 (setf (fill-pointer hi::*prompt-key*) 0)
184 (loop
185 (let ((char (read-char hi::*editor-input*)))
186 (vector-push-extend char hi::*prompt-key*)
187 (let ((res (get-command hi::*prompt-key* :current)))
188 (format hi::*echo-area-stream* "~:C " char)
189 (cond ((commandp res)
190 (with-pop-up-display (s)
191 (sub-print-key (copy-seq hi::*prompt-key*) s)
192 (format s " is bound to ~S.~%" (command-name res))
193 (format s "Documentation for this command:~% ~A"
194 (command-documentation res)))
195 (return))
196 ((not (eq res :prefix))
197 (with-pop-up-display (s :height 1)
198 (sub-print-key (copy-seq hi::*prompt-key*) s)
199 (write-string " is not bound to anything." s))
200 (return)))))))
201 (setf (current-window) old-window))))
202
203 (defcommand "Describe Pointer" (p)
204 "Describe commands with any key binding that contains a \"mouse\" character
205 (modified or not). Does not describe the command \"Illegal\"."
206 "Describe commands with any key binding that contains a \"mouse\" character
207 (modified or not). Does not describe the command \"Illegal\"."
208 (declare (ignore p))
209 (let ((illegal-command (getstring "Illegal" *command-names*)))
210 (with-pop-up-display (s)
211 (dolist (cmd (get-mouse-commands))
212 (unless (eq cmd illegal-command)
213 (format s "Documentation for ~S:~% ~A~%"
214 (command-name cmd)
215 (command-documentation cmd))
216 (write-line
217 "This can be invoked in the following ways:" s)
218 (write-string " " s)
219 (print-command-bindings (command-bindings cmd) s)
220 (terpri s) (terpri s))))))
221
222 (defun get-mouse-commands ()
223 (let ((result nil))
224 (do-strings (name cmd *command-names* result)
225 (declare (ignore name))
226 (dolist (b (command-bindings cmd))
227 (let ((key (car b)))
228 (declare (simple-vector key))
229 (when (dotimes (i (length key) nil)
230 (when (member (make-char (svref key i))
231 '(#\leftdown #\leftup #\middledown #\middleup
232 #\rightdown #\rightup))
233 (push cmd result)
234 (return t)))
235 (return)))))))
236
237
238
239 ;;;; Generic describe variable, command, key, attribute.
240
241 (defvar *generic-describe-kinds*
242 (list (make-string-table :initial-contents
243 '(("Variable" . :variable)
244 ("Command" . :command)
245 ("Key" . :key)
246 ("Attribute" . :attribute)))))
247
248 (defcommand "Generic Describe" (p)
249 "Describe some Hemlock thing.
250 First prompt for the kind of thing, then prompt for the thing to describe.
251 Currently supported kinds of things are variables, commands, keys and
252 character attributes."
253 "Prompt for some Hemlock thing to describe."
254 (declare (ignore p))
255 (multiple-value-bind (ignore kwd)
256 (prompt-for-keyword *generic-describe-kinds*
257 :default "Variable"
258 :help "Kind of thing to describe."
259 :prompt "Kind: ")
260 (declare (ignore ignore))
261 (case kwd
262 (:variable
263 (describe-and-show-variable-command nil))
264 (:command (describe-command-command ()))
265 (:key (describe-key-command ()))
266 (:attribute
267 (multiple-value-bind (name attr)
268 (prompt-for-keyword
269 (list *character-attribute-names*)
270 :help "Name of character attribute to describe."
271 :prompt "Attribute: ")
272 (print-full-doc name (character-attribute-documentation attr)))))))
273
274 ;;; PRINT-FULL-DOC displays whole documentation string in a pop-up window.
275 ;;; Doc may be a function that takes at least one arg, :short or :full.
276 ;;;
277 (defun print-full-doc (nam doc)
278 (typecase doc
279 (function (funcall doc :full))
280 (simple-string
281 (with-pop-up-display (s)
282 (format s "Documentation for ~S:~% ~A" nam doc)))
283 (t (error "Bad documentation: ~S" doc))))
284
285
286
287 ;;;; Describing and show variables.
288
289 (defcommand "Show Variable" (p)
290 "Display the values of a Hemlock variable."
291 "Display the values of a Hemlock variable."
292 (declare (ignore p))
293 (multiple-value-bind (name var)
294 (prompt-for-variable
295 :help "Name of variable to describe."
296 :prompt "Variable: ")
297 (with-pop-up-display (s)
298 (show-variable s name var))))
299
300 (defcommand "Describe and Show Variable" (p)
301 "Describe in full and show all of variable's value.
302 Variable is prompted for."
303 "Describe in full and show all of variable's value."
304 (declare (ignore p))
305 (multiple-value-bind (name var)
306 (prompt-for-variable
307 :help "Name of variable to describe."
308 :prompt "Variable: ")
309 (with-pop-up-display (s)
310 (format s "Documentation for ~S:~% ~A~&~%"
311 name (variable-documentation var))
312 (show-variable s name var))))
313
314 (defun show-variable (s name var)
315 (when (hemlock-bound-p var :global)
316 (format s "Global value of ~S:~% ~S~%"
317 name (variable-value var :global)))
318 (let ((buffer (current-buffer)))
319 (when (hemlock-bound-p var :buffer (current-buffer))
320 (format s "Value of ~S in buffer ~A:~% ~S~%"
321 name (buffer-name buffer)
322 (variable-value var :buffer buffer))))
323 (do-strings (mode-name val *mode-names*)
324 (declare (ignore val))
325 (when (hemlock-bound-p var :mode mode-name)
326 (format s "Value of ~S in ~S Mode:~% ~S~%"
327 name mode-name
328 (variable-value var :mode mode-name)))))
329
330
331
332 ;;;; Describing modes.
333
334 (defvar *describe-mode-ignore* (list "Illegal" "Do Nothing"))
335
336 (defcommand "Describe Mode" (p &optional name)
337 "Describe a mode showing special bindings for that mode."
338 "Describe a mode showing special bindings for that mode."
339 (declare (ignore p))
340 (let ((name (or name
341 (prompt-for-keyword (list *mode-names*)
342 :prompt "Mode: "
343 :help "Enter mode to describe."
344 :default
345 (car (buffer-modes (current-buffer)))))))
346 (with-pop-up-display (s)
347 (format s "~A mode description:~%" name)
348 (let ((doc (mode-documentation name)))
349 (when doc
350 (write-line doc s)
351 (terpri s)))
352 (map-bindings
353 #'(lambda (key cmd)
354 (unless (member (command-name cmd)
355 *describe-mode-ignore*
356 :test #'string-equal)
357 (let ((str (key-to-string key)))
358 (cond ((= (length str) 1)
359 (write-string str s)
360 (write-string " - " s))
361 (t (write-line str s)
362 (write-string " - " s)))
363 (print-short-doc (command-documentation cmd) s))))
364 :mode name))))
365
366 (defun key-to-string (key)
367 (with-output-to-string (s)
368 (sub-print-key key s)))
369
370
371
372 ;;;; Printing bindings and last N characters typed.
373
374 (defcommand "What Lossage" (p)
375 "Display the last 60 characters typed."
376 "Display the last 60 characters typed."
377 (declare (ignore p))
378 (with-pop-up-display (s :height 7)
379 (let ((num (ring-length *character-history*)))
380 (format s "The last ~D characters typed:~%" num)
381 (do ((i (1- num) (1- i)))
382 ((minusp i))
383 (print-pretty-character (ring-ref *character-history* i) s)
384 (write-char #\space s)))))
385
386 (defun print-command-bindings (bindings stream)
387 (let ((buffer ())
388 (mode ())
389 (global ()))
390 (dolist (b bindings)
391 (case (second b)
392 (:global (push (first b) global))
393 (:mode
394 (let ((m (assoc (third b) mode :test #'string=)))
395 (if m
396 (push (first b) (cdr m))
397 (push (list (third b) (first b)) mode))))
398 (t
399 (let ((f (assq (third b) buffer)))
400 (if f
401 (push (first b) (cdr f))
402 (push (list (third b) (first b)) buffer))))))
403 (when global
404 (print-some-keys global stream)
405 (write-string "; " stream))
406 (dolist (b buffer)
407 (format stream "Buffer ~S: " (buffer-name (car b)))
408 (print-some-keys (cdr b) stream)
409 (write-string "; " stream))
410 (dolist (m mode)
411 (write-string (car m) stream)
412 (write-string ": " stream)
413 (print-some-keys (cdr m) stream)
414 (write-string "; " stream))))
415
416 ;;; PRINT-SOME-KEYS prints the list of keys onto Stream.
417 ;;;
418 (defun print-some-keys (keys stream)
419 (do ((key keys (cdr key)))
420 ((null (cdr key))
421 (sub-print-key (car key) stream))
422 (sub-print-key (car key) stream)
423 (write-string ", " stream)))
424
425 ;;; SUB-PRINT-KEY writes key on stream as a serious pretty printed characters
426 ;;; separated by spaces.
427 ;;;
428 (defun sub-print-key (key stream)
429 (declare (simple-vector key))
430 (let ((last (1- (length key))))
431 (dotimes (i last)
432 (print-pretty-character (svref key i) stream)
433 (write-char #\space stream))
434 (print-pretty-character (svref key last) stream)))

  ViewVC Help
Powered by ViewVC 1.1.5