Skip to content
Snippets Groups Projects
frames.lisp 53.5 KiB
Newer Older
cer's avatar
cer committed
  (read-command (frame-command-table frame) :stream stream))
cer's avatar
cer committed

cer's avatar
cer committed
#+++ignore				;--- install this?
(defmethod execute-frame-command :around ((frame standard-application-frame) command)
  (let ((top-level-process (slot-value frame 'top-level-process)))
    (if (and top-level-process
	     (eq top-level-process (current-process)))
	;; If we're in the process for the frame, just execute the command
	(call-next-method)
	;; Otherwise arrange to run the command in the frame's process
	(execute-command-in-frame frame command))))

cer's avatar
cer committed
(defmethod execute-frame-command ((frame standard-application-frame) command)
  (apply (command-name command) (command-arguments command)))
cer's avatar
cer committed

cer's avatar
cer committed
(defvar *click-outside-menu-handler* nil)

cer's avatar
cer committed
(defmethod command-enabled (command-name (frame standard-application-frame))
  (with-slots (disabled-commands) frame
    (or *assume-all-commands-enabled*
	(and (not (member command-name disabled-commands))
	     (command-accessible-in-command-table-p
	       command-name (frame-command-table frame))))))

(defmethod (setf command-enabled) (enabled command-name (frame standard-application-frame))
  (with-slots (disabled-commands) frame
    (cond (enabled
	   (setf disabled-commands (delete command-name disabled-commands))
	   (note-command-enabled (frame-manager frame) frame command-name))
	  (t
	   (push command-name disabled-commands)
	   (note-command-enabled (frame-manager frame) frame command-name)))))

cer's avatar
cer committed

cer's avatar
cer committed
;;--- There is the compiler bug with (eval-when (compile load eval) ...)
;;--- DEFMETHOD with a CALL-NEXT-METHOD.  See to incorporate this patch.
(eval-when (#-Allegro compile load eval)
cer's avatar
cer committed
(define-condition synchronous-command-event ()
  ((command :initarg :command :reader synchronous-command-event-command))
  (:report (lambda (condition stream)
	     (format stream "Command event condition signalled for ~S"
	       (synchronous-command-event-command condition)))))
)	;eval-when

cer's avatar
cer committed
(defvar *reading-frame-command* nil)

cer's avatar
cer committed
(defmethod read-frame-command :around ((frame standard-application-frame) &key)
  (let* ((command (queue-pop (frame-command-queue frame))))
    (or command 
	(handler-bind ((synchronous-command-event
cer's avatar
cer committed
			#'(lambda (c)
			    (return-from read-frame-command
			      (synchronous-command-event-command c)))))
	  (let ((*reading-frame-command* t))
	    (call-next-method))))))
cer's avatar
cer committed
	
cer's avatar
cer committed
;;--- Actually this should be named command-event

cer's avatar
cer committed
(defclass presentation-event (event)
cer's avatar
cer committed
	  ((value :initarg :value :reader presentation-event-value)
	   (sheet :initarg :sheet :reader event-sheet)
	   (frame :initarg :frame :reader event-frame)
	   (queuep :initarg :queuep :initform nil)
	   (presentation-type :initarg :presentation-type :reader event-presentation-type))
  (:default-initargs :presentation-type 'command))
cer's avatar
cer committed

(defmethod handle-event (sheet (event presentation-event))
  (process-command-event sheet event))

(defun process-command-event (sheet event)
  ;;--- This code is as bad as I feel.
  (let ((command (presentation-event-value event)))
    (if (partial-command-p command)
	(throw-highlighted-presentation
cer's avatar
cer committed
	 (make-instance 'standard-presentation
			:object command
			:type (event-presentation-type event))
	 *input-context*
	 (allocate-event 'pointer-button-press-event
			 :sheet sheet
			 :x 0 :y 0
			 :modifier-state 0
			 :button +pointer-left-button+))
      (progn
	(when (and *input-buffer-empty*
		   (eq *application-frame* (event-frame event)))
	  (signal 'synchronous-command-event
		  :command command))
	;; Perhaps if this results directly from a user action then either
	;; we should do it right away, ie. loose the input buffer or beep if
	;; it has to be deffered,
	(if (slot-value event 'queuep)
	    (queue-frame-command (event-frame event) (presentation-event-value event))
	  (beep sheet))))))
cer's avatar
cer committed

(defun queue-frame-command (frame command)
  (queue-push (frame-command-queue frame) command))

cer's avatar
cer committed
(defmethod execute-command-in-frame ((frame standard-application-frame) 
				     command &rest initargs)
cer's avatar
cer committed
  (distribute-event
    (port frame)
cer's avatar
cer committed
    (apply #'allocate-event 
	   'presentation-event 
	   :frame frame
	   :sheet (frame-top-level-sheet frame) 
	   :value command 
	   initargs)))

(defun make-command-timer (frame 
			   command arguments delay 
			   &key repeat
				(command-table (frame-command-table frame)))
  (flet ((queue-command-event (timer)
	   (declare (ignore timer))
	   (execute-command-in-frame
	    frame
	    (cons command arguments)
	    :queuep t
	    :presentation-type `(command :command-table ,command-table))))
    (let ((timer 
	   (make-instance 'clim-utils::timer 
			  :function #'queue-command-event
			  :delay delay :repeat repeat)))
      (clim-utils::add-timer timer)
      timer)))
cer's avatar
cer committed

cer's avatar
cer committed

cer's avatar
cer committed
;;; The contract of this is to find an "appropriate" presentation; i.e., one
;;; satisfying the input context specified by TYPE.  Everything that looks for a
;;; presentation goes through this so that applications can specialize it.
(defmethod frame-find-innermost-applicable-presentation
cer's avatar
cer committed
	   ((frame standard-application-frame) input-context stream x y &key event)
  (find-innermost-applicable-presentation
    input-context stream x y
    :frame frame
    :modifier-state (window-modifier-state stream) :event event))
cer's avatar
cer committed

cer's avatar
cer committed
(defmethod frame-input-context-button-press-handler
cer's avatar
cer committed
	   ((frame standard-application-frame) stream button-press-event)
cer's avatar
cer committed
  (declare (ignore stream))
  (let* ((window (event-sheet button-press-event))
	 (x (pointer-event-x button-press-event))
	 (y (pointer-event-y button-press-event))
	 (highlighted-presentation (highlighted-presentation window nil))
	 (input-context *input-context*))
cer's avatar
cer committed
    #+Allegro
cer's avatar
cer committed
    (when (and *click-outside-menu-handler*
		(output-recording-stream-p window)
cer's avatar
cer committed
		(not (region-contains-position-p (stream-output-history window) x y)))
cer's avatar
cer committed
      (funcall *click-outside-menu-handler*))
    (when highlighted-presentation
      ;; Unhighlight on the way out.
      ;; But only unhighlight the window that the click is from. 
      (unhighlight-highlighted-presentation window nil))
    (throw-highlighted-presentation 
      (or (and (output-recording-stream-p window)
	       (frame-find-innermost-applicable-presentation
cer's avatar
cer committed
		 frame input-context window x y
		 :event button-press-event))
cer's avatar
cer committed
	  *null-presentation*)
      input-context
      button-press-event)))

(defun find-frame-pane-of-type (frame type)
cer's avatar
cer committed
  (map-over-sheets #'(lambda (sheet)
cer's avatar
cer committed
		       (when (typep sheet type)
cer's avatar
cer committed
			 (return-from find-frame-pane-of-type sheet)))
		   (frame-top-level-sheet frame)))
cer's avatar
cer committed

cer's avatar
cer committed
(defmethod frame-standard-output ((frame standard-application-frame))
  (or (find-frame-pane-of-type frame 'application-pane)
      (find-frame-pane-of-type frame 'interactor-pane)))
cer's avatar
cer committed

cer's avatar
cer committed
(defmethod frame-standard-input ((frame standard-application-frame))
  (or (find-frame-pane-of-type frame 'interactor-pane)
      (frame-standard-output frame)))
cer's avatar
cer committed

cer's avatar
cer committed
(defmethod frame-query-io ((frame standard-application-frame))
cer's avatar
cer committed
  (or (frame-standard-input frame)
      (frame-standard-output frame)))

cer's avatar
cer committed
(defmethod frame-error-output ((frame standard-application-frame))
  (frame-standard-output frame))
cer's avatar
cer committed

cer's avatar
cer committed
(defmethod frame-pointer-documentation-output ((frame standard-application-frame))
cer's avatar
cer committed
  (find-frame-pane-of-type frame 'pointer-documentation-pane))
cer's avatar
cer committed

cer's avatar
cer committed
;;--- This causes direct-manipulation and menu-driven applications not to
;;--- maintain histories.  Is there a better heuristic?
(defmethod frame-maintain-presentation-histories ((frame standard-application-frame))
  (not (null (find-frame-pane-of-type frame 'interactor-pane))))
cer's avatar
cer committed

cer's avatar
cer committed
(defmethod notify-user (frame message &rest options) 
cer's avatar
cer committed
  (declare (dynamic-extent options))
  (when frame
    (setf (getf options :frame) frame))
  (apply #'frame-manager-notify-user 
	 (if frame (frame-manager frame) (find-frame-manager)) message options))
cer's avatar
cer committed

(defmethod select-file (frame &rest options) 
cer's avatar
cer committed
  (declare (dynamic-extent options))
  (when frame
    (setf (getf options :frame) frame))
  (apply #'frame-manager-select-file
	 (if frame (frame-manager frame) (find-frame-manager)) options))
cer's avatar
cer committed

cer's avatar
cer committed

;;; Pointer documentation
cer's avatar
cer committed

cer's avatar
cer committed
(defvar *pointer-documentation-interval*
	(max (floor (* 1/10 internal-time-units-per-second)) 1))
(defvar *last-pointer-documentation-time* 0)
cer's avatar
cer committed

cer's avatar
cer committed
;;; Produce pointer documentation
(defmethod frame-document-highlighted-presentation
	   ((frame standard-application-frame) presentation input-context window x y stream)
cer's avatar
cer committed
  (frame-manager-display-pointer-documentation
    (frame-manager frame) frame presentation input-context window x y stream))

(defmethod frame-manager-display-pointer-documentation
	   ((framem standard-frame-manager)
	    frame presentation input-context window x y stream)
  (when stream
cer's avatar
cer committed
    ;; The documentation should never say anything if we're not over a presentation
    (when (null presentation) 
cer's avatar
cer committed
      (window-clear stream))
cer's avatar
cer committed
    ;; Cheap test to not do this work too often
    (let ((old-modifier-state *last-pointer-documentation-modifier-state*)
	  (modifier-state (window-modifier-state window))
	  (last-time *last-pointer-documentation-time*)
	  (time (get-internal-real-time)))
      (setq *last-pointer-documentation-modifier-state* modifier-state)
      (when (and (< time (+ last-time *pointer-documentation-interval*))
		 (= modifier-state old-modifier-state))
cer's avatar
cer committed
	(return-from frame-manager-display-pointer-documentation nil))
cer's avatar
cer committed
      (setq *last-pointer-documentation-time* time))
    (when presentation
      (with-output-recording-options (stream :record nil)
	(with-end-of-line-action (stream :allow)
	  (with-end-of-page-action (stream :allow)
	    (window-clear stream)
	    (when (null (frame-document-highlighted-presentation-1
			  frame presentation input-context window x y stream))
	      (setq *last-pointer-documentation-time* 0))
	    (force-output stream)))))))

(defun frame-document-highlighted-presentation-1
       (frame presentation input-context window x y stream)
  (let ((modifier-state (window-modifier-state window)))
cer's avatar
cer committed
    (declare (type fixnum modifier-state))
cer's avatar
cer committed
    (multiple-value-bind (left   left-presentation   left-context
			  middle middle-presentation middle-context
			  right  right-presentation  right-context)
cer's avatar
cer committed
	(find-applicable-translators-for-documentation presentation input-context
						       frame window x y modifier-state)
      (let* ((*print-length* 3)
	     (*print-level* 2)
	     (*print-circle* nil)
	     (*print-array* nil)
	     (*print-readably* nil)
	     (*print-pretty* nil))
cer's avatar
cer committed
	(flet ((document-translator (translator presentation context-type
				     button-name separator)
cer's avatar
cer committed
		 ;; Assumes 5 modifier keys and the reverse ordering of *MODIFIER-KEYS*
		 (let ((bit #o20)
		       (shift-name '("h-" "s-" "m-" "c-" "sh-")))
cer's avatar
cer committed
		   (declare (type fixnum bit))
cer's avatar
cer committed
		   (repeat 5			;length of shift-name
cer's avatar
cer committed
		     (unless (zerop (logand bit modifier-state))
		       (write-string (car shift-name) stream))
		     (pop shift-name)
		     (setq bit (the fixnum (ash bit -1)))))
		 (write-string button-name stream)
		 (document-presentation-translator translator presentation context-type
						   frame nil window x y
						   :stream stream
						   :documentation-type :pointer)
		 (write-string separator stream)))
	  (declare (dynamic-extent #'document-translator))
cer's avatar
cer committed
	  ;;--- The button names should be hard-wired in.  Consider 1-button
	  ;;--- Macs and 2-button PCs...
cer's avatar
cer committed
	  (when left
cer's avatar
cer committed
	    (let ((button-name (cond ((and (eq left middle)
					   (eq left right))
cer's avatar
cer committed
				      (setq middle nil
					    right nil)
				      "L,M,R: ")
cer's avatar
cer committed
				     ((eq left middle) 
cer's avatar
cer committed
				      (setq middle nil)
				      "L,M: ")
				     (t "L: "))))
cer's avatar
cer committed
	      (document-translator left left-presentation left-context
				   button-name (if (or middle right) "; " "."))))
cer's avatar
cer committed
	  (when middle
cer's avatar
cer committed
	    (let ((button-name (cond ((eq middle right)
cer's avatar
cer committed
				      (setq right nil)
				      "M,R: ")
				     (t "M: "))))
cer's avatar
cer committed
	      (document-translator middle middle-presentation middle-context
				   button-name (if right "; " "."))))
cer's avatar
cer committed
	  (when right
cer's avatar
cer committed
	    (document-translator right right-presentation right-context
				 "R: " "."))
cer's avatar
cer committed
	  ;; Return non-NIL if any pointer documentation was produced
	  (or left middle right))))))

;; This is derived directly from FIND-APPLICABLE-TRANSLATORS
(defun find-applicable-translators-for-documentation
       (presentation input-context frame window x y modifier-state)
  ;; Assume a maximum of three pointer buttons
cer's avatar
cer committed
  (let ((left nil)   (left-presentation nil)   (left-context nil)
	(middle nil) (middle-presentation nil) (middle-context nil)
	(right nil)  (right-presentation nil)  (right-context nil))
    (macrolet ((match (translator presentation context-type button)
		 (let* ((symbol (symbol-name button))
			(button-translator (intern symbol))
			(button-presentation (fintern "~A-~A" symbol 'presentation))
			(button-context (fintern "~A-~A" symbol 'context)))
cer's avatar
cer committed
		   `(when (and (or (null ,button-translator)
				   (> (presentation-translator-priority ,translator)
				      (presentation-translator-priority ,button-translator)))
			       (button-and-modifier-state-matches-gesture-name-p
				 (button-index ,button) modifier-state
				 (presentation-translator-gesture-name ,translator)))
		      (setq ,button-translator ,translator
cer's avatar
cer committed
			    ,button-presentation ,presentation
cer's avatar
cer committed
			    ,button-context ,context-type)))))
      (do ((presentation presentation
			 (parent-presentation-with-shared-box presentation window)))
	  ((null presentation))
	(let ((from-type (presentation-type presentation)))
	  (dolist (context input-context)
	    (let ((context-type (pop context)))	;input-context-type = first
	      (let ((translators (find-presentation-translators 
				   from-type context-type (frame-command-table frame))))
		(when translators
		  (dolist (translator translators)
		    (when (test-presentation-translator translator
							presentation context-type
							frame window x y
							:modifier-state modifier-state)
cer's avatar
cer committed
		      (match translator presentation context-type :left)
		      (match translator presentation context-type :middle)
		      (match translator presentation context-type :right)))))
cer's avatar
cer committed
	      (when (and (or left middle right)
			 *presentation-menu-translator*
			 (test-presentation-translator *presentation-menu-translator*
						       presentation context-type
						       frame window x y
						       :modifier-state modifier-state))
cer's avatar
cer committed
		(match *presentation-menu-translator* presentation context-type :left)
		(match *presentation-menu-translator* presentation context-type :middle)
		(match *presentation-menu-translator* presentation context-type :right)))))))
    (values left   left-presentation   left-context
	    middle middle-presentation middle-context
	    right  right-presentation  right-context)))
cer's avatar
cer committed


cer's avatar
cer committed
(defmethod raise-frame ((frame standard-application-frame))
  (raise-sheet (frame-top-level-sheet frame)))

(defmethod bury-frame ((frame standard-application-frame))
  (bury-sheet (frame-top-level-sheet frame)))

cer's avatar
cer committed