source: branches/event-ide/ccl/cocoa-ide/hemlock/src/echo.lisp @ 8062

Last change on this file since 8062 was 8062, checked in by gz, 13 years ago

Get rid of the variable "winding" scheme (which used to swap the
current buffer's variable bindings into symbol plists), simplify
variable and mode handing.

Fix a shadow attribute caching bug.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 26.5 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;;; Totally rewritten for Clozure CL.
17
18(in-package :hemlock-internals)
19
20(defmacro modifying-echo-buffer (&body body)
21  `(modifying-buffer-storage ((hemlock-echo-area-buffer *current-view*))
22     ,@body))
23
24;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
25;;;;
26;;;; Echo area output.
27
28(defvar *last-message-time* (get-internal-real-time))
29
30(defun clear-echo-area ()
31  "You guessed it."
32  (modifying-echo-buffer
33   (delete-region (buffer-region *current-buffer*))))
34
35;;; Message  --  Public
36;;;
37;;;    Display the stuff on *echo-area-stream*
38;;;
39(defun message (string &rest args)
40  "Nicely display a message in the echo-area.
41  String and Args are a format control string and format arguments, respectively."
42  ;; TODO: used to do something cleverish if in the middle of reading prompted input, might
43  ;; want to address that.
44  (if *current-view*
45    (let ((message (apply #'format nil string args)))
46      (modifying-echo-buffer
47       (delete-region (buffer-region *current-buffer*))
48       (insert-string (buffer-point *current-buffer*) message)
49       (setq *last-message-time* (get-internal-real-time))
50       ))
51    ;; For some reason this crashes.  Perhaps something is too aggressive about
52    ;; catching conditions in events??
53    #+not-yet(apply #'warn string args)
54    #-not-yet (apply #'format t string args)))
55
56;;; LOUD-MESSAGE -- Public.
57;;;
58;;; Like message, only more provocative.
59;;;
60(defun loud-message (&rest args)
61  "This is the same as MESSAGE, but it beeps and clears the echo area before
62   doing anything else."
63  (beep)
64  (apply #'message args))
65
66;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
67;;
68;; Echo area input
69
70(defmode "Echo Area" :major-p t)
71
72(defstruct (echo-parse-state (:conc-name "EPS-"))
73  (parse-verification-function nil)
74  (parse-string-tables ())
75  (parse-value-must-exist ())
76  ;; When the user attempts to default a parse, we call the verification function
77  ;; on this string.  This is not the :Default argument to the prompting function,
78  ;; but rather a string representation of it.
79  (parse-default ())
80  ;; String that we show the user to inform him of the default.  If this
81  ;; is NIL then we just use Parse-Default.
82  (parse-default-string ())
83  ;; Prompt for the current parse.
84  (parse-prompt ())
85  ;; Help string for the current parse.
86  (parse-help ())
87  ;; :String, :File or :Keyword.
88  (parse-type :string)
89  ;; input region
90  parse-starting-mark
91  parse-input-region
92  ;; key handler, nil to use the standard one
93  (parse-key-handler nil)
94  ;; Store result here
95  (parse-results ()))
96
97(defun current-echo-parse-state (&key (must-exist t))
98  (or (hemlock-prompted-input-state *current-view*)
99      (and must-exist (error "Can't do that when not in echo area input"))))
100
101
102;;;; DISPLAY-PROMPT-NICELY and PARSE-FOR-SOMETHING.
103
104(defun display-prompt-nicely (eps &optional (prompt (eps-parse-prompt eps))
105                                            (default (or (eps-parse-default-string eps)
106                                                         (eps-parse-default eps))))
107  (modifying-echo-buffer 
108   (let* ((buffer *current-buffer*)
109          (point (buffer-point buffer)))
110     (delete-region (buffer-region buffer))
111     (insert-string point (if (listp prompt)
112                            (apply #'format nil prompt)
113                            prompt))
114     (when default
115       (insert-character point #\[)
116       (insert-string point default)
117       (insert-string point "] "))
118     (move-mark (eps-parse-starting-mark eps) point))))
119
120;; This is used to prevent multiple buffers trying to do echo area input
121;; at the same time - there would be no way to exit the earlier one
122;; without exiting the later one, because they're both on the same stack.
123(defvar *recursive-edit-view* nil)
124
125(defun parse-for-something (&key verification-function
126                                 type
127                                 string-tables
128                                 value-must-exist
129                                 default-string
130                                 default
131                                 prompt
132                                 help
133                                 key-handler)
134  ;; We can't do a "recursive" edit in more than one view, because if the earlier
135  ;; one wants to exit first, we'd have to unwind the stack to allow it to exit,
136  ;; which would force the later one to exit whether it wants to or not.
137  (when (and *recursive-edit-view* (not (eq *recursive-edit-view* *current-view*)))
138    (editor-error "~s is already waiting for input"
139                  (buffer-name (hemlock-view-buffer *recursive-edit-view*))))
140  (modifying-echo-buffer
141   (let* ((view *current-view*)
142          (buffer *current-buffer*)
143          (old-eps (hemlock-prompted-input-state view))
144          (parse-mark (copy-mark (buffer-point buffer) :right-inserting))
145          (end-mark (buffer-end-mark buffer))
146          (eps (make-echo-parse-state
147                :parse-starting-mark parse-mark
148                :parse-input-region (region parse-mark end-mark)
149                :parse-verification-function verification-function
150                :parse-type type
151                :parse-string-tables string-tables
152                :parse-value-must-exist value-must-exist
153                :parse-default-string default-string
154                :parse-default default
155                :parse-prompt prompt
156                :parse-help help
157                :parse-key-handler key-handler)))
158     ;; TODO: There is really no good reason to disallow recursive edits in the same
159     ;; buffer, I'm just too lazy.  Should save contents, starting mark, and point,
160     ;; and restore them at the end.
161     (when old-eps
162       (editor-error "Attempt to recursively use echo area"))
163     (display-prompt-nicely eps)
164     (modifying-buffer-storage (nil)
165       (unwind-protect
166            (let ((*recursive-edit-view* view))
167              (setf (hemlock-prompted-input-state view) eps)
168              (unless old-eps
169                (hemlock-ext:change-active-pane view :echo))
170              (with-standard-standard-output
171                  (gui::event-loop #'(lambda () (eps-parse-results eps))))
172              #+gz (log-debug "~&Event loop exited!, results = ~s" (eps-parse-results eps)))
173         (unless old-eps
174           (hemlock-ext:change-active-pane view :text))
175         (setf (hemlock-prompted-input-state view) old-eps)
176         (delete-mark parse-mark)))
177     (let ((results (eps-parse-results eps)))
178       (if (listp results)
179         (apply #'values results)
180         (abort-to-toplevel))))))
181
182(defun exit-echo-parse (eps results)
183  #+gz (log-debug "~&exit echo parse, results = ~s" results)
184  ;; Must be set to non-nil to indicate parse done.
185  (setf (eps-parse-results eps) (or results '(nil)))
186  (gui::stop-event-loop) ;; this just marks it for dead then returns.
187  ;; this exits current event, and since the event loop is stopped, it
188  ;; will exit the event loop, which will return to parse-for-something,
189  ;; which will notice we have the result set and will handle it accordingly.
190  (exit-event-handler))
191
192;;;; Buffer prompting.
193
194(defun prompt-for-buffer (&key (must-exist t)
195                                default
196                                default-string
197                               (prompt "Buffer: ")
198                               (help "Type a buffer name."))
199  "Prompts for a buffer name and returns the corresponding buffer.  If
200   :must-exist is nil, then return the input string.  This refuses to accept
201   the empty string as input when no default is supplied.  :default-string
202   may be used to supply a default buffer name even when :default is nil, but
203   when :must-exist is non-nil, :default-string must be the name of an existing
204   buffer."
205  (when (and must-exist
206             (not default)
207             (not (getstring default-string *buffer-names*)))
208    (error "Default-string must name an existing buffer when must-exist is non-nil -- ~S."
209           default-string))
210  (parse-for-something
211   :verification-function #'buffer-verification-function
212   :type :keyword
213   :string-tables (list *buffer-names*)
214   :value-must-exist must-exist
215   :default-string default-string
216   :default (if default (buffer-name default) default-string)
217   :prompt prompt
218   :help help))
219
220(defun buffer-verification-function (eps string)
221  (declare (simple-string string))
222  (modifying-echo-buffer
223   (cond ((string= string "") nil)
224         ((eps-parse-value-must-exist eps)
225          (multiple-value-bind
226              (prefix key value field ambig)
227              (complete-string string (eps-parse-string-tables eps))
228            (declare (ignore field))
229            (ecase key
230              (:none nil)
231              ((:unique :complete)
232               (list value))
233              (:ambiguous
234               (let ((input-region (eps-parse-input-region eps)))
235                 (delete-region input-region)
236                 (insert-string (region-start input-region) prefix)
237                 (let ((point (current-point)))
238                   (move-mark point (region-start input-region))
239                   (unless (character-offset point ambig)
240                     (buffer-end point)))
241                 nil)))))
242         (t
243          (list (or (getstring string *buffer-names*) string))))))
244
245
246
247;;;; File Prompting.
248
249(defun prompt-for-file (&key (must-exist t)
250                             default
251                             default-string
252                             (prompt "Filename: ")
253                             (help "Type a file name."))
254  "Prompts for a filename."
255  (parse-for-something
256   :verification-function #'file-verification-function
257   :type :file
258   :string-tables nil
259   :value-must-exist must-exist
260   :default-string default-string
261   :default (if default (namestring default))
262   :prompt prompt
263   :help help))
264
265(defun file-verification-function (eps string)
266  (let ((pn (pathname-or-lose eps string)))
267    (if pn
268        (let ((merge
269               (cond ((not (eps-parse-default eps)) nil)
270                     ((directoryp pn)
271                      (merge-pathnames pn (eps-parse-default eps)))
272                     (t
273                      (merge-pathnames pn
274                                       (or (directory-namestring
275                                            (eps-parse-default eps))
276                                           ""))))))
277          (cond ((probe-file pn) (list pn))
278                ((and merge (probe-file merge)) (list merge))
279                ((not (eps-parse-value-must-exist eps)) (list (or merge pn)))
280                (t nil))))))
281
282;;; PATHNAME-OR-LOSE tries to convert string to a pathname using
283;;; PARSE-NAMESTRING.  If it succeeds, this returns the pathname.  Otherwise,
284;;; this deletes the offending characters from *parse-input-region* and signals
285;;; an editor-error.
286;;;
287(defun pathname-or-lose (eps string)
288  (multiple-value-bind (pn idx)
289                       (parse-namestring string nil *default-pathname-defaults*
290                                         :junk-allowed t)
291    (cond (pn)
292          (t (modifying-echo-buffer
293              (delete-characters (region-end (eps-parse-input-region eps))
294                                 (- idx (length string))))
295             nil))))
296
297
298
299;;;; Keyword and variable prompting.
300
301(defun prompt-for-keyword (&key
302                           tables
303                           (must-exist t)
304                           default
305                           default-string
306                           (prompt "Keyword: ")
307                           (help "Type a keyword."))
308  "Prompts for a keyword using the String Tables."
309  (parse-for-something
310   :verification-function #'keyword-verification-function
311   :type :keyword
312   :string-tables tables
313   :value-must-exist must-exist
314   :default-string default-string
315   :default default
316   :prompt prompt
317   :help help))
318
319
320
321(defun prompt-for-variable (&key (must-exist t)
322                                 default
323                                 default-string
324                                 (prompt "Variable: ")
325                                 (help "Type the name of a variable."))
326  "Prompts for a variable defined in the current scheme of things."
327  (parse-for-something
328   :verification-function  #'keyword-verification-function
329   :type :keyword
330   :string-tables (current-variable-tables)
331   :value-must-exist must-exist
332   :default-string default-string
333   :default default
334   :prompt prompt
335   :help help))
336
337(defun current-variable-tables ()
338  "Returns a list of all the variable tables currently established globally,
339   by the current buffer, and by any modes for the current buffer."
340  (nconc (list (buffer-variables *current-buffer*))
341         (mapcar #'mode-object-variables (buffer-minor-mode-objects *current-buffer*))
342         (list (mode-object-variables (buffer-major-mode-object *current-buffer*)))
343         (list *global-variable-names*)))
344
345(defun keyword-verification-function (eps string)
346  (declare (simple-string string))
347  (multiple-value-bind
348      (prefix key value field ambig)
349      (complete-string string (eps-parse-string-tables eps))
350    (declare (ignore field))
351    (modifying-echo-buffer
352     (cond ((eps-parse-value-must-exist eps)
353            (ecase key
354              (:none nil)
355              ((:unique :complete)
356               (list prefix value))
357              (:ambiguous
358               (let ((input-region (eps-parse-input-region eps)))
359                 (delete-region input-region)
360                 (insert-string (region-start input-region) prefix)
361                 (let ((point (current-point)))
362                   (move-mark point (region-start 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 t)
377                                default
378                                default-string
379                                (prompt "Integer: ")
380                                (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
384  (parse-for-something
385   :verification-function #'(lambda (eps string)
386                              (let ((number (parse-integer string  :junk-allowed t)))
387                                (if (eps-parse-value-must-exist eps)
388                                  (if number (list number))
389                                  (list (or number string)))))
390   :type :string
391   :string-tables nil
392   :value-must-exist must-exist
393   :default-string default-string
394   :default (if default (write-to-string default :base 10))
395   :prompt prompt
396   :help help))
397
398
399(defvar hemlock-eof '(())
400  "An object that won't be EQ to anything read.")
401
402(defun prompt-for-expression (&key (must-exist t)
403                                   (default nil defaultp)
404                                   default-string
405                                   (prompt "Expression: ")
406                                   (help "Type a Lisp expression."))
407  "Prompts for a Lisp expression."
408  (parse-for-something
409   :verification-function #'(lambda (eps string)
410                              (let* ((input-region (eps-parse-input-region eps))
411                                     (expr (with-input-from-region (stream input-region)
412                                             (handler-case (read stream nil hemlock-eof)
413                                               (error () hemlock-eof)))))
414                                (if (eq expr hemlock-eof)
415                                  (unless (eps-parse-value-must-exist eps) (list string))
416                                  (values (list expr) t))))
417   :type :string
418   :string-tables nil
419   :value-must-exist must-exist
420   :default-string default-string
421   :default (if defaultp (prin1-to-string default))
422   :prompt prompt
423   :help help))
424
425
426(defun prompt-for-string (&key default
427                               default-string
428                               (trim ())
429                               (prompt "String: ")
430                               (help "Type a string."))
431  "Prompts for a string.  If :trim is t, then leading and trailing whitespace
432   is removed from input, otherwise it is interpreted as a Char-Bag argument
433   to String-Trim."
434  (when (eq trim t) (setq trim '(#\space #\tab)))
435  (parse-for-something
436   :verification-function #'(lambda (eps string)
437                              (declare (ignore eps))
438                              (list (string-trim trim string)))
439   :type :string
440   :string-tables nil
441   :value-must-exist nil
442   :default-string default-string
443   :default default
444   :prompt prompt
445   :help help))
446
447
448;;;; Package names.
449(defun make-package-string-table ()
450  (let ((names ()))
451    (dolist (p (list-all-packages))
452      (let* ((name (package-name p)))
453        (push (cons name name) names)
454        (dolist (nick (package-nicknames p))
455          (push (cons nick name) names))))
456    (make-string-table :initial-contents names)))
457
458#||
459(defun prompt-for-package (&key (must-exist t)
460                                (default nil defaultp)
461                                default-string
462                                (prompt "Package Name:")
463                                (help "Type a package name."))
464)
465||#
466
467
468;;;; Yes-or-no and y-or-n prompting.
469
470(defvar *yes-or-no-string-table*
471  (make-string-table :initial-contents '(("Yes" . t) ("No" . nil))))
472
473(defun prompt-for-yes-or-no (&key (must-exist t)
474                                  (default nil defaultp)
475                                  default-string
476                                  (prompt "Yes or No? ")
477                                  (help "Type Yes or No."))
478  "Prompts for Yes or No."
479  (parse-for-something
480   :verification-function #'(lambda (eps string)
481                              (multiple-value-bind
482                                  (prefix key value field ambig)
483                                  (complete-string string (eps-parse-string-tables eps))
484                                (declare (ignore prefix field ambig))
485                                (let ((won (or (eq key :complete) (eq key :unique))))
486                                  (if (eps-parse-value-must-exist eps)
487                                    (if won (values (list value) t))
488                                    (list (if won (values value t) string))))))
489   :type :keyword
490   :string-tables (list *yes-or-no-string-table*)
491   :value-must-exist must-exist
492   :default-string default-string
493   :default (if defaultp (if default "Yes" "No"))
494   :prompt prompt
495   :help help))
496
497(defun prompt-for-y-or-n (&key (must-exist t)
498                               (default nil defaultp)
499                               default-string
500                               (prompt "Y or N? ")
501                               (help "Type Y or N."))
502  "Prompts for Y or N."
503  (parse-for-something
504   :verification-function #'(lambda (eps key-event)
505                              (cond ((logical-key-event-p key-event :y)
506                                     (values (list t) t))
507                                    ((logical-key-event-p key-event :n)
508                                     (values (list nil) t))
509                                    ((and (eps-parse-default eps)
510                                          (logical-key-event-p key-event :confirm))
511                                     (values (list (equalp (eps-parse-default eps) "y")) t))
512                                    ((logical-key-event-p key-event :abort)
513                                     :abort)
514                                    ((logical-key-event-p key-event :help)
515                                     :help)
516                                    (t
517                                     (if (eps-parse-value-must-exist eps)
518                                       :error
519                                       (values (list key-event) t)))))
520   :type :key
521   :value-must-exist must-exist
522   :default-string default-string
523   :default (and defaultp (if default "Y" "N"))
524   :prompt prompt
525   :help help
526   :key-handler (getstring "Key Input Handler" *command-names*)))
527
528
529
530;;;; Key-event and key prompting.
531
532(defun prompt-for-key-event (&key (prompt "Key-event: ")
533                                  (help "Type any key"))
534  "Prompts for a key-event."
535  (parse-for-something
536   :verification-function #'(lambda (eps key-event)
537                              (declare (ignore eps))
538                              (values (list key-event) t))
539   :type :key
540   :prompt prompt
541   :help help
542   :key-handler (getstring "Key Input Handler" *command-names*)))
543
544(defun verify-key (eps key-event key quote-p)
545  ;; This is called with the echo buffer as the current buffer.  We want to look
546  ;; up the commands in the main buffer.
547  (let* ((buffer (hemlock-view-buffer (current-view)))
548         (n (length key)))
549    (block nil
550      (unless quote-p
551        (cond ((logical-key-event-p key-event :help)
552               (return :help))
553              ((logical-key-event-p key-event :abort)
554               (return :abort))
555              ((and (not (eps-parse-value-must-exist eps))
556                    (logical-key-event-p key-event :confirm))
557               (return
558                 (cond ((eql n 0)
559                        (let ((key (eps-parse-default eps))
560                              (cmd (and key (let ((*current-buffer* buffer))
561                                              (get-command key :current)))))
562                          (if (commandp cmd)
563                            (values (list key cmd) :confirmed)
564                            :error)))
565                       ((> n 0)
566                        (values (list key nil) :confirmed))
567                       (t :error))))))
568      (vector-push-extend key-event key)
569      (let ((cmd (if (eps-parse-value-must-exist eps)
570                   (let ((*current-buffer* buffer)) (get-command key :current))
571                   :prefix)))
572        (cond ((commandp cmd)
573               (values (list key cmd) t))
574              ((eq cmd :prefix)
575               nil)
576              (t
577               (vector-pop key)
578               :error))))))
579
580(defun prompt-for-key (&key (prompt "Key: ")
581                            (help "Type a key.")
582                            default default-string
583                            (must-exist t))
584  (parse-for-something
585   :verification-function (let ((key (make-array 10 :adjustable t :fill-pointer 0))
586                                (quote-p nil))
587                            #'(lambda (eps key-event)
588                                (if (and (not quote-p) (logical-key-event-p key-event :quote))
589                                  (progn
590                                    (setq quote-p t)
591                                    (values :ignore nil))
592                                  (verify-key eps key-event key (shiftf quote-p nil)))))
593   :type :command
594   :prompt prompt
595   :help help
596   :value-must-exist must-exist
597   :default default
598   :default-string default-string
599   :key-handler (getstring "Key Input Handler" *command-names*)))
600
601
602;;;; Logical key-event stuff.
603
604(defvar *logical-key-event-names* (make-string-table)
605  "This variable holds a string-table from logical-key-event names to the
606   corresponding keywords.")
607
608(defvar *real-to-logical-key-events* (make-hash-table :test #'eql)
609  "A hashtable from real key-events to their corresponding logical
610   key-event keywords.")
611
612(defvar *logical-key-event-descriptors* (make-hash-table :test #'eq)
613  "A hashtable from logical-key-events to logical-key-event-descriptors.")
614
615(defstruct (logical-key-event-descriptor
616            (:constructor make-logical-key-event-descriptor ()))
617  name
618  key-events
619  documentation)
620
621;;; LOGICAL-KEY-EVENT-P  --  Public
622;;;
623(defun logical-key-event-p (key-event keyword)
624  "Return true if key-event has been defined to have Keyword as its
625   logical key-event.  The relation between logical and real key-events
626   is defined by using SETF on LOGICAL-KEY-EVENT-P.  If it is set to
627   true then calling LOGICAL-KEY-EVENT-P with the same key-event and
628   Keyword, will result in truth.  Setting to false produces the opposite
629   result.  See DEFINE-LOGICAL-KEY-EVENT and COMMAND-CASE."
630  (not (null (member keyword (gethash key-event *real-to-logical-key-events*)))))
631
632;;; GET-LOGICAL-KEY-EVENT-DESC  --  Internal
633;;;
634;;;    Return the descriptor for the logical key-event keyword, or signal
635;;; an error if it isn't defined.
636;;;
637(defun get-logical-key-event-desc (keyword)
638  (let ((res (gethash keyword *logical-key-event-descriptors*)))
639    (unless res
640      (error "~S is not a defined logical-key-event keyword." keyword))
641    res))
642
643;;; %SET-LOGICAL-KEY-EVENT-P  --  Internal
644;;;
645;;;    Add or remove a logical key-event link by adding to or deleting from
646;;; the list in the from-char hashtable and the descriptor.
647;;;
648(defun %set-logical-key-event-p (key-event keyword new-value)
649  (let ((entry (get-logical-key-event-desc keyword)))
650    (cond
651     (new-value
652      (pushnew keyword (gethash key-event *real-to-logical-key-events*))
653      (pushnew key-event (logical-key-event-descriptor-key-events entry)))
654     (t
655      (setf (gethash key-event *real-to-logical-key-events*)
656            (delete keyword (gethash key-event *real-to-logical-key-events*)))
657      (setf (logical-key-event-descriptor-key-events entry)
658            (delete keyword (logical-key-event-descriptor-key-events entry))))))
659  new-value)
660
661;;; LOGICAL-KEY-EVENT-DOCUMENTATION, NAME, KEY-EVENTS  --  Public
662;;;
663;;;    Grab the right field out of the descriptor and return it.
664;;;
665(defun logical-key-event-documentation (keyword)
666  "Return the documentation for the logical key-event Keyword."
667  (logical-key-event-descriptor-documentation
668   (get-logical-key-event-desc keyword)))
669;;;
670(defun logical-key-event-name (keyword)
671  "Return the string name for the logical key-event Keyword."
672  (logical-key-event-descriptor-name (get-logical-key-event-desc keyword)))
673;;;
674(defun logical-key-event-key-events (keyword)
675  "Return the list of key-events for which Keyword is the logical key-event."
676  (logical-key-event-descriptor-key-events
677   (get-logical-key-event-desc keyword)))
678
679;;; DEFINE-LOGICAL-KEY-EVENT  --  Public
680;;;
681;;;    Make the entries in the two hashtables and the string-table.
682;;;
683(defun define-logical-key-event (name documentation)
684  "Define a logical key-event having the specified Name and Documentation.
685  See LOGICAL-KEY-EVENT-P and COMMAND-CASE."
686  (check-type name string)
687  (check-type documentation (or string function))
688  (let* ((keyword (string-to-keyword name))
689         (entry (or (gethash keyword *logical-key-event-descriptors*)
690                    (setf (gethash keyword *logical-key-event-descriptors*)
691                          (make-logical-key-event-descriptor)))))
692    (setf (logical-key-event-descriptor-name entry) name)
693    (setf (logical-key-event-descriptor-documentation entry) documentation)
694    (setf (getstring name *logical-key-event-names*) keyword)))
695
696
697
698;;;; Some standard logical-key-events:
699
700(define-logical-key-event "Abort"
701  "This key-event is used to abort the command in progress.")
702(define-logical-key-event "Yes"
703  "This key-event is used to indicate a positive response.")
704(define-logical-key-event "No"
705  "This key-event is used to indicate a negative response.")
706(define-logical-key-event "Do All"
707  "This key-event means do it as many times as you can.")
708(define-logical-key-event "Do Once"
709  "This key-event means, do it this time, then exit.")
710(define-logical-key-event "Help"
711  "This key-event is used to ask for help.")
712(define-logical-key-event "Confirm"
713  "This key-event is used to confirm some choice.")
714(define-logical-key-event "Quote"
715  "This key-event is used to quote the next key-event of input.")
716(define-logical-key-event "Keep"
717  "This key-event means exit but keep something around.")
718(define-logical-key-event "y"
719  "This key-event is used to indicate a short positive response.")
720(define-logical-key-event "n"
721  "This key-event is used to indicate a short negative response.")
722
723
724;;;; COMMAND-CASE help message printing.
725
726(defvar *my-string-output-stream* (make-string-output-stream))
727
728(defun chars-to-string (chars)
729  (do ((s *my-string-output-stream*)
730       (chars chars (cdr chars)))
731      ((null chars)
732       (get-output-stream-string s))
733    (let ((char (car chars)))
734      (if (characterp char)
735          (write-char char s)
736          (do ((key-events
737                (logical-key-event-key-events char)
738                (cdr key-events)))
739              ((null key-events))
740            (write-string (pretty-key-string (car key-events)) s)
741            (unless (null (cdr key-events))
742              (write-string ", " s))))
743      (unless (null (cdr chars))
744        (write-string ", " s)))))
745
746;;; COMMAND-CASE-HELP  --  Internal
747;;;
748;;;    Print out a help message derived from the options in a
749;;; random-typeout window.
750;;;
751(defun command-case-help (help options)
752  (let ((help (if (listp help)
753                  (apply #'format nil help) help)))
754    (with-pop-up-display (s :title "Help")
755      (write-string help s)
756      (fresh-line s)
757      (do ((o options (cdr o)))
758          ((null o))
759        (let ((string (chars-to-string (caar o))))
760          (declare (simple-string string))
761          (if (= (length string) 1)
762              (write-char (char string 0) s)
763              (write-line string s))
764          (write-string "  - " s)
765          (write-line (cdar o) s))))))
Note: See TracBrowser for help on using the repository browser.