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

Contents of /src/hemlock/echo.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5