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

Contents of /src/hemlock/echo.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (show annotations)
Fri Jul 13 15:11:45 1990 UTC (23 years, 9 months ago) by ram
Branch: MAIN
Changes since 1.1: +175 -172 lines
*** empty log message ***
1 ;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*-
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 Echo Area stuff.
12 ;;; Written by Skef Wholey and Rob MacLachlan.
13 ;;; Modified by Bill Chiles.
14 ;;;
15 (in-package "HEMLOCK-INTERNALS")
16 (export '(*echo-area-buffer* *echo-area-stream* *echo-area-window*
17 *parse-starting-mark* *parse-input-region*
18 *parse-verification-function* *parse-string-tables*
19 *parse-value-must-exist* *parse-default* *parse-default-string*
20 *parse-prompt* *parse-help* clear-echo-area message loud-message
21 prompt-for-buffer prompt-for-file prompt-for-integer
22 prompt-for-keyword prompt-for-expression prompt-for-string
23 prompt-for-variable prompt-for-yes-or-no prompt-for-y-or-n
24 prompt-for-key-event prompt-for-key *logical-key-event-names*
25 logical-key-event-p logical-key-event-documentation
26 logical-key-event-name logical-key-event-key-events
27 define-logical-key-event *parse-type* current-variable-tables))
28
29
30 (defmode "Echo Area" :major-p t)
31 (defvar *echo-area-buffer* (make-buffer "Echo Area" :modes '("Echo Area"))
32 "Buffer used to hack text for the echo area.")
33 (defvar *echo-area-region* (buffer-region *echo-area-buffer*)
34 "Internal thing that's the *echo-area-buffer*'s region.")
35 (defvar *echo-area-stream*
36 (make-hemlock-output-stream (region-end *echo-area-region*) :full)
37 "Buffered stream that prints into the echo area.")
38 (defvar *echo-area-window* ()
39 "Window used to display stuff in the echo area.")
40 (defvar *parse-starting-mark*
41 (copy-mark (buffer-point *echo-area-buffer*) :right-inserting)
42 "Mark that points to the beginning of the text that'll be parsed.")
43 (defvar *parse-input-region*
44 (region *parse-starting-mark* (region-end *echo-area-region*))
45 "Region that contains the text typed in.")
46
47
48
49 ;;;; Variables that control parsing:
50
51 (defvar *parse-verification-function* '%not-inside-a-parse
52 "Function that verifies what's being parsed.")
53
54 ;;; %Not-Inside-A-Parse -- Internal
55 ;;;
56 ;;; This function is called if someone does stuff in the echo area when
57 ;;; we aren't inside a parse. It tries to put them back in a reasonable place.
58 ;;;
59 (defun %not-inside-a-parse (quaz)
60 "Thing that's called when somehow we get called to confirm a parse that's
61 not in progress."
62 (declare (ignore quaz))
63 (let* ((bufs (remove *echo-area-buffer* *buffer-list*))
64 (buf (or (find-if #'buffer-windows bufs)
65 (car bufs)
66 (make-buffer "Main"))))
67 (setf (current-buffer) buf)
68 (dolist (w *window-list*)
69 (when (and (eq (window-buffer w) *echo-area-buffer*)
70 (not (eq w *echo-area-window*)))
71 (setf (window-buffer w) buf)))
72 (setf (current-window)
73 (or (car (buffer-windows buf))
74 (make-window (buffer-start-mark buf)))))
75 (editor-error "Wham! We tried to confirm a parse that wasn't in progress?"))
76
77 (defvar *parse-string-tables* ()
78 "String tables being used in the current parse.")
79
80 (defvar *parse-value-must-exist* ()
81 "You know.")
82
83 (defvar *parse-default* ()
84 "When the user attempts to default a parse, we call the verification function
85 on this string. This is not the :Default argument to the prompting function,
86 but rather a string representation of it.")
87
88 (defvar *parse-default-string* ()
89 "String that we show the user to inform him of the default. If this
90 is NIL then we just use *Parse-Default*.")
91
92 (defvar *parse-prompt* ()
93 "Prompt for the current parse.")
94
95 (defvar *parse-help* ()
96 "Help string for the current parse.")
97
98 (defvar *parse-type* :string "A hack. :String, :File or :Keyword.")
99
100
101
102 ;;;; MESSAGE and CLEAR-ECHO-AREA:
103
104 (defhvar "Message Pause" "The number of seconds to pause after a Message."
105 :value 0.5s0)
106
107 (defvar *last-message-time* 0
108 "Internal-Real-Time the last time we displayed a message.")
109
110 (defun maybe-wait ()
111 (let* ((now (get-internal-real-time))
112 (delta (/ (float (- now *last-message-time*))
113 (float internal-time-units-per-second)))
114 (pause (value ed::message-pause)))
115 (when (< delta pause)
116 (sleep (- pause delta)))))
117
118 (defun clear-echo-area ()
119 "You guessed it."
120 (maybe-wait)
121 (delete-region *echo-area-region*)
122 (setf (buffer-modified *echo-area-buffer*) nil))
123
124 ;;; Message -- Public
125 ;;;
126 ;;; Display the stuff on *echo-area-stream* and then wait. Editor-Sleep
127 ;;; will do a redisplay if appropriate.
128 ;;;
129 (defun message (string &rest args)
130 "Nicely display a message in the echo-area.
131 Put the message on a fresh line and wait for \"Message Pause\" seconds
132 to give the luser a chance to see it. String and Args are a format
133 control string and format arguments, respectively."
134 (maybe-wait)
135 (cond ((eq *current-window* *echo-area-window*)
136 (let ((point (buffer-point *echo-area-buffer*)))
137 (with-mark ((m point :left-inserting))
138 (line-start m)
139 (with-output-to-mark (s m :full)
140 (apply #'format s string args)
141 (fresh-line s)))))
142 (t
143 (let ((mark (region-end *echo-area-region*)))
144 (cond ((buffer-modified *echo-area-buffer*)
145 (clear-echo-area))
146 ((not (zerop (mark-charpos mark)))
147 (insert-character mark #\newline)
148 (unless (displayed-p mark *echo-area-window*)
149 (clear-echo-area))))
150 (apply #'format *echo-area-stream* string args)
151 (setf (buffer-modified *echo-area-buffer*) nil))))
152 (force-output *echo-area-stream*)
153 (setq *last-message-time* (get-internal-real-time))
154 nil)
155
156
157 ;;; LOUD-MESSAGE -- Public.
158 ;;; Like message, only more provocative.
159 ;;;
160 (defun loud-message (&rest args)
161 "This is the same as MESSAGE, but it beeps and clears the echo area before
162 doing anything else."
163 (beep)
164 (clear-echo-area)
165 (apply #'message args))
166
167
168
169 ;;;; DISPLAY-PROMPT-NICELY and PARSE-FOR-SOMETHING.
170
171 (defun display-prompt-nicely (&optional (prompt *parse-prompt*)
172 (default (or *parse-default-string*
173 *parse-default*)))
174 (clear-echo-area)
175 (let ((point (buffer-point *echo-area-buffer*)))
176 (if (listp prompt)
177 (apply #'format *echo-area-stream* prompt)
178 (insert-string point prompt))
179 (when default
180 (insert-character point #\[)
181 (insert-string point default)
182 (insert-string point "] "))))
183
184 (defun parse-for-something ()
185 (display-prompt-nicely)
186 (let ((start-window (current-window)))
187 (move-mark *parse-starting-mark* (buffer-point *echo-area-buffer*))
188 (setf (current-window) *echo-area-window*)
189 (unwind-protect
190 (use-buffer *echo-area-buffer*
191 (recursive-edit nil))
192 (setf (current-window) start-window))))
193
194
195
196 ;;;; Buffer prompting.
197
198 (defun prompt-for-buffer (&key ((:must-exist *parse-value-must-exist*) t)
199 default
200 ((:default-string *parse-default-string*))
201 ((:prompt *parse-prompt*) "Buffer: ")
202 ((:help *parse-help*) "Type a buffer name."))
203 "Prompts for a buffer name and returns the corresponding buffer. If
204 :must-exist is nil, then return the input string. This refuses to accept
205 the empty string as input when no default is supplied. :default-string
206 may be used to supply a default buffer name even when :default is nil, but
207 when :must-exist is non-nil, :default-string must be the name of an existing
208 buffer."
209 (let ((*parse-string-tables* (list *buffer-names*))
210 (*parse-type* :keyword)
211 (*parse-default* (cond
212 (default (buffer-name default))
213 (*parse-default-string*
214 (when (and *parse-value-must-exist*
215 (not (getstring *parse-default-string*
216 *buffer-names*)))
217 (error "Default-string must name an existing ~
218 buffer when must-exist is non-nil -- ~S."
219 *parse-default-string*))
220 *parse-default-string*)
221 (t nil)))
222 (*parse-verification-function* #'buffer-verification-function))
223 (parse-for-something)))
224
225 (defun buffer-verification-function (string)
226 (declare (simple-string string))
227 (cond ((string= string "") nil)
228 (*parse-value-must-exist*
229 (multiple-value-bind
230 (prefix key value field ambig)
231 (complete-string string *parse-string-tables*)
232 (declare (ignore field))
233 (ecase key
234 (:none nil)
235 ((:unique :complete)
236 (list value))
237 (:ambiguous
238 (delete-region *parse-input-region*)
239 (insert-string (region-start *parse-input-region*) prefix)
240 (let ((point (current-point)))
241 (move-mark point (region-start *parse-input-region*))
242 (unless (character-offset point ambig)
243 (buffer-end point)))
244 nil))))
245 (t
246 (list (or (getstring string *buffer-names*) string)))))
247
248
249
250 ;;;; File Prompting.
251
252 (defun prompt-for-file (&key ((:must-exist *parse-value-must-exist*) t)
253 default
254 ((:default-string *parse-default-string*))
255 ((:prompt *parse-prompt*) "Filename: ")
256 ((:help *parse-help*) "Type a file name."))
257 "Prompts for a filename."
258 (let ((*parse-verification-function* #'file-verification-function)
259 (*parse-default* (if default (namestring default)))
260 (*parse-type* :file))
261 (parse-for-something)))
262
263 (defun file-verification-function (string)
264 (let ((pn (pathname-or-lose string)))
265 (if pn
266 (let ((merge
267 (cond ((not *parse-default*) nil)
268 ((directoryp pn)
269 (merge-pathnames pn *parse-default*))
270 (t
271 (merge-pathnames
272 (prompting-merge-pathnames (directory-namestring pn)
273 (directory-namestring
274 *parse-default*))
275 (file-namestring pn))))))
276 (cond ((probe-file pn) (list pn))
277 ((and merge (probe-file merge)) (list merge))
278 ((not *parse-value-must-exist*) (list (or merge pn)))
279 (t nil))))))
280
281 (defun prompting-merge-pathnames (pathname default-directory)
282 "Merges pathname with default-directory. If pathname is not absolute, it
283 is assumed to be relative to default-directory. The result is always a
284 directory. This works even when pathname is a logical name."
285 (if (and pathname (string/= (namestring pathname) ""))
286 (let ((pathname (pathname pathname))
287 (device (pathname-device pathname)))
288 (if (and device
289 (not (eq device :absolute))
290 (not (string= device "Default")))
291 pathname
292 (merge-relative-pathnames pathname default-directory)))
293 default-directory))
294
295 ;;; PATHNAME-OR-LOSE tries to convert string to a pathname using
296 ;;; PARSE-NAMESTRING. If it succeeds, this returns the pathname. Otherwise,
297 ;;; this deletes the offending characters from *parse-input-region* and signals
298 ;;; an editor-error.
299 ;;;
300 (defun pathname-or-lose (string)
301 (declare (simple-string string))
302 (multiple-value-bind (pn idx)
303 (parse-namestring string nil *default-pathname-defaults*
304 :junk-allowed t)
305 (cond (pn)
306 (t (delete-characters (region-end *echo-area-region*)
307 (- idx (length string)))
308 nil))))
309
310
311
312 ;;;; Keyword and variable prompting.
313
314 (defun prompt-for-keyword (*parse-string-tables*
315 &key
316 ((:must-exist *parse-value-must-exist*) t)
317 ((:default *parse-default*))
318 ((:default-string *parse-default-string*))
319 ((:prompt *parse-prompt*) "Keyword: ")
320 ((:help *parse-help*) "Type a keyword."))
321 "Prompts for a keyword using the String Tables."
322 (let ((*parse-verification-function* #'keyword-verification-function)
323 (*parse-type* :keyword))
324 (parse-for-something)))
325
326 (defun prompt-for-variable (&key ((:must-exist *parse-value-must-exist*) t)
327 ((:default *parse-default*))
328 ((:default-string *parse-default-string*))
329 ((:prompt *parse-prompt*) "Variable: ")
330 ((:help *parse-help*)
331 "Type the name of a variable."))
332 "Prompts for a variable defined in the current scheme of things."
333 (let ((*parse-string-tables* (current-variable-tables))
334 (*parse-verification-function* #'keyword-verification-function)
335 (*parse-type* :keyword))
336 (parse-for-something)))
337
338 (defun current-variable-tables ()
339 "Returns a list of all the variable tables currently established globally,
340 by the current buffer, and by any modes for the current buffer."
341 (do ((tables (list (buffer-variables *current-buffer*)
342 *global-variable-names*)
343 (cons (hi::mode-object-variables (car mode)) tables))
344 (mode (buffer-mode-objects *current-buffer*) (cdr mode)))
345 ((null mode) tables)))
346
347 (defun keyword-verification-function (string)
348 (declare (simple-string string))
349 (multiple-value-bind
350 (prefix key value field ambig)
351 (complete-string string *parse-string-tables*)
352 (declare (ignore field))
353 (cond (*parse-value-must-exist*
354 (ecase key
355 (:none nil)
356 ((:unique :complete)
357 (list prefix value))
358 (:ambiguous
359 (delete-region *parse-input-region*)
360 (insert-string (region-start *parse-input-region*) prefix)
361 (let ((point (current-point)))
362 (move-mark point (region-start *parse-input-region*))
363 (unless (character-offset point ambig)
364 (buffer-end point)))
365 nil)))
366 (t
367 ;; HACK: If it doesn't have to exist, and the completion does not
368 ;; add anything, then return the completion's capitalization,
369 ;; instead of the user's input.
370 (list (if (= (length string) (length prefix)) prefix string))))))
371
372
373
374 ;;;; Integer, expression, and string prompting.
375
376 (defun prompt-for-integer (&key ((:must-exist *parse-value-must-exist*) t)
377 default
378 ((:default-string *parse-default-string*))
379 ((:prompt *parse-prompt*) "Integer: ")
380 ((:help *parse-help*) "Type an integer."))
381 "Prompt for an integer. If :must-exist is Nil, then we return as a string
382 whatever was input if it is not a valid integer."
383 (let ((*parse-verification-function*
384 #'(lambda (string)
385 (let ((number (parse-integer string :junk-allowed t)))
386 (if *parse-value-must-exist*
387 (if number (list number))
388 (list (or number string))))))
389 (*parse-default* (if default (write-to-string default :base 10))))
390 (parse-for-something)))
391
392
393 (defvar hemlock-eof '(())
394 "An object that won't be EQ to anything read.")
395
396 (defun prompt-for-expression (&key ((:must-exist *parse-value-must-exist*) t)
397 (default nil defaultp)
398 ((:default-string *parse-default-string*))
399 ((:prompt *parse-prompt*) "Expression: ")
400 ((:help *parse-help*)
401 "Type a Lisp expression."))
402 "Prompts for a Lisp expression."
403 (let ((*parse-verification-function*
404 #'(lambda (string)
405 (let ((expr (with-input-from-region (stream *parse-input-region*)
406 (handler-case (read stream nil hemlock-eof)
407 (error () hemlock-eof)))))
408 (if *parse-value-must-exist*
409 (if (not (eq expr hemlock-eof)) (values (list expr) t))
410 (if (eq expr hemlock-eof)
411 (list string) (values (list expr) t))))))
412 (*parse-default* (if defaultp (prin1-to-string default))))
413 (parse-for-something)))
414
415
416 (defun prompt-for-string (&key ((:default *parse-default*))
417 ((:default-string *parse-default-string*))
418 (trim ())
419 ((:prompt *parse-prompt*) "String: ")
420 ((:help *parse-help*) "Type a string."))
421 "Prompts for a string. If :trim is t, then leading and trailing whitespace
422 is removed from input, otherwise it is interpreted as a Char-Bag argument
423 to String-Trim."
424 (let ((*parse-verification-function*
425 #'(lambda (string)
426 (list (string-trim (if (eq trim t) '(#\space #\tab) trim)
427 string)))))
428 (parse-for-something)))
429
430
431
432 ;;;; Yes-or-no and y-or-n prompting.
433
434 (defvar *yes-or-no-string-table*
435 (make-string-table :initial-contents '(("Yes" . t) ("No" . nil))))
436
437 (defun prompt-for-yes-or-no (&key ((:must-exist *parse-value-must-exist*) t)
438 (default nil defaultp)
439 ((:default-string *parse-default-string*))
440 ((:prompt *parse-prompt*) "Yes or No? ")
441 ((:help *parse-help*) "Type Yes or No."))
442 "Prompts for Yes or No."
443 (let* ((*parse-string-tables* (list *yes-or-no-string-table*))
444 (*parse-default* (if defaultp (if default "Yes" "No")))
445 (*parse-verification-function*
446 #'(lambda (string)
447 (multiple-value-bind
448 (prefix key value field ambig)
449 (complete-string string *parse-string-tables*)
450 (declare (ignore prefix field ambig))
451 (let ((won (or (eq key :complete) (eq key :unique))))
452 (if *parse-value-must-exist*
453 (if won (values (list value) t))
454 (list (if won (values value t) string)))))))
455 (*parse-type* :keyword))
456 (parse-for-something)))
457
458 (defun prompt-for-y-or-n (&key ((:must-exist must-exist) t)
459 (default nil defaultp)
460 default-string
461 ((:prompt prompt) "Y or N? ")
462 ((:help *parse-help*) "Type Y or N."))
463 "Prompts for Y or N."
464 (let ((old-window (current-window)))
465 (unwind-protect
466 (progn
467 (setf (current-window) *echo-area-window*)
468 (display-prompt-nicely prompt (or default-string
469 (if defaultp (if default "Y" "N"))))
470 (loop
471 (let ((key-event (get-key-event *editor-input*)))
472 (cond ((or (eq key-event #k"y")
473 (eq key-event #k"Y"))
474 (return t))
475 ((or (eq key-event #k"n")
476 (eq key-event #k"N"))
477 (return nil))
478 ((logical-key-event-p key-event :confirm)
479 (if defaultp
480 (return default)
481 (beep)))
482 ((logical-key-event-p key-event :help)
483 (ed::help-on-parse-command ()))
484 (t
485 (unless must-exist (return key-event))
486 (beep))))))
487 (setf (current-window) old-window))))
488
489
490
491 ;;;; Key-event and key prompting.
492
493 (defun prompt-for-key-event (&key (prompt "Key-event: ") (change-window t))
494 "Prompts for a key-event."
495 (prompt-for-key-event* prompt change-window))
496
497 (defun prompt-for-key-event* (prompt change-window)
498 (let ((old-window (current-window)))
499 (unwind-protect
500 (progn
501 (when change-window
502 (setf (current-window) *echo-area-window*))
503 (display-prompt-nicely prompt)
504 (get-key-event *editor-input* t))
505 (when change-window (setf (current-window) old-window)))))
506
507 (defvar *prompt-key* (make-array 10 :adjustable t :fill-pointer 0))
508 (defun prompt-for-key (&key ((:must-exist must-exist) t)
509 default default-string
510 (prompt "Key: ")
511 ((:help *parse-help*) "Type a key."))
512 (let ((old-window (current-window))
513 (string (if default
514 (or default-string
515 (let ((l (coerce default 'list)))
516 (format nil "~:C~{ ~:C~}" (car l) (cdr l)))))))
517
518 (unwind-protect
519 (progn
520 (setf (current-window) *echo-area-window*)
521 (display-prompt-nicely prompt string)
522 (setf (fill-pointer *prompt-key*) 0)
523 (prog ((key *prompt-key*) key-event)
524 (declare (vector key))
525 TOP
526 (setf key-event (get-key-event *editor-input*))
527 (cond ((logical-key-event-p key-event :quote)
528 (setf key-event (get-key-event *editor-input* t)))
529 ((logical-key-event-p key-event :confirm)
530 (cond ((and default (zerop (length key)))
531 (let ((res (get-command default :current)))
532 (unless (commandp res) (go FLAME))
533 (return (values default res))))
534 ((and (not must-exist) (plusp (length key)))
535 (return (copy-seq key)))
536 (t
537 (go FLAME))))
538 ((logical-key-event-p key-event :help)
539 (ed::help-on-parse-command ())
540 (go TOP)))
541 (vector-push-extend key-event key)
542 (when must-exist
543 (let ((res (get-command key :current)))
544 (cond ((commandp res)
545 (ext:print-pretty-key-event key-event
546 *echo-area-stream*
547 t)
548 (write-char #\space *echo-area-stream*)
549 (return (values (copy-seq key) res)))
550 ((not (eq res :prefix))
551 (vector-pop key)
552 (go FLAME)))))
553 (print-pretty-key key-event *echo-area-stream* t)
554 (write-char #\space *echo-area-stream*)
555 (go TOP)
556 FLAME
557 (beep)
558 (go TOP)))
559 (force-output *echo-area-stream*)
560 (setf (current-window) old-window))))
561
562
563
564 ;;;; Logical key-event stuff.
565
566 (defvar *logical-key-event-names* (make-string-table)
567 "This variable holds a string-table from logical-key-event names to the
568 corresponding keywords.")
569
570 (defvar *real-to-logical-key-events* (make-hash-table :test #'eql)
571 "A hashtable from real key-events to their corresponding logical
572 key-event keywords.")
573
574 (defvar *logical-key-event-descriptors* (make-hash-table :test #'eq)
575 "A hashtable from logical-key-events to logical-key-event-descriptors.")
576
577 (defstruct (logical-key-event-descriptor
578 (:constructor make-logical-key-event-descriptor ()))
579 name
580 key-events
581 documentation)
582
583 ;;; LOGICAL-KEY-EVENT-P -- Public
584 ;;;
585 (defun logical-key-event-p (key-event keyword)
586 "Return true if key-event has been defined to have Keyword as its
587 logical key-event. The relation between logical and real key-events
588 is defined by using SETF on LOGICAL-KEY-EVENT-P. If it is set to
589 true then calling LOGICAL-KEY-EVENT-P with the same key-event and
590 Keyword, will result in truth. Setting to false produces the opposite
591 result. See DEFINE-LOGICAL-KEY-EVENT and COMMAND-CASE."
592 (not (null (memq keyword (gethash key-event *real-to-logical-key-events*)))))
593
594 ;;; GET-LOGICAL-KEY-EVENT-DESC -- Internal
595 ;;;
596 ;;; Return the descriptor for the logical key-event keyword, or signal
597 ;;; an error if it isn't defined.
598 ;;;
599 (defun get-logical-key-event-desc (keyword)
600 (let ((res (gethash keyword *logical-key-event-descriptors*)))
601 (unless res
602 (error "~S is not a defined logical-key-event keyword." keyword))
603 res))
604
605 ;;; %SET-LOGICAL-KEY-EVENT-P -- Internal
606 ;;;
607 ;;; Add or remove a logical key-event link by adding to or deleting from
608 ;;; the list in the from-char hashtable and the descriptor.
609 ;;;
610 (defun %set-logical-key-event-p (key-event keyword new-value)
611 (let ((entry (get-logical-key-event-desc keyword)))
612 (cond
613 (new-value
614 (pushnew keyword (gethash key-event *real-to-logical-key-events*))
615 (pushnew key-event (logical-key-event-descriptor-key-events entry)))
616 (t
617 (setf (gethash key-event *real-to-logical-key-events*)
618 (delete keyword (gethash key-event *real-to-logical-key-events*)))
619 (setf (logical-key-event-descriptor-key-events entry)
620 (delete keyword (logical-key-event-descriptor-key-events entry))))))
621 new-value)
622
623 ;;; LOGICAL-KEY-EVENT-DOCUMENTATION, NAME, KEY-EVENTS -- Public
624 ;;;
625 ;;; Grab the right field out of the descriptor and return it.
626 ;;;
627 (defun logical-key-event-documentation (keyword)
628 "Return the documentation for the logical key-event Keyword."
629 (logical-key-event-descriptor-documentation
630 (get-logical-key-event-desc keyword)))
631 ;;;
632 (defun logical-key-event-name (keyword)
633 "Return the string name for the logical key-event Keyword."
634 (logical-key-event-descriptor-name (get-logical-key-event-desc keyword)))
635 ;;;
636 (defun logical-key-event-key-events (keyword)
637 "Return the list of key-events for which Keyword is the logical key-event."
638 (logical-key-event-descriptor-key-events
639 (get-logical-key-event-desc keyword)))
640
641 ;;; DEFINE-LOGICAL-KEY-EVENT -- Public
642 ;;;
643 ;;; Make the entries in the two hashtables and the string-table.
644 ;;;
645 (defun define-logical-key-event (name documentation)
646 "Define a logical key-event having the specified Name and Documentation.
647 See LOGICAL-KEY-EVENT-P and COMMAND-CASE."
648 (check-type name string)
649 (check-type documentation (or string function))
650 (let* ((keyword (string-to-keyword name))
651 (entry (or (gethash keyword *logical-key-event-descriptors*)
652 (setf (gethash keyword *logical-key-event-descriptors*)
653 (make-logical-key-event-descriptor)))))
654 (setf (logical-key-event-descriptor-name entry) name)
655 (setf (logical-key-event-descriptor-documentation entry) documentation)
656 (setf (getstring name *logical-key-event-names*) keyword)))
657
658
659
660 ;;;; Some standard logical-key-events:
661
662 (define-logical-key-event "Forward Search"
663 "This key-event is used to indicate that a forward search should be made.")
664 (define-logical-key-event "Backward Search"
665 "This key-event is used to indicate that a backward search should be made.")
666 (define-logical-key-event "Recursive Edit"
667 "This key-event indicates that a recursive edit should be entered.")
668 (define-logical-key-event "Cancel"
669 "This key-event is used to cancel a previous key-event of input.")
670 (define-logical-key-event "Abort"
671 "This key-event is used to abort the command in progress.")
672 (define-logical-key-event "Exit"
673 "This key-event is used to exit normally the command in progress.")
674 (define-logical-key-event "Yes"
675 "This key-event is used to indicate a positive response.")
676 (define-logical-key-event "No"
677 "This key-event is used to indicate a negative response.")
678 (define-logical-key-event "Do All"
679 "This key-event means do it as many times as you can.")
680 (define-logical-key-event "Do Once"
681 "This key-event means, do it this time, then exit.")
682 (define-logical-key-event "Help"
683 "This key-event is used to ask for help.")
684 (define-logical-key-event "Confirm"
685 "This key-event is used to confirm some choice.")
686 (define-logical-key-event "Quote"
687 "This key-event is used to quote the next key-event of input.")
688 (define-logical-key-event "Keep"
689 "This key-event means exit but keep something around.")
690
691
692
693 ;;;; COMMAND-CASE help message printing.
694
695 (defvar *my-string-output-stream* (make-string-output-stream))
696
697 (defun chars-to-string (chars)
698 (do ((s *my-string-output-stream*)
699 (chars chars (cdr chars)))
700 ((null chars)
701 (get-output-stream-string s))
702 (let ((char (car chars)))
703 (if (characterp char)
704 (write-char char s)
705 (do ((key-events
706 (logical-key-event-key-events char)
707 (cdr key-events)))
708 ((null key-events))
709 (ext:print-pretty-key (car key-events) s)
710 (unless (null (cdr key-events))
711 (write-string ", " s))))
712 (unless (null (cdr chars))
713 (write-string ", " s)))))
714
715 ;;; COMMAND-CASE-HELP -- Internal
716 ;;;
717 ;;; Print out a help message derived from the options in a
718 ;;; random-typeout window.
719 ;;;
720 (defun command-case-help (help options)
721 (let ((help (if (listp help)
722 (apply #'format nil help) help)))
723 (with-pop-up-display (s)
724 (write-string help s)
725 (fresh-line s)
726 (do ((o options (cdr o)))
727 ((null o))
728 (let ((string (chars-to-string (caar o))))
729 (declare (simple-string string))
730 (if (= (length string) 1)
731 (write-char (char string 0) s)
732 (write-line string s))
733 (write-string " - " s)
734 (write-line (cdar o) s))))))

  ViewVC Help
Powered by ViewVC 1.1.5