source: tags/pre_1_0_pre_hash_modifications/ccl/hemlock/src/echo.lisp @ 2475

Last change on this file since 2475 was 2475, checked in by anonymous, 14 years ago

This commit was manufactured by cvs2svn to create tag
'pre_1_0_pre_hash_modifications'.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 25.2 KB
Line 
1;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*-
2;;;
3;;; **********************************************************************
4;;; This code was written as part of the CMU Common Lisp project at
5;;; Carnegie Mellon University, and has been placed in the public domain.
6;;;
7#+CMU (ext:file-comment
8  "$Header$")
9;;;
10;;; **********************************************************************
11;;;
12;;; Hemlock Echo Area stuff.
13;;; Written by Skef Wholey and Rob MacLachlan.
14;;; Modified by Bill Chiles.
15;;;
16(in-package :hemlock-internals)
17
18(defmode "Echo Area" :major-p t)
19(defvar *echo-area-buffer* (make-buffer "Echo Area" :modes '("Echo Area"))
20  "Buffer used to hack text for the echo area.")
21(defvar *echo-area-region* (buffer-region *echo-area-buffer*)
22  "Internal thing that's the *echo-area-buffer*'s region.")
23(defvar *echo-area-stream*
24  (make-hemlock-output-stream (region-end *echo-area-region*) :full)
25  "Buffered stream that prints into the echo area.")
26(defvar *echo-area-window* ()
27  "Window used to display stuff in the echo area.")
28(defvar *parse-starting-mark*
29  (copy-mark (buffer-point *echo-area-buffer*) :right-inserting)
30  "Mark that points to the beginning of the text that'll be parsed.")
31(defvar *parse-input-region*
32  (region *parse-starting-mark* (region-end *echo-area-region*))
33  "Region that contains the text typed in.")
34
35
36
37;;;; Variables that control parsing:
38
39(defvar *parse-verification-function* '%not-inside-a-parse
40  "Function that verifies what's being parsed.")
41
42;;; %Not-Inside-A-Parse  --  Internal
43;;;
44;;;    This function is called if someone does stuff in the echo area when
45;;; we aren't inside a parse.  It tries to put them back in a reasonable place.
46;;;
47(defun %not-inside-a-parse (quaz)
48  "Thing that's called when somehow we get called to confirm a parse that's
49  not in progress."
50  (declare (ignore quaz))
51  (let* ((bufs (remove *echo-area-buffer* *buffer-list*))
52         (buf (or (find-if #'buffer-windows bufs)
53                  (car bufs)
54                  (make-buffer "Main"))))
55    (setf (current-buffer) buf)
56    (dolist (w *window-list*)
57      (when (and (eq (window-buffer w) *echo-area-buffer*)
58                 (not (eq w *echo-area-window*)))
59        (setf (window-buffer w) buf)))
60    (setf (current-window)
61          (or (car (buffer-windows buf))
62              (make-window (buffer-start-mark buf)))))
63  (editor-error "Wham!  We tried to confirm a parse that wasn't in progress?"))
64
65(defvar *parse-string-tables* ()
66  "String tables being used in the current parse.")
67
68(defvar *parse-value-must-exist* ()
69  "You know.")
70
71(defvar *parse-default* ()
72  "When the user attempts to default a parse, we call the verification function
73  on this string.  This is not the :Default argument to the prompting function,
74  but rather a string representation of it.")
75
76(defvar *parse-default-string* ()
77  "String that we show the user to inform him of the default.  If this
78  is NIL then we just use *Parse-Default*.")
79
80(defvar *parse-prompt* ()
81  "Prompt for the current parse.")
82
83(defvar *parse-help* ()
84  "Help string for the current parse.")
85
86(defvar *parse-type* :string "A hack. :String, :File or :Keyword.") 
87
88
89
90;;;; MESSAGE and CLEAR-ECHO-AREA:
91
92(defhvar "Message Pause" "The number of seconds to pause after a Message."
93  :value 0.5s0)
94
95(defvar *last-message-time* 0
96  "Internal-Real-Time the last time we displayed a message.") 
97
98(defun maybe-wait ()
99  (let* ((now (get-internal-real-time))
100         (delta (/ (float (- now *last-message-time*))
101                   (float internal-time-units-per-second)))
102         (pause (value hemlock::message-pause)))
103    (when (< delta pause)
104      (sleep (- pause delta)))))
105
106(defun clear-echo-area ()
107  "You guessed it."
108  (maybe-wait)
109  (let* ((b (current-buffer)))
110    (unwind-protect
111         (progn
112           (setf (current-buffer) *echo-area-buffer*)
113           (delete-region *echo-area-region*)
114           (setf (buffer-modified *echo-area-buffer*) nil))
115      (setf (current-buffer) b))))
116
117;;; Message  --  Public
118;;;
119;;;    Display the stuff on *echo-area-stream* and then wait.  Editor-Sleep
120;;; will do a redisplay if appropriate.
121;;;
122(defun message (string &rest args)
123  "Nicely display a message in the echo-area.
124  Put the message on a fresh line and wait for \"Message Pause\" seconds
125  to give the luser a chance to see it.  String and Args are a format
126  control string and format arguments, respectively."
127  (maybe-wait)
128  (cond ((eq *current-window* *echo-area-window*)
129         (let ((point (buffer-point *echo-area-buffer*)))
130           (with-mark ((m point :left-inserting))
131             (line-start m)
132             (with-output-to-mark (s m :full)
133               (apply #'format s string args)
134               (fresh-line s)))))
135        (t
136         (let ((mark (region-end *echo-area-region*)))
137           (cond ((buffer-modified *echo-area-buffer*)
138                  (clear-echo-area))
139                 ((not (zerop (mark-charpos mark)))
140                  (insert-character mark #\newline)
141                  (clear-echo-area)))
142           (apply #'format *echo-area-stream* string args)
143           (setf (buffer-modified *echo-area-buffer*) nil))))
144  (force-output *echo-area-stream*)
145  (setq *last-message-time* (get-internal-real-time))
146  nil)
147
148
149;;; LOUD-MESSAGE -- Public.
150;;;
151;;; Like message, only more provocative.
152;;;
153(defun loud-message (&rest args)
154  "This is the same as MESSAGE, but it beeps and clears the echo area before
155   doing anything else."
156  (beep)
157  (clear-echo-area)
158  (apply #'message args))
159
160
161(defhvar "Raise Echo Area When Modified"
162  "When set, Hemlock raises the echo area window when output appears there."
163  :value nil)
164
165;;; RAISE-ECHO-AREA-WHEN-MODIFIED -- Internal.
166;;;
167;;; INIT-BITMAP-SCREEN-MANAGER in bit-screen.lisp adds this hook when
168;;; initializing the bitmap screen manager.
169;;;
170#+clx
171(defun raise-echo-area-when-modified (buffer modified)
172  (when (and (value hemlock::raise-echo-area-when-modified)
173             (eq buffer *echo-area-buffer*)
174             modified)
175    (let* ((hunk (window-hunk *echo-area-window*))
176           (win (window-group-xparent (bitmap-hunk-window-group hunk))))
177      (xlib:map-window win)
178      (setf (xlib:window-priority win) :above)
179      (xlib:display-force-output
180       (bitmap-device-display (device-hunk-device hunk))))))
181
182
183
184;;;; DISPLAY-PROMPT-NICELY and PARSE-FOR-SOMETHING.
185
186(defun display-prompt-nicely (&optional (prompt *parse-prompt*)
187                                        (default (or *parse-default-string*
188                                                     *parse-default*)))
189  (clear-echo-area)
190  (let ((point (buffer-point *echo-area-buffer*)))
191    (if (listp prompt)
192        (apply #'format *echo-area-stream* prompt)
193        (insert-string point prompt))
194    (when default
195      (insert-character point #\[)
196      (insert-string point default)
197      (insert-string point "] "))))
198
199(defun parse-for-something ()
200  (display-prompt-nicely)
201  (let ((start-window (current-window)))
202    (move-mark *parse-starting-mark* (buffer-point *echo-area-buffer*))
203    (setf (current-window) *echo-area-window*)
204    (unwind-protect
205     (use-buffer *echo-area-buffer*
206       (recursive-edit nil))
207     (setf (current-window) start-window))))
208
209
210
211;;;; Buffer prompting.
212
213(defun prompt-for-buffer (&key ((:must-exist *parse-value-must-exist*) t)
214                               default
215                               ((:default-string *parse-default-string*))
216                               ((:prompt *parse-prompt*) "Buffer: ")
217                               ((:help *parse-help*) "Type a buffer name."))
218  "Prompts for a buffer name and returns the corresponding buffer.  If
219   :must-exist is nil, then return the input string.  This refuses to accept
220   the empty string as input when no default is supplied.  :default-string
221   may be used to supply a default buffer name even when :default is nil, but
222   when :must-exist is non-nil, :default-string must be the name of an existing
223   buffer."
224    (let ((*parse-string-tables* (list *buffer-names*))
225          (*parse-type* :keyword)
226          (*parse-default* (cond
227                            (default (buffer-name default))
228                            (*parse-default-string*
229                             (when (and *parse-value-must-exist*
230                                        (not (getstring *parse-default-string*
231                                                        *buffer-names*)))
232                               (error "Default-string must name an existing ~
233                                       buffer when must-exist is non-nil -- ~S."
234                                      *parse-default-string*))
235                             *parse-default-string*)
236                            (t nil)))
237          (*parse-verification-function* #'buffer-verification-function))
238      (parse-for-something)))
239
240(defun buffer-verification-function (string)
241  (declare (simple-string string))
242  (cond ((string= string "") nil)
243        (*parse-value-must-exist*
244         (multiple-value-bind
245             (prefix key value field ambig)
246             (complete-string string *parse-string-tables*)
247           (declare (ignore field))
248           (ecase key
249             (:none nil)
250             ((:unique :complete)
251              (list value))
252             (:ambiguous
253              (delete-region *parse-input-region*)
254              (insert-string (region-start *parse-input-region*) prefix)
255              (let ((point (current-point)))
256                (move-mark point (region-start *parse-input-region*))
257                (unless (character-offset point ambig)
258                  (buffer-end point)))
259              nil))))
260        (t
261         (list (or (getstring string *buffer-names*) string)))))
262
263
264
265;;;; File Prompting.
266
267(defun prompt-for-file (&key ((:must-exist *parse-value-must-exist*) t)
268                             default
269                             ((:default-string *parse-default-string*))
270                             ((:prompt *parse-prompt*) "Filename: ")
271                             ((:help *parse-help*) "Type a file name."))
272  "Prompts for a filename."
273  (let ((*parse-verification-function* #'file-verification-function)
274        (*parse-default* (if default (namestring default)))
275        (*parse-type* :file))
276    (parse-for-something)))
277
278(defun file-verification-function (string)
279  (let ((pn (pathname-or-lose string)))
280    (if pn
281        (let ((merge
282               (cond ((not *parse-default*) nil)
283                     ((directoryp pn)
284                      (merge-pathnames pn *parse-default*))
285                     (t
286                      (merge-pathnames pn
287                                       (or (directory-namestring
288                                            *parse-default*)
289                                           ""))))))
290          (cond ((probe-file pn) (list pn))
291                ((and merge (probe-file merge)) (list merge))
292                ((not *parse-value-must-exist*) (list (or merge pn)))
293                (t nil))))))
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 (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                     (hemlock::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                       (hemlock::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                           (hemlock-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                (hemlock-ext: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 (member 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            (hemlock-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))))))
Note: See TracBrowser for help on using the repository browser.