Skip to content
Snippets Groups Projects
accept.lisp 18.8 KiB
Newer Older
cer's avatar
cer committed
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
;; copyright (c) 1985,1986 Franz Inc, Alameda, Ca.
;; copyright (c) 1986-1998 Franz Inc, Berkeley, CA  - All rights reserved.
;;
;; The software, data and information contained herein are proprietary
;; to, and comprise valuable trade secrets of, Franz, Inc.  They are
;; given in confidence by Franz, Inc. pursuant to a written license
;; agreement, and may be stored and used only in accordance with the terms
;; of such license.
;;
;; Restricted Rights Legend
;; ------------------------
;; Use, duplication, and disclosure of the software, data and information
;; contained herein by any agency, department or entity of the U.S.
;; Government are subject to restrictions of Restricted Rights for
;; Commercial Software developed at private expense as specified in
;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable.
;;
;; $Id: accept.lisp,v 1.30 2000/06/26 17:42:07 layer Exp $
cer's avatar
cer committed

cer's avatar
cer committed
(in-package :clim-internals)
cer's avatar
cer committed

;;"Copyright (c) 1990, 1991, 1992 Symbolics, Inc.	 All rights reserved."
cer's avatar
cer committed

(defun accept (type &rest accept-args
cer's avatar
cer committed
	       &key (stream *standard-input*)
cer's avatar
cer committed
		    (view (stream-default-view stream))
		    (default nil default-supplied-p)
		    (default-type type)
		    (history type)
		    (provide-default nil)
		    (prompt t)
		    (prompt-mode ':normal)
		    (display-default prompt)
		    (query-identifier nil)
cer's avatar
cer committed
		    (activation-gestures nil)
		    (additional-activation-gestures nil)
cer's avatar
cer committed
		    (delimiter-gestures nil)
		    (additional-delimiter-gestures nil)
cer's avatar
cer committed
		    (insert-default nil) (replace-input t)
cer's avatar
cer committed
		    (present-p nil) (active-p t))
cer's avatar
cer committed
  (declare (dynamic-extent accept-args))
  (declare (values object type))
cer's avatar
cer committed
  (declare (ignore prompt-mode display-default
cer's avatar
cer committed
		   activation-gestures additional-activation-gestures
cer's avatar
cer committed
		   delimiter-gestures additional-delimiter-gestures 
cer's avatar
cer committed
		   insert-default replace-input present-p active-p))
cer's avatar
cer committed

  ;; Allow the arguments to be presentation type abbreviations
  (multiple-value-bind (expansion expanded)
      (expand-presentation-type-abbreviation type)
    (when expanded
      (when (eq default-type type)
	(setq default-type expansion))
cer's avatar
cer committed
      (when (eq history type)
cer's avatar
cer committed
	(setq history expansion))
      (setq type expansion)))
  (unless (eq default-type type)
    (multiple-value-bind (expansion expanded)
	(expand-presentation-type-abbreviation default-type)
      (when expanded
	(setq default-type expansion)
	(setq accept-args `(:default-type ,default-type ,@accept-args)))))
  (unless (eq history type)
    (multiple-value-bind (expansion expanded)
	(expand-presentation-type-abbreviation history)
      (when expanded
	(setq history expansion)
	(setq accept-args `(:history ,history ,@accept-args)))))

  (let ((insert-default nil))
    (when (and provide-default (null default-supplied-p))
      ;; If the user wants a default, but provided none, go get it from the history
      (let ((history (if (typep history 'basic-history)
			 history
			 (presentation-type-history history))))
cer's avatar
cer committed
	(when history
	  (let ((element (yank-from-history history)))
	    (when element
	      (setq default (presentation-history-element-object element)
		    default-supplied-p t
		    insert-default t))))))
    (when default-supplied-p
      ;; Massage the default
      (multiple-value-bind (new-default new-type)
	  (presentation-default-preprocessor default type :default-type default-type)
	(when (or (not (eq default new-default))
		  (not (eq default-type new-type)))
	  (setq default new-default
		default-type (or new-type default-type)
		insert-default t))))
    (when insert-default
      (setq accept-args `(:default ,default :default-type ,default-type ,@accept-args))))

cer's avatar
cer committed
  (typecase view
    (null)
    (symbol (setq view (make-instance view)))
    (cons   (setq view (apply #'make-instance view))))
cer's avatar
 
cer committed
  (setq view (decode-indirect-view type view (frame-manager stream)
				   :query-identifier query-identifier))
cer's avatar
cer committed

  ;; Call STREAM-ACCEPT to do the work.	 It would be nice if we could
cer's avatar
 
cer committed
  ;; call PROMPT-FOR-ACCEPT to generate the real query-id here, but we
  ;; can't because we want to be able to decide exactly how it is called
  ;; on a case-by-case basis.  For example, within ACCEPTING-VALUES...
cer's avatar
cer committed
  (with-keywords-removed (accept-args accept-args '(:stream :view))
    (apply #'stream-accept (encapsulating-stream stream) type
cer's avatar
 
cer committed
			   :view view :query-identifier query-identifier
			   accept-args)))
cer's avatar
cer committed

cer's avatar
 
cer committed
(defmethod stream-accept ((stream input-protocol-mixin) type &rest accept-args
			  &key view &allow-other-keys)
cer's avatar
cer committed
  (declare (dynamic-extent accept-args))
  (let* ((stream (encapsulating-stream stream))
colin's avatar
colin committed
	 (query-identifier (apply #'prompt-for-accept
				  stream type view accept-args)))
    (apply #'accept-1 stream type
	   :query-identifier query-identifier
	   accept-args)))
cer's avatar
cer committed

cer's avatar
cer committed
(defmethod prompt-for-accept ((stream input-protocol-mixin) type (view view)
			      &rest accept-args
cer's avatar
cer committed
			      &key query-identifier &allow-other-keys)
cer's avatar
cer committed
  (declare (dynamic-extent accept-args))
cer's avatar
cer committed
  (when (output-stream-p stream)
cer's avatar
cer committed
    (apply #'prompt-for-accept-1 stream type accept-args))
cer's avatar
cer committed
  query-identifier)

cer's avatar
cer committed
(defun prompt-for-accept-1 (stream type
			    &key (default nil default-supplied-p) (default-type type)
				 (prompt t) (prompt-mode ':normal)
				 (display-default prompt)
			    &allow-other-keys)
cer's avatar
cer committed
  (cond ((eq prompt t)
	 (write-string "Enter " stream)
	 (describe-presentation-type type stream 1))
	((not (eq prompt nil))
	 (write-string prompt stream)))
  (when (and display-default default-supplied-p)
    (when prompt (write-string " [" stream))
    (write-string "default " stream)
    (present default default-type :stream stream)
    (when prompt (write-string "]" stream)))
  (when (eq prompt-mode ':normal)
    (when (or prompt (and display-default default-supplied-p))
      (write-string ": " stream))))

cer's avatar
cer committed
(defun accept-1 (stream type
cer's avatar
cer committed
		 &key (view (stream-default-view stream))
		      (default nil default-supplied-p)
		      (default-type type)
		      ((:history history-type) type)
cer's avatar
cer committed
		      (insert-default nil) (replace-input t replace-supplied-p)
		      (prompt t)
cer's avatar
cer committed
		      (present-p nil)
		      (query-identifier nil)
cer's avatar
cer committed
		      (activation-gestures nil activation-gestures-p)
cer's avatar
cer committed
		      (additional-activation-gestures nil)
cer's avatar
cer committed
		      (delimiter-gestures nil delimiter-gestures-p)
cer's avatar
cer committed
		      (additional-delimiter-gestures nil)
cer's avatar
cer committed
		      (active-p t)
cer's avatar
cer committed
		 &allow-other-keys)

  ;; Set up the input editing environment
  (let ((the-object nil)
	(the-type nil)
cer's avatar
cer committed
	(the-options nil)
cer's avatar
cer committed
	(activated t)
	(history nil))

    (cond ((typep history-type 'basic-history)
	   (setq history history-type
		 history-type type))
	  (history-type
	   (setq history (presentation-type-history history-type))))

cer's avatar
cer committed
    ;; Inside ACCEPTING-VALUES, ACCEPT can turn into PRESENT
cer's avatar
cer committed
    (when present-p
cer's avatar
cer committed
      (return-from accept-1
cer's avatar
cer committed
	(accept-present-default type stream view default default-supplied-p
cer's avatar
cer committed
				present-p query-identifier
				:prompt prompt :active-p active-p)))
cer's avatar
cer committed

    (block input-editing
      (flet ((input-sensitizer (continuation stream)
	       (declare (dynamic-extent continuation))
cer's avatar
cer committed
	       (if (stream-recording-p stream)
		   (with-output-as-presentation (stream the-object (or the-type type))
cer's avatar
cer committed
		     (funcall continuation stream))
		   (funcall continuation stream))))
	(declare (dynamic-extent #'input-sensitizer))
cer's avatar
cer committed
	(with-input-editing (stream :input-sensitizer #'input-sensitizer
				    :initial-contents (and insert-default
							   default-supplied-p
							   (list default default-type)))
cer's avatar
cer committed
	  (let ((start-position (stream-scan-pointer stream)))
cer's avatar
cer committed
	    (with-input-context (type)
				(object presentation-type nil options)
	      (with-activation-gestures ((if activation-gestures-p
					     activation-gestures
					   (or additional-activation-gestures
					       *standard-activation-gestures*))
cer's avatar
cer committed
					 :override activation-gestures-p)
		(with-delimiter-gestures ((if delimiter-gestures-p
					      delimiter-gestures
					    additional-delimiter-gestures)
cer's avatar
cer committed
					  :override delimiter-gestures-p)
		  (handler-bind
		      ((parse-error
			 #'(lambda (anerror)
			     (declare (ignore anerror))
cer's avatar
cer committed
			     (when (and default-supplied-p
					(check-for-default stream start-position
							   default default-type
							   view))
			       (setq the-object default
				     the-type default-type)
			       (return-from input-editing))
			     ;; Decline to handle the parse error
			     nil)))
cer's avatar
cer committed
		    (flet ((accept-help (stream action string-so-far)
			     (declare (ignore action string-so-far))
			     (write-string "You are being asked to enter " stream)
			     (describe-presentation-type type stream)
			     (write-char #\. stream)))
		      (declare (dynamic-extent #'accept-help))
		      (with-accept-help
			  (((:top-level-help :establish-unless-overridden)
			    ;; :ESTABLISH-... here because we want (SEQUENCE PATHNAME)'s
			    ;; help, not both (SEQUENCE PATHNAME) and PATHNAME.
			    #'accept-help))
			;; Call the presentation type's ACCEPT method
			(multiple-value-setq (the-object the-type)
			  (let ((*presentation-type-for-yanking* (and history history-type)))
			    (if default-supplied-p
				(if history
				    (let ((default-element
					    (make-presentation-history-element
					      :object default :type default-type)))
				      (with-default-bound-in-history history default-element
cer's avatar
cer committed
					(funcall-presentation-generic-function accept
cer's avatar
cer committed
					  type stream view
					  :default default :default-type default-type)))
cer's avatar
cer committed
				    (funcall-presentation-generic-function accept
cer's avatar
cer committed
				      type stream view
				      :default default :default-type default-type))
				(funcall-presentation-generic-function accept
cer's avatar
cer committed
				  type stream view)))))))))

	       ;; A presentation translator was invoked
	       (t 
		 (setq the-object object
		       the-type presentation-type
cer's avatar
cer committed
		       the-options options
cer's avatar
cer committed
		       activated nil)
cer's avatar
cer committed
		 (when (if replace-supplied-p
			   replace-input
cer's avatar
cer committed
			   (getf the-options :echo t))
		   (presentation-replace-input stream the-object the-type view
cer's avatar
cer committed
					       :buffer-start start-position
					       :query-identifier query-identifier))))))))

    ;; The input has been parsed, moused, or defaulted.
    ;; If we are still inside a WITH-INPUT-EDITING at an outer level, leave the
    ;; delimiter in the stream.	 But if this was the top level of input, eat
cer's avatar
cer committed
    ;; the activation gesture instead of leaving it in the stream. Don't eat
    ;; the activation gesture on streams that can't ever support input editing,
    ;; such as string streams.
    ;;--- This is really lousy.	 We need a coherent theory here.
cer's avatar
cer committed
    (when activated
cer's avatar
cer committed
      (when (and (not (input-editing-stream-p stream))
cer's avatar
cer committed
		 (stream-supports-input-editing stream))
	(let ((gesture (read-gesture :stream stream :timeout 0)))
	  ;;--- For now, just ignore button release events
cer's avatar
cer committed
	  (when (typep gesture 'pointer-button-release-event)
cer's avatar
cer committed
	    (read-gesture :stream stream :timeout 0)))))
cer's avatar
cer committed
    (when (and history
	       (frame-maintain-presentation-histories *application-frame*)
	       (getf the-options :maintain-history t))
cer's avatar
cer committed
      ;;--- Should this only record stuff that was input via the keyboard?
      (push-history-element history (make-presentation-history-element
				      :object the-object :type (or the-type type))))
    #+compulsive-type-checking
    (when (and the-type (not (eq the-type type)))
cer's avatar
cer committed
      (unless (presentation-subtypep-1 the-type type)
cer's avatar
cer committed
	;; Catch a common bug by verifying that the returned type is a subtype
	;; of the requested type
	(cerror "Return a second value of ~*~*~*~S"
		"The ~S method for the type ~S returned a second value of ~S, ~
		 which is not a subtype of ~S"
		'accept type the-type type)
	(setq the-type type)))
    ;; Ensure that there are no stale highlighting boxes lying around if
    ;; we are exiting via keyboard input
    (when (output-recording-stream-p stream)
      (unhighlight-highlighted-presentation stream t))
    (values the-object (or the-type type))))

;;; If the input from stream, starting at location, is a request to use the default
;;; then insert the default and return true
(defun check-for-default (stream location default default-type view)
cer's avatar
cer committed
  (setf (stream-scan-pointer stream) location)
cer's avatar
cer committed
  (loop
    (let ((char (read-gesture :stream stream)))
      (when (or (not (characterp char))
cer's avatar
cer committed
		(delimiter-gesture-p char)
cer's avatar
cer committed
		(not (whitespace-char-p char)))
cer's avatar
cer committed
	;; If we got some kind of mouse gesture or a delimiter or a
	;; printing character, then put it back and check to see if
cer's avatar
cer committed
	;; we should insert the default.
	(unread-gesture char :stream stream)
cer's avatar
cer committed
	(setf (stream-scan-pointer stream) location)
cer's avatar
cer committed
	(when (or (null char)
cer's avatar
cer committed
		  (activation-gesture-p char)
cer's avatar
cer committed
		  (delimiter-gesture-p char))
cer's avatar
cer committed
	  ;; Insert the default if we got a character that will terminate
	  ;; the current call to ACCEPT
cer's avatar
cer committed
	  (unless (stream-rescanning-p stream)
cer's avatar
cer committed
	    (presentation-replace-input stream default default-type view
					:buffer-start location))
	  (return-from check-for-default t))
	(return-from check-for-default nil)))))

;;; As in DW, this does not do defaulting, but does accept a :default argument
;;; in case the accept method needs it (e.g. for pathnames)
cer's avatar
cer committed
(defun accept-from-string (type string 
			   &key (view +textual-view+)
				(default nil default-supplied-p)
				(default-type type)
				(activation-gestures nil activation-gestures-p)
				(additional-activation-gestures nil)
				(delimiter-gestures nil delimiter-gestures-p)
				(additional-delimiter-gestures nil)
				(start 0) (end nil))
cer's avatar
cer committed
  (declare (values object type index))

  ;; Allow the arguments to be presentation type abbreviations
  (multiple-value-bind (expansion expanded)
      (expand-presentation-type-abbreviation type)
    (when expanded
      (when (eq default-type type)
	(setq default-type expansion))
      (setq type expansion)))
  (unless (eq default-type type)
    (multiple-value-bind (expansion expanded)
	(expand-presentation-type-abbreviation default-type)
      (when expanded
	(setq default-type expansion))))

  ;; Call the presentation type's accept method
  (let ((index start))
    (multiple-value-bind (the-object the-type)
	(with-input-from-string (stream string :start start :end end :index index)
	  (with-activation-gestures ((if activation-gestures-p
					 activation-gestures
				       (or additional-activation-gestures
					   *standard-activation-gestures*))
cer's avatar
cer committed
				     :override activation-gestures-p)
	    (with-delimiter-gestures ((if delimiter-gestures-p
					  delimiter-gestures
					additional-delimiter-gestures)
cer's avatar
cer committed
				      :override delimiter-gestures-p)
	      (handler-bind 
		  ((parse-error
		     #'(lambda (anerror)
			 (declare (ignore anerror))
			 ;; This private version of CHECK-FOR-DEFAULT is
			 ;; enough for string and string streams to do a
			 ;; reasonable job, but it's not perfect.  Some
			 ;; hairy presentation types may still not work.
			 (flet ((check-for-default (stream)
				  (loop
				    (let ((char (read-char stream nil *end-of-file-marker*)))
				      (when (or (not (characterp char))
						(delimiter-gesture-p char)
						(not (whitespace-char-p char)))
					(unless (eq char *end-of-file-marker*)
					  (unread-char char stream))
					(when (and default-supplied-p
						   (or (eq char *end-of-file-marker*)
						       (activation-gesture-p char)
						       (delimiter-gesture-p char)))
					  (return-from check-for-default t))
					(return-from check-for-default nil))))))
			   (declare (dynamic-extent #'check-for-default))
			   (when (check-for-default stream)
			     (return-from accept-from-string
			       (values default default-type index)))))))
		(if default-supplied-p
		    (funcall-presentation-generic-function accept
		      type stream view
		      :default default :default-type default-type)
		    (funcall-presentation-generic-function accept
							   type stream view))))))
      #+aclpc ;; for some reason paul want to do this twice (error? :)
	(with-input-from-string (stream string :start start :end end :index index)
	  (with-activation-gestures ((if activation-gestures-p
					 activation-gestures
				       (or additional-activation-gestures
					   *standard-activation-gestures*))
				     :override activation-gestures-p)
	    (with-delimiter-gestures ((if delimiter-gestures-p
					  delimiter-gestures
					additional-delimiter-gestures)
				      :override delimiter-gestures-p)
	      (handler-bind 
		  ((parse-error
		     #'(lambda (anerror)
			 (declare (ignore anerror))
cer's avatar
cer committed
			 ;; This private version of CHECK-FOR-DEFAULT is
			 ;; enough for string and string streams to do a
			 ;; reasonable job, but it's not perfect.  Some
			 ;; hairy presentation types may still not work.
			 (flet ((check-for-default (stream)
				  (loop
				    (let ((char (read-char stream nil *end-of-file-marker*)))
				      (when (or (not (characterp char))
						(delimiter-gesture-p char)
						(not (whitespace-char-p char)))
					(unless (eq char *end-of-file-marker*)
					  (unread-char char stream))
					(when (and default-supplied-p
						   (or (eq char *end-of-file-marker*)
						       (activation-gesture-p char)
						       (delimiter-gesture-p char)))
					  (return-from check-for-default t))
					(return-from check-for-default nil))))))
			   (declare (dynamic-extent #'check-for-default))
			   (when (check-for-default stream)
			     (return-from accept-from-string
			       (values default default-type index)))))))
		(if default-supplied-p
		    (funcall-presentation-generic-function accept
		      type stream view
		      :default default :default-type default-type)
		    (funcall-presentation-generic-function accept
		      type stream view))))))
cer's avatar
cer committed
      (values the-object (or the-type type) index))))

;; Make ACCEPT work inside WITH-INPUT-FROM-STRING
;; by defining methods that partially implement the extended stream input
;; protocol on input-from-string streams 
(defmethod stream-read-gesture ((stream t)
				&key timeout peek-p
				     input-wait-test input-wait-handler
				     pointer-button-press-handler)
  (declare (ignore input-wait-test input-wait-handler pointer-button-press-handler))
  ;; avoid using STREAM-x functions to reduce Gray stream dependence,
  ;; tfb 13-jun-2000
cer's avatar
cer committed
  (let ((char (if (eq timeout 0)

		  (read-char-no-hang stream nil ':eof)
		  (read-char stream nil ':eof))))
cer's avatar
cer committed
    (when (and char peek-p)
      (unread-char char stream))
cer's avatar
cer committed
    char))

(defmethod stream-unread-gesture ((stream t) gesture)
cer's avatar
cer committed
  (unless (eq gesture *end-of-file-marker*)
cer's avatar
cer committed
    (check-type gesture character)
    ;; avoid using STREAM-x functions to reduce Gray stream dependence,
    ;; tfb 13-jun-2000
    (unread-char gesture stream)))
cer's avatar
cer committed

cer's avatar
 
cer committed
(defmethod stream-accept ((stream t) type &rest accept-args
			  &key view &allow-other-keys)
cer's avatar
cer committed
  (declare (dynamic-extent accept-args))
cer's avatar
 
cer committed
  (let ((query-identifier
	  (apply #'prompt-for-accept
		 (encapsulating-stream stream) type view accept-args)))
    (apply #'accept-1 (encapsulating-stream stream) type
cer's avatar
 
cer committed
		      :query-identifier query-identifier
		      accept-args)))
cer's avatar
cer committed

cer's avatar
cer committed
(defmethod prompt-for-accept ((stream t) type (view view) 
			      &key query-identifier &allow-other-keys)
cer's avatar
cer committed
  (declare (ignore type))
  query-identifier)