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

Contents of /src/hemlock/echo.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5