;;;-*- cold-load:t; Mode:Common-Lisp; Package:FORMAT; Base:10 -*- ;;; RESTRICTED RIGHTS LEGEND ;;;Use, duplication, or disclosure by the Government is subject to ;;;restrictions as set forth in subdivision (c)(1)(ii) of the Rights in ;;;Technical Data and Computer Software clause at 52.227-7013. ;;; ;;; TEXAS INSTRUMENTS INCORPORATED. ;;; P.O. BOX 2909 ;;; AUSTIN, TEXAS 78769 ;;; MS 2151 ;;; ;;; Copyright (C) 1985-1989 Texas Instruments Incorporated. All rights reserved. ;;; ** (c) Copyright 1980 Massachusetts Institute of Technology ** ;;; (FQUERY OPTIONS FORMAT-STRING &REST FORMAT-ARGS) ;;; OPTIONS is a PLIST. Defined indicators are: ;;; :MAKE-COMPLETE boolean. Send a :MAKE-COMPLETE message to the stream if it understands it. ;;; :TYPE one of :TYI, :READLINE. How typing is gathered and echoed. ;;; :CHOICES a list of choices. ;;; A choice is either the symbol :ANY or a list. ;;; If a list, its car is either a possible return value, ;;; or a list of a possible return value and how to echo it. ;;; The remaining things in the list are input items that select that return value. ;;; For a :READLINE type call, they should be strings. ;;; For a :TYI type call, they should be characters. ;;; Example choice: ((:foo "Foo") #/F #\space) ;;; :FRESH-LINE boolean. Send a FRESH-LINE to the stream initially. ;;; :CONDITION symbol. Signalled before asking. ;;; :LIST-CHOICES boolean. After prompting in parentheses. ;;; :BEEP boolean. Before printing message. ;;; :CLEAR-INPUT boolean. Before printing message. ;;; :SELECT boolean. Select the window and select back. ;;; :HELP-FUNCTION function. Called with STREAM, CHOICES and TYPE-FUNCTION as arguments. ;;; :STREAM stream or expression. Specifies the stream to use. ;;; If it is a symbol (which is not an io-stream) or a list it is evaluated. ;;; Default is to use QUERY-IO. ;;; Edit history: ;;;------------------------------------------------------------------------------ ;;; 8-26-87 rjf o Removed unneeded unwind-protect from fquery (defvar fquery-format-string) (defvar fquery-format-args) (defvar fquery-list-choices) (defvar fquery-choices) (defvar fquery-help-function) (defvar fquery-stream) (defun fquery (options fquery-format-string &rest fquery-format-args &aux make-complete type type-function fquery-choices stream fquery-stream fresh-line condition fquery-list-choices fquery-help-function beep-p clear-input select handled-p val typein) "Ask a multiple-choice question on QUERY-IO. FQUERY-FORMAT-STRING and FQUERY-FORMAT-ARGS are used to print the question. Ending the string with \"? \" is often appropriate. OPTIONS is a PLIST. Defined indicators are: :MAKE-COMPLETE boolean. Send a :MAKE-COMPLETE message to the stream if it understands it. :TYPE one of :TYI, :READLINE, :MINI-BUFFER-OR-READLINE. It says how the answer is gathered and echoed. :CHOICES a list of choices. A choice is either the symbol :ANY or a list. If a list, its car is either a possible return value, or a list of a possible return value and how to echo it. The remaining things in the list are input items that select that return value. For a :READLINE type call, they should be strings. For a :TYI type call, they should be characters. Example choice (for :READLINE): ((:foo \"Foo\") #F #\\space) :FRESH-LINE boolean. Send a :FRESH-LINE to the stream initially. :CONDITION symbol. Signalled before asking. :LIST-CHOICES boolean. If T, a list of choices is printed after the question. :BEEP boolean. If T, we beep before printing the message. :CLEAR-INPUT boolean. If T, we discard type-ahead before printing the message. :SELECT boolean. Select the window and select back. :HELP-FUNCTION specifies a function to be called if the user types Help. It is called with STREAM, CHOICES and TYPE-FUNCTION as arguments. :STREAM stream or expression. Specifies the stream to use. If it is a symbol (which is not an io-stream) or a list it is evaluated. Default is to use QUERY-IO." (setf (values make-complete type fquery-choices stream beep-p clear-input select fresh-line condition fquery-list-choices fquery-help-function) (apply 'fquery-decode-options options)) (setq fquery-stream (if stream (if (or (and (symbolp stream) (not (get stream 'si:io-stream-p))) (consp stream)) (eval stream) stream) *query-io*)) (setq type-function (or (get type 'fquery-function) (ferror () "~S is not a valid :TYPE for FQUERY" type))) (and condition (or (neq condition 'fquery) (eh:condition-name-handled-p condition)) (multiple-value-setq (handled-p val) (signal-condition (apply 'make-condition condition options fquery-format-string fquery-format-args) '(:new-value)))) (if handled-p val ;;;(unwind-protect (progn (block top (do () (nil) (when beep-p (beep)) (when clear-input (funcall fquery-stream :clear-input)) (when fresh-line (funcall fquery-stream :fresh-line)) (setq typein (funcall type-function :read fquery-stream)) (dolist (choice fquery-choices) (cond ((eq choice :any) (funcall type-function :echo typein fquery-stream) (when make-complete (funcall fquery-stream :send-if-handles :make-complete)) (return-from top typein)) ((funcall type-function :member typein (cdr choice)) (setq choice (car choice)) (when (consp choice) (funcall type-function :echo (cadr choice) fquery-stream) (setq choice (car choice))) (when make-complete (funcall fquery-stream :send-if-handles :make-complete)) (return-from top choice)))) (setq beep-p t clear-input t fresh-line t ;User spazzed, will need fresh line fquery-list-choices t)))) ;and should list options ;;;) )) (defun fquery-decode-options (&key (make-complete t) (type :tyi) (choices y-or-n-p-choices) stream beep clear-input select (fresh-line t) (condition :fquery) signal-condition (list-choices t) (help-function 'default-fquery-help)) signal-condition (values make-complete type choices stream beep clear-input select fresh-line condition list-choices help-function)) (defun fquery-prompt (stream &rest ignore) (and fquery-format-string (apply #'format stream fquery-format-string fquery-format-args)) (and fquery-list-choices (do ((choices fquery-choices (cdr choices)) (first-p t nil) (many (> (length fquery-choices) 2)) (choice)) ((null choices) (or first-p (funcall stream :string-out ") "))) (funcall stream :string-out (cond (first-p "(") ((not (null (cdr choices))) ", ") (many ", or ") (t " or "))) (if (eq (car choices) :any) (funcall stream :string-out "anything else") (progn (setq choice (cadar choices)) (cond ((or (numberp choice) (characterp choice)) (format stream "~:@C" choice)) ((equal choice "") (princ "nothing" stream)) (t (funcall stream :string-out choice)))))))) (defun default-fquery-help (stream choices type) type;Not relevant (do ((choices choices (cdr choices)) (first-p t nil) (choice)) ((null choices) (or first-p (funcall stream :string-out ") "))) (funcall stream :string-out (cond (first-p "(Type ") ((not (null (cdr choices))) ", ") (t " or "))) (setq choice (car choices)) (cond ((eq choice :any) (princ "anything else" stream)) (t ;;Print the first input which selects this choice. ;;Don't confuse the user by mentioning possible alternative inputs. (cond ((or (numberp (cadr choice))(characterp (cadr choice))) (format stream "~:@C" (cadr choice))) ((equal (cadr choice) "") (princ "nothing" stream)) (t (funcall stream :string-out (cadr choice)))) ;; If that would echo as something else, say so (if (consp (car choice)) (format stream " (~A)" (cadar choice))))))) (defprop :tyi tyi-fquery-function fquery-function) (defun tyi-fquery-function (op arg1 &optional arg2) (case op (:read ;(arg1: stream) (do ((ch)) (nil) (fquery-prompt arg1 ) (setq ch (funcall arg1 :tyi)) (unless (and (char= ch #\HELP) fquery-help-function) (return ch)) (funcall fquery-help-function arg1 fquery-choices #'tyi-fquery-function) (funcall arg1 :fresh-line))) (:echo ;(arg1: echo, arg2: stream) (funcall arg2 :string-out (string arg1))) (:member ;(arg1: char, arg2: list) (member arg1 arg2 :test #'char-equal)))) (defprop :readline readline-fquery-function fquery-function) (defun readline-fquery-function (op arg1 &optional arg2) (case op (:read ; (stream &aux string) (let ((string (funcall arg1 :rubout-handler '((:editing-command #+elroy #\help #-elroy #.(char-code #\HELP)) ;Just in case (:prompt fquery-prompt) (:dont-save t)) #'fquery-readline-with-help arg1))) (string-trim '(#\SPACE) string))) (:echo arg2) (:member ;(arg1: string, arg2: list) (member arg1 arg2 :test #'string-equal)))) (defun fquery-readline-with-help (stream) (do ((string (make-array 20 :element-type 'string-char :fill-pointer 0)) (ch)) (nil) (setq ch (funcall stream :tyi)) (cond ((or (null ch) (char= ch #\NEWLINE)) (return string)) ((and (char= ch #\HELP) fquery-help-function) (fresh-line stream) (funcall fquery-help-function stream fquery-choices #'readline-fquery-function) (funcall stream :send-if-handles :refresh-rubout-handler)) ((ldb-test sys:%%kbd-control-meta ch)) (t (vector-push-extend ch string))))) (proclaim '(special zwei::*mini-buffer-arg-documenter*)) ;DEFVAR is in ZWEI. (defprop :mini-buffer-or-readline mini-buffer-or-readline-fquery-function fquery-function) (defun mini-buffer-or-readline-fquery-function (&rest args &aux string) (cond ((and (eq (car args) :read) (eq (cadr args) 'zwei::*typein-window*-syn-stream)) (let ((zwei::*mini-buffer-arg-documenter* 'mini-buffer-or-readline-help-function)) (funcall (cadr args) :send-if-handles :make-complete) (setq string (apply 'zwei:typein-line-readline fquery-format-string fquery-format-args))) (string-trim '(#\SPACE) string)) (t (apply 'readline-fquery-function args)))) (defun mini-buffer-or-readline-help-function () (format *terminal-io* "~&~%You are now typing an answer to a query.~&") (funcall fquery-help-function *terminal-io* fquery-choices 'mini-buffer-or-readline-fquery-function))