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

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

Various:

Implement prompt-for-key, the last of the prompting suite of functions.

Keep last-command around, not just last-key-event, though ended up not using it.

Stop using pty's for listener input, as they wedge the cocoa thread when the
listener is busy. Use a specialized stream using direct queues, as for output.

With above change, no longer use pty's at all, so stop loading PTY module.

Rearrange recursive setup so view activation happens outside of modifying-buffer-storage.

Fix so with-buffer-bindings doesn't get confused if already wound (can't wait
til I get rid of this whole winding thing!)

make c-n/c-p with numarg at least move to end of range when not enough lines.

API tweaks:

Get rid of *invoke-hook* since not usable in current setup anyway.
Make last-key-event-typed read-only.
Move cocoa-specific part of keysym-defs to cocoa-editor.lisp
Move everything out of hemock-ext, make hemlock-ext be strictly the external support API.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 26.4 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  (do ((tables (list (buffer-variables *current-buffer*)
341                     *global-variable-names*)
342               (cons (mode-object-variables (car mode)) tables))
343       (mode (buffer-mode-objects *current-buffer*) (cdr mode)))
344      ((null mode) tables)))
345
346(defun keyword-verification-function (eps string)
347  (declare (simple-string string))
348  (multiple-value-bind
349      (prefix key value field ambig)
350      (complete-string string (eps-parse-string-tables eps))
351    (declare (ignore field))
352    (modifying-echo-buffer
353     (cond ((eps-parse-value-must-exist eps)
354            (ecase key
355              (:none nil)
356              ((:unique :complete)
357               (list prefix value))
358              (:ambiguous
359               (let ((input-region (eps-parse-input-region eps)))
360                 (delete-region input-region)
361                 (insert-string (region-start input-region) prefix)
362                 (let ((point (current-point)))
363                   (move-mark point (region-start input-region))
364                   (unless (character-offset point ambig)
365                     (buffer-end point)))
366                 nil))))
367           (t
368            ;; HACK: If it doesn't have to exist, and the completion does not
369            ;; add anything, then return the completion's capitalization,
370            ;; instead of the user's input.
371            (list (if (= (length string) (length prefix)) prefix string)))))))
372
373
374
375;;;; Integer, expression, and string prompting.
376
377(defun prompt-for-integer (&key (must-exist t)
378                                default
379                                default-string
380                                (prompt "Integer: ")
381                                (help "Type an integer."))
382  "Prompt for an integer.  If :must-exist is Nil, then we return as a string
383  whatever was input if it is not a valid integer."
384
385  (parse-for-something
386   :verification-function #'(lambda (eps string)
387                              (let ((number (parse-integer string  :junk-allowed t)))
388                                (if (eps-parse-value-must-exist eps)
389                                  (if number (list number))
390                                  (list (or number string)))))
391   :type :string
392   :string-tables nil
393   :value-must-exist must-exist
394   :default-string default-string
395   :default (if default (write-to-string default :base 10))
396   :prompt prompt
397   :help help))
398
399
400(defvar hemlock-eof '(())
401  "An object that won't be EQ to anything read.")
402
403(defun prompt-for-expression (&key (must-exist t)
404                                   (default nil defaultp)
405                                   default-string
406                                   (prompt "Expression: ")
407                                   (help "Type a Lisp expression."))
408  "Prompts for a Lisp expression."
409  (parse-for-something
410   :verification-function #'(lambda (eps string)
411                              (let* ((input-region (eps-parse-input-region eps))
412                                     (expr (with-input-from-region (stream input-region)
413                                             (handler-case (read stream nil hemlock-eof)
414                                               (error () hemlock-eof)))))
415                                (if (eq expr hemlock-eof)
416                                  (unless (eps-parse-value-must-exist eps) (list string))
417                                  (values (list expr) t))))
418   :type :string
419   :string-tables nil
420   :value-must-exist must-exist
421   :default-string default-string
422   :default (if defaultp (prin1-to-string default))
423   :prompt prompt
424   :help help))
425
426
427(defun prompt-for-string (&key default
428                               default-string
429                               (trim ())
430                               (prompt "String: ")
431                               (help "Type a string."))
432  "Prompts for a string.  If :trim is t, then leading and trailing whitespace
433   is removed from input, otherwise it is interpreted as a Char-Bag argument
434   to String-Trim."
435  (when (eq trim t) (setq trim '(#\space #\tab)))
436  (parse-for-something
437   :verification-function #'(lambda (eps string)
438                              (declare (ignore eps))
439                              (list (string-trim trim string)))
440   :type :string
441   :string-tables nil
442   :value-must-exist nil
443   :default-string default-string
444   :default default
445   :prompt prompt
446   :help help))
447
448
449;;;; Package names.
450(defun make-package-string-table ()
451  (let ((names ()))
452    (dolist (p (list-all-packages))
453      (let* ((name (package-name p)))
454        (push (cons name name) names)
455        (dolist (nick (package-nicknames p))
456          (push (cons nick name) names))))
457    (make-string-table :initial-contents names)))
458
459#||
460(defun prompt-for-package (&key (must-exist t)
461                                (default nil defaultp)
462                                default-string
463                                (prompt "Package Name:")
464                                (help "Type a package name."))
465)
466||#
467
468
469;;;; Yes-or-no and y-or-n prompting.
470
471(defvar *yes-or-no-string-table*
472  (make-string-table :initial-contents '(("Yes" . t) ("No" . nil))))
473
474(defun prompt-for-yes-or-no (&key (must-exist t)
475                                  (default nil defaultp)
476                                  default-string
477                                  (prompt "Yes or No? ")
478                                  (help "Type Yes or No."))
479  "Prompts for Yes or No."
480  (parse-for-something
481   :verification-function #'(lambda (eps string)
482                              (multiple-value-bind
483                                  (prefix key value field ambig)
484                                  (complete-string string (eps-parse-string-tables eps))
485                                (declare (ignore prefix field ambig))
486                                (let ((won (or (eq key :complete) (eq key :unique))))
487                                  (if (eps-parse-value-must-exist eps)
488                                    (if won (values (list value) t))
489                                    (list (if won (values value t) string))))))
490   :type :keyword
491   :string-tables (list *yes-or-no-string-table*)
492   :value-must-exist must-exist
493   :default-string default-string
494   :default (if defaultp (if default "Yes" "No"))
495   :prompt prompt
496   :help help))
497
498(defun prompt-for-y-or-n (&key (must-exist t)
499                               (default nil defaultp)
500                               default-string
501                               (prompt "Y or N? ")
502                               (help "Type Y or N."))
503  "Prompts for Y or N."
504  (parse-for-something
505   :verification-function #'(lambda (eps key-event)
506                              (cond ((logical-key-event-p key-event :y)
507                                     (values (list t) t))
508                                    ((logical-key-event-p key-event :n)
509                                     (values (list nil) t))
510                                    ((and (eps-parse-default eps)
511                                          (logical-key-event-p key-event :confirm))
512                                     (values (list (equalp (eps-parse-default eps) "y")) t))
513                                    ((logical-key-event-p key-event :abort)
514                                     :abort)
515                                    ((logical-key-event-p key-event :help)
516                                     :help)
517                                    (t
518                                     (if (eps-parse-value-must-exist eps)
519                                       :error
520                                       (values (list key-event) t)))))
521   :type :key
522   :value-must-exist must-exist
523   :default-string default-string
524   :default (and defaultp (if default "Y" "N"))
525   :prompt prompt
526   :help help
527   :key-handler (getstring "Key Input Handler" *command-names*)))
528
529
530
531;;;; Key-event and key prompting.
532
533(defun prompt-for-key-event (&key (prompt "Key-event: ")
534                                  (help "Type any key"))
535  "Prompts for a key-event."
536  (parse-for-something
537   :verification-function #'(lambda (eps key-event)
538                              (declare (ignore eps))
539                              (values (list key-event) t))
540   :type :key
541   :prompt prompt
542   :help help
543   :key-handler (getstring "Key Input Handler" *command-names*)))
544
545(defun verify-key (eps key-event key quote-p)
546  ;; This is called with the echo buffer as the current buffer.  We want to look
547  ;; up the commands in the main buffer.
548  (let* ((buffer (hemlock-view-buffer (current-view)))
549         (n (length key)))
550    (block nil
551      (unless quote-p
552        (cond ((logical-key-event-p key-event :help)
553               (return :help))
554              ((logical-key-event-p key-event :abort)
555               (return :abort))
556              ((and (not (eps-parse-value-must-exist eps))
557                    (logical-key-event-p key-event :confirm))
558               (return
559                 (cond ((eql n 0)
560                        (let ((key (eps-parse-default eps))
561                              (cmd (and key (with-buffer-bindings (buffer)
562                                              (get-command key :current)))))
563                          (if (commandp cmd)
564                            (values (list key cmd) :confirmed)
565                            :error)))
566                       ((> n 0)
567                        (values (list key nil) :confirmed))
568                       (t :error))))))
569      (vector-push-extend key-event key)
570      (let ((cmd (if (eps-parse-value-must-exist eps)
571                   (with-buffer-bindings (buffer) (get-command key :current))
572                   :prefix)))
573        (cond ((commandp cmd)
574               (values (list key cmd) t))
575              ((eq cmd :prefix)
576               nil)
577              (t
578               (vector-pop key)
579               :error))))))
580
581(defun prompt-for-key (&key (prompt "Key: ")
582                            (help "Type a key.")
583                            default default-string
584                            (must-exist t))
585  (parse-for-something
586   :verification-function (let ((key (make-array 10 :adjustable t :fill-pointer 0))
587                                (quote-p nil))
588                            #'(lambda (eps key-event)
589                                (if (and (not quote-p) (logical-key-event-p key-event :quote))
590                                  (progn
591                                    (setq quote-p t)
592                                    (values :ignore nil))
593                                  (verify-key eps key-event key (shiftf quote-p nil)))))
594   :type :command
595   :prompt prompt
596   :help help
597   :value-must-exist must-exist
598   :default default
599   :default-string default-string
600   :key-handler (getstring "Key Input Handler" *command-names*)))
601
602
603;;;; Logical key-event stuff.
604
605(defvar *logical-key-event-names* (make-string-table)
606  "This variable holds a string-table from logical-key-event names to the
607   corresponding keywords.")
608
609(defvar *real-to-logical-key-events* (make-hash-table :test #'eql)
610  "A hashtable from real key-events to their corresponding logical
611   key-event keywords.")
612
613(defvar *logical-key-event-descriptors* (make-hash-table :test #'eq)
614  "A hashtable from logical-key-events to logical-key-event-descriptors.")
615
616(defstruct (logical-key-event-descriptor
617            (:constructor make-logical-key-event-descriptor ()))
618  name
619  key-events
620  documentation)
621
622;;; LOGICAL-KEY-EVENT-P  --  Public
623;;;
624(defun logical-key-event-p (key-event keyword)
625  "Return true if key-event has been defined to have Keyword as its
626   logical key-event.  The relation between logical and real key-events
627   is defined by using SETF on LOGICAL-KEY-EVENT-P.  If it is set to
628   true then calling LOGICAL-KEY-EVENT-P with the same key-event and
629   Keyword, will result in truth.  Setting to false produces the opposite
630   result.  See DEFINE-LOGICAL-KEY-EVENT and COMMAND-CASE."
631  (not (null (member keyword (gethash key-event *real-to-logical-key-events*)))))
632
633;;; GET-LOGICAL-KEY-EVENT-DESC  --  Internal
634;;;
635;;;    Return the descriptor for the logical key-event keyword, or signal
636;;; an error if it isn't defined.
637;;;
638(defun get-logical-key-event-desc (keyword)
639  (let ((res (gethash keyword *logical-key-event-descriptors*)))
640    (unless res
641      (error "~S is not a defined logical-key-event keyword." keyword))
642    res))
643
644;;; %SET-LOGICAL-KEY-EVENT-P  --  Internal
645;;;
646;;;    Add or remove a logical key-event link by adding to or deleting from
647;;; the list in the from-char hashtable and the descriptor.
648;;;
649(defun %set-logical-key-event-p (key-event keyword new-value)
650  (let ((entry (get-logical-key-event-desc keyword)))
651    (cond
652     (new-value
653      (pushnew keyword (gethash key-event *real-to-logical-key-events*))
654      (pushnew key-event (logical-key-event-descriptor-key-events entry)))
655     (t
656      (setf (gethash key-event *real-to-logical-key-events*)
657            (delete keyword (gethash key-event *real-to-logical-key-events*)))
658      (setf (logical-key-event-descriptor-key-events entry)
659            (delete keyword (logical-key-event-descriptor-key-events entry))))))
660  new-value)
661
662;;; LOGICAL-KEY-EVENT-DOCUMENTATION, NAME, KEY-EVENTS  --  Public
663;;;
664;;;    Grab the right field out of the descriptor and return it.
665;;;
666(defun logical-key-event-documentation (keyword)
667  "Return the documentation for the logical key-event Keyword."
668  (logical-key-event-descriptor-documentation
669   (get-logical-key-event-desc keyword)))
670;;;
671(defun logical-key-event-name (keyword)
672  "Return the string name for the logical key-event Keyword."
673  (logical-key-event-descriptor-name (get-logical-key-event-desc keyword)))
674;;;
675(defun logical-key-event-key-events (keyword)
676  "Return the list of key-events for which Keyword is the logical key-event."
677  (logical-key-event-descriptor-key-events
678   (get-logical-key-event-desc keyword)))
679
680;;; DEFINE-LOGICAL-KEY-EVENT  --  Public
681;;;
682;;;    Make the entries in the two hashtables and the string-table.
683;;;
684(defun define-logical-key-event (name documentation)
685  "Define a logical key-event having the specified Name and Documentation.
686  See LOGICAL-KEY-EVENT-P and COMMAND-CASE."
687  (check-type name string)
688  (check-type documentation (or string function))
689  (let* ((keyword (string-to-keyword name))
690         (entry (or (gethash keyword *logical-key-event-descriptors*)
691                    (setf (gethash keyword *logical-key-event-descriptors*)
692                          (make-logical-key-event-descriptor)))))
693    (setf (logical-key-event-descriptor-name entry) name)
694    (setf (logical-key-event-descriptor-documentation entry) documentation)
695    (setf (getstring name *logical-key-event-names*) keyword)))
696
697
698
699;;;; Some standard logical-key-events:
700
701(define-logical-key-event "Abort"
702  "This key-event is used to abort the command in progress.")
703(define-logical-key-event "Yes"
704  "This key-event is used to indicate a positive response.")
705(define-logical-key-event "No"
706  "This key-event is used to indicate a negative response.")
707(define-logical-key-event "Do All"
708  "This key-event means do it as many times as you can.")
709(define-logical-key-event "Do Once"
710  "This key-event means, do it this time, then exit.")
711(define-logical-key-event "Help"
712  "This key-event is used to ask for help.")
713(define-logical-key-event "Confirm"
714  "This key-event is used to confirm some choice.")
715(define-logical-key-event "Quote"
716  "This key-event is used to quote the next key-event of input.")
717(define-logical-key-event "Keep"
718  "This key-event means exit but keep something around.")
719(define-logical-key-event "y"
720  "This key-event is used to indicate a short positive response.")
721(define-logical-key-event "n"
722  "This key-event is used to indicate a short negative response.")
723
724
725;;;; COMMAND-CASE help message printing.
726
727(defvar *my-string-output-stream* (make-string-output-stream))
728
729(defun chars-to-string (chars)
730  (do ((s *my-string-output-stream*)
731       (chars chars (cdr chars)))
732      ((null chars)
733       (get-output-stream-string s))
734    (let ((char (car chars)))
735      (if (characterp char)
736          (write-char char s)
737          (do ((key-events
738                (logical-key-event-key-events char)
739                (cdr key-events)))
740              ((null key-events))
741            (write-string (pretty-key-string (car key-events)) s)
742            (unless (null (cdr key-events))
743              (write-string ", " s))))
744      (unless (null (cdr chars))
745        (write-string ", " s)))))
746
747;;; COMMAND-CASE-HELP  --  Internal
748;;;
749;;;    Print out a help message derived from the options in a
750;;; random-typeout window.
751;;;
752(defun command-case-help (help options)
753  (let ((help (if (listp help)
754                  (apply #'format nil help) help)))
755    (with-pop-up-display (s :title "Help")
756      (write-string help s)
757      (fresh-line s)
758      (do ((o options (cdr o)))
759          ((null o))
760        (let ((string (chars-to-string (caar o))))
761          (declare (simple-string string))
762          (if (= (length string) 1)
763              (write-char (char string 0) s)
764              (write-line string s))
765          (write-string "  - " s)
766          (write-line (cdar o) s))))))
Note: See TracBrowser for help on using the repository browser.