Skip to content
Snippets Groups Projects
frames.lisp 76.9 KiB
Newer Older
;; Sizes an application frame based on the size of the contents of the
cer's avatar
cer committed
;; output recording stream STREAM.
(defun size-frame-from-contents (stream
                                  &key width height
                                       (right-margin 10) (bottom-margin 10)
                                       (size-setter #'window-set-inside-size))
cer's avatar
cer committed
  (with-slots (output-record) stream
    (with-bounding-rectangle* (left top right bottom) output-record
      (let* ((graft (or (graft stream)
                        (find-graft)))                ;--- is this right?
             (gw (bounding-rectangle-width (sheet-region graft)))
             (gh (bounding-rectangle-height (sheet-region graft)))
             ;;--- Does this need to account for the size of window decorations?
             (width (min gw (+ (or width (- right left)) right-margin)))
             (height (min gh (+ (or height (- bottom top)) bottom-margin))))
        ;; The size-setter will typically resize the entire frame
        (funcall size-setter stream width height)
        (window-set-viewport-position stream left top)))))
cer's avatar
cer committed

;; Moves the sheet to the specified position, taking care not to move
;; it outside of the graft.  It's safest to use this on a top-level sheet.
(defun position-sheet-carefully (sheet x y)
  (multiple-value-bind (width height) (bounding-rectangle-size sheet)
    (multiple-value-bind (graft-width graft-height)
        (bounding-rectangle-size (or (graft sheet) (find-graft)))
cer's avatar
cer committed
      (let* ((left x)
             (top y)
             (right (+ left width))
             (bottom (+ top height)))
        (when (> right graft-width)
          (setq left (- graft-width width)))
        (when (> bottom graft-height)
          (setq top (- graft-height height)))
        (port-move-frame (port sheet) (pane-frame sheet) 
			 (max 0 left) (max 0 top))))))
cer's avatar
 
cer committed

(defmethod port-move-frame ((port basic-port) frame x y)
  (move-sheet (frame-top-level-sheet frame) x y))
cer's avatar
cer committed

;; Moves the sheet to be near where the pointer is.  It's safest to use this
;; on a top-level sheet.
(defun position-sheet-near-pointer (sheet &optional x y)
  (unless (and x y)
    (multiple-value-setq (x y)
      (pointer-position (port-pointer (port sheet)))))
cer's avatar
cer committed
  (position-sheet-carefully sheet x y))

cer's avatar
cer committed

cer's avatar
cer committed
(defun display-title (frame stream &key max-width max-height)
  (declare (ignore max-width max-height))
  (with-slots (display-string) stream
    (let ((title display-string))
      (when (and (stringp title)
                 (not (string-equal title (frame-pretty-name frame))))
        ;; On some hosts this will update the title bar
        (setf (frame-pretty-name frame) title))
cer's avatar
cer committed
      (multiple-value-bind (width height)
          (window-inside-size stream)
        (draw-text* stream (or title (frame-pretty-name frame))
                    (/ width 2) (/ height 2)
                    :align-x :center :align-y :center)))))
cer's avatar
cer committed

cer's avatar
cer committed
(defun title-capitalize (string)
  (let ((new-string (substitute #\Space #\- string)))
    (when (eq new-string string)
      (setq new-string (copy-seq new-string)))
    (nstring-capitalize new-string)))

cer's avatar
cer committed
(defun display-command-menu (frame stream &rest keys
                             &key command-table max-width max-height &allow-other-keys)
cer's avatar
cer committed
  (declare (dynamic-extent keys)
           (ignore max-width max-height))
cer's avatar
cer committed
  (when (or (null command-table)
cer's avatar
cer committed
    (setq command-table (frame-command-table frame)))
cer's avatar
cer committed
  (setq command-table (find-command-table command-table))
cer's avatar
cer committed
  (with-keywords-removed (keys keys '(:command-table))
cer's avatar
cer committed
    (if (slot-value stream 'incremental-redisplay-p)
        (apply #'display-command-menu-1 stream command-table keys)
        (apply #'display-command-table-menu command-table stream keys))))
cer's avatar
cer committed

;; Split out to avoid consing unnecessary closure environments.
(defun display-command-menu-1 (stream command-table &rest keys)
  (declare (dynamic-extent keys))
  (updating-output (stream :unique-id stream
                           :cache-value (slot-value command-table 'menu-tick))
cer's avatar
cer committed
    (apply #'display-command-table-menu command-table stream keys)))
cer's avatar
cer committed

cer's avatar
cer committed
(defmethod find-pane-named ((frame standard-application-frame) pane-name &optional (errorp t))
  (with-slots (all-panes) frame
    (cond ((second (assoc pane-name all-panes)))
          (errorp (error "There is no pane named ~S in frame ~S" pane-name frame)))))
cer's avatar
cer committed

cer's avatar
 
cer committed


cer's avatar
cer committed
;; The contract of GET-FRAME-PANE is to get a pane upon which we can do normal
;; I/O operations, that is, a CLIM stream pane
cer's avatar
cer committed
(defmethod get-frame-pane ((frame standard-application-frame) pane-name &key (errorp t))
  (with-slots (all-panes) frame
    (let ((pane (assoc pane-name all-panes)))
      (when pane
        (map-over-sheets #'(lambda (sheet)
                             (when (typep sheet 'clim-stream-pane)
                               (return-from get-frame-pane sheet)))
                         (second pane)))
cer's avatar
cer committed
      (when errorp
        (error "There is no CLIM stream pane named ~S in frame ~S" pane-name frame)))))
cer's avatar
cer committed

#+ignore
(defmethod pane-name ((pane basic-pane))
  (let ((frame (pane-frame pane)))
    (and frame
         (dolist (name-and-pane (slot-value frame 'all-panes))
           (destructuring-bind (name apane) name-and-pane
             (when (sheet-ancestor-p pane apane)
               (return name)))))))
cer's avatar
 
cer committed
(defmethod frame-current-panes ((frame standard-application-frame))
  (let ((panes nil)
cer's avatar
 
cer committed
    (when top
      (map-over-sheets #'(lambda (sheet)
                           (when (panep sheet)
                             (push sheet panes)))
                       top))
cer's avatar
 
cer committed
    panes))

cer's avatar
cer committed
(defmethod redisplay-frame-panes ((frame standard-application-frame) &key force-p)
cer's avatar
cer committed
  ;; First display all the :accept-values panes, then display the rest.
  ;; We do this to ensure that all side-effects from :accept-values panes
  ;; have taken place.
  (when *frame-layout-changing-p* (setq force-p t))
cer's avatar
cer committed
  (map-over-sheets #'(lambda (sheet)
                       (when (typep sheet 'accept-values-pane)
                         (redisplay-frame-pane frame sheet :force-p force-p)))
                   (frame-top-level-sheet frame))
cer's avatar
cer committed
  (map-over-sheets #'(lambda (sheet)
                       (when (and (typep sheet 'clim-stream-pane)
                                  (not (typep sheet 'accept-values-pane)))
                         (redisplay-frame-pane frame sheet :force-p force-p)))
                   (frame-top-level-sheet frame))
cer's avatar
cer committed
  ;; Once we've redisplayed everything, the layout is done changing
  (setq *frame-layout-changing-p* nil))
cer's avatar
cer committed

cer's avatar
cer committed
(defmethod redisplay-frame-pane ((frame standard-application-frame) pane &key force-p)
cer's avatar
cer committed
  (when (symbolp pane)
    (setq pane (get-frame-pane frame pane)))
cer's avatar
cer committed
  (let* ((display-function (pane-display-function pane))
         (ir (slot-value pane 'incremental-redisplay-p))
         (redisplay-p (if (listp ir) (first ir) ir))
         (check-overlapping (or (atom ir) ;default is T
                                (getf (rest ir) :check-overlapping
                                      t)))
         needs-display
         clear)
    (with-simple-restart (skip-pane-redisplay "Skip redisplaying pane ~S" pane)
cer's avatar
cer committed
      (loop
        (with-simple-restart (retry-pane-redisplay "Retry displaying pane ~S" pane)
	  #-moved ;; pr Aug97
	  (when *frame-layout-changing-p*
            (setq force-p t))
          (unless *sizing-application-frame*
            (unless (member pane (slot-value frame 'initialized-panes))
              (setq force-p t)
              (push pane (slot-value frame 'initialized-panes))))
          (return
            (cond (display-function
                   (cond

                    ;; display function with incremental redisplay
                    (redisplay-p
                     (let ((redisplay-record
                            (let ((history (stream-output-history pane)))
                              (when history
                                #+compulsive-redisplay
                                (when (> (output-record-count history :fastp t) 1)
                                  (cerror "Clear the output history and proceed"
                                          "There is more than one element in this redisplay pane")
                                  (window-clear pane))
                                (unless (zerop (output-record-count history :fastp t))
                                  (output-record-element history 0))))))
                       (cond ((or (null redisplay-record) force-p)
                              (when force-p
                                (window-clear pane))
                              (invoke-pane-redisplay-function frame pane))
                             (t
                              (redisplay redisplay-record pane
                                         :check-overlapping check-overlapping)))))

                    ;; display function without incremental redisplay
                    ((or force-p (progn (multiple-value-setq (needs-display clear)
                                          (pane-needs-redisplay pane))
                                        needs-display))
                     (when (or force-p clear)
                       (window-clear pane))
                     (invoke-pane-display-function frame pane)))
                   (force-output pane))

                  ;; no display function
                  (force-p
                   ;; If refilling from scratch, give the application a chance
                   ;; to draw stuff
                   (frame-replay frame pane))
                  ;; Otherwise do nothing, the bits will still be on display
                  ;; and will be refreshed properly if there's a damage event.
                  )))))))
cer's avatar
cer committed

;; Factored out of the above to avoid consing closures
cer's avatar
cer committed
(defun invoke-pane-redisplay-function (frame pane &rest args)
cer's avatar
cer committed
  (declare (dynamic-extent args))
  (updating-output (pane)
    (apply #'invoke-pane-display-function frame pane args)))

(defun invoke-pane-display-function (frame pane &rest args)
cer's avatar
cer committed
  (declare (dynamic-extent args))
  (let* ((df (pane-display-function pane))
         (display-args (if (listp df) (rest df) nil))
         (display-function (if (listp df) (first df) df)))
cer's avatar
cer committed
    ;; Cons as little as possible...
    (cond ((and (null args) (null display-args))
           (funcall display-function frame pane))
          ((null display-args)
           (apply display-function frame pane args))
          ((null args)
           (apply display-function frame pane display-args))
          (t
           (apply display-function frame pane (append args display-args))))))
cer's avatar
cer committed
;;; The contract of this is to replay the contents of STREAM within the region.
(defmethod frame-replay ((frame standard-application-frame) stream &optional region)
cer's avatar
cer committed
  (when (null region)
    (setq region (or (pane-viewport-region stream) (sheet-region stream))))
cer's avatar
cer committed
  (stream-replay stream region)
  (force-output stream))


(defmethod read-frame-command ((frame standard-application-frame)
                               &key (stream *standard-input*)        ;--- FRAME-STANDARD-INPUT?
                               ;; should the rest of the *command-parser*
                               ;; etc. variables be passed as keywords or bound?
                               )
cer's avatar
cer committed
  (read-command (frame-command-table frame) :stream stream))
cer's avatar
cer committed

(defmacro with-menu-disabled (frame &body body)
  #-mswindows (declare (ignore frame))
  #-mswindows `(progn ,@body)
       (progn 
	 (disable-all-menu-items ,frame)
	 ,@body)
     (re-enable-menu-items ,frame)))

(defmethod execute-frame-command ((frame standard-application-frame) command)
  (apply (command-name command) (command-arguments command))
  #+ignore ;; from jeff on 4/8/99
  (with-menu-disabled frame
    (apply (command-name command) (command-arguments command))))

(defmethod execute-frame-command :around ((frame standard-application-frame) 
					  command)
cer's avatar
 
cer committed
  (let ((top-level-process (slot-value frame 'top-level-process))
    (if (or (and top-level-process
		 (eq top-level-process (current-process)))
	    (and (typep frame 'activity-frame)
		 (setq activity (frame-activity frame))
		 (eq (slot-value activity 'top-level-process)
		     (current-process))))
	;; If we're in the process for the frame, just execute the command
	;; Or the process for the frames activity
	(call-next-method)
      ;; Otherwise arrange to run the command in the frame's process
      (execute-command-in-frame frame command :queuep t))))
(defmethod command-defined-p ((frame standard-application-frame) command)
  (or (not (symbolp command))
      (fboundp command)))

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 (command-defined-p frame command-name)
             (not (member command-name disabled-commands))
             (command-accessible-in-command-table-p
               command-name (frame-command-table frame))))))
cer's avatar
cer committed

(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-disabled (frame-manager frame) frame command-name)))))
cer's avatar
cer committed

cer's avatar
cer committed
(define-condition synchronous-command-event ()
  ((command :initarg :command :reader synchronous-command-event-command)
   (echo :initarg :echo :reader synchronous-command-event-echo-p))
cer's avatar
cer committed
  (:report (lambda (condition stream)
             (format stream "Command event condition signalled for ~S"
		     (synchronous-command-event-command condition)))))
cer's avatar
cer committed

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)
  (initialize-for-command-reader (frame-manager frame) frame)
  (flet ((maybe-echo-command (command)
           (let ((ptype `(command :command-table ,(frame-command-table frame))))
             (when (eq *command-parser* #'command-line-command-parser)
               (present command ptype :stream *standard-input* 
			:allow-sensitive-inferiors nil))
             (when (frame-maintain-presentation-histories frame)
               (push-history-element (presentation-type-history ptype)
                                     (make-presentation-history-element 
				      :object command :type ptype))))))
    (let* ((command-and-options (queue-pop (frame-command-queue frame))))
      (if command-and-options
          (destructuring-bind (command &key echo) command-and-options
            (when echo (maybe-echo-command command))
            command)
        (handler-bind ((synchronous-command-event
                        #'(lambda (c)
                            (let ((command (synchronous-command-event-command c)))
                              (when (synchronous-command-event-echo-p c)
                                (maybe-echo-command command))
                              (return-from read-frame-command command)))))
          (let ((*reading-frame-command* t))
            (call-next-method)))))))
(defmethod initialize-for-command-reader ((frame-manager t) (frame t)) nil)

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)
     (echo :initarg :echo :initform t :reader presentation-event-echo-p)
cer's avatar
cer committed
     (presentation-type :initarg :presentation-type :reader event-presentation-type))
cer's avatar
cer committed
  (:default-initargs :presentation-type 'command))
cer's avatar
cer committed

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

;;;#+(or aclpc acl86win32)
;;;(eval-when (compile load eval)
;;;   ;;mm: 11Jan95 - this is defined later in  ???
;;;   (unless (ignore-errors (find-class 'activity-frame))
;;;      (defclass activity-frame () ())))
cer's avatar
cer committed
(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
          (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+))
        (let ((frame (event-frame event))
              (activity nil))
          (when (and *input-buffer-empty*
                     (or (eq *application-frame* frame)
                         (and (typep frame 'activity-frame)
                              (eq (frame-activity frame) *activity*)
                              (setq activity *activity*))))
            (signal 'synchronous-command-event
                    :echo (presentation-event-echo-p event)
                    :command command))
          ;; Perhaps if this results directly from a user action then either
          ;; we should do it right away, ie. lose the input buffer or beep if
          ;; it has to be deferred,
          (if (slot-value event 'queuep)
              (queue-frame-command (if activity (activity-active-frame activity) frame)
                                   (presentation-event-value event)
                                   (presentation-event-echo-p event))
              (beep sheet))))))
cer's avatar
cer committed

cer's avatar
 
cer committed
(defun command-callback (function &rest arguments)
  (cons #'(lambda (widget &rest args) (apply #'command-callback-1 function widget args)) arguments))

(defun command-callback-1 (function sheet &rest arguments)
  (let ((frame (pane-frame sheet)))
    (process-command-event
     sheet
     (make-instance 'presentation-event
                    :frame frame
                    :value (list* function sheet arguments)
                    :presentation-type `(command :command-table ,(frame-command-table frame))))))
(defun queue-frame-command (frame command &optional (echo t))
  (queue-push (frame-command-queue frame) (list command :echo echo)))
cer's avatar
cer committed

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

(defun make-command-timer (frame command
                           &key (delay 0) interval
                                (command-table (frame-command-table frame)))
cer's avatar
cer committed
  (flet ((queue-command-event (timer)
           (declare (ignore timer))
           (execute-command-in-frame
            frame command
            :echo  nil
            :queuep t
            :presentation-type `(command :command-table ,command-table))))
cer's avatar
cer committed
    (let ((timer (make-timer
                   :function #'queue-command-event
                   :delay delay :interval interval)))
cer's avatar
cer committed
      (add-timer timer)
cer's avatar
cer committed
      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
           ((frame standard-application-frame) input-context stream x y &key event)
cer's avatar
cer committed
  (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
           ((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*))
    #+allegro
cer's avatar
cer committed
    (when (and *click-outside-menu-handler*
                (output-recording-stream-p window)
                (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.
cer's avatar
cer committed
      (unhighlight-highlighted-presentation window nil))
    (throw-highlighted-presentation
cer's avatar
cer committed
      (or (and (output-recording-stream-p window)
               (frame-find-innermost-applicable-presentation
                 frame input-context window x y
                 :event button-press-event))
          *null-presentation*)
cer's avatar
cer committed
      input-context
      button-press-event)))

(defun find-frame-pane-of-type (frame type)
cer's avatar
cer committed
  (map-over-sheets #'(lambda (sheet)
                       (when (typep sheet type)
                         (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))
  (if (not (member '*standard-output* (slot-value frame 
						  'non-frame-stream-names)))
      (or 
       (find-frame-pane-of-type frame 'application-pane)
       (find-frame-pane-of-type frame 'interactor-pane))
      nil))
cer's avatar
cer committed

cer's avatar
cer committed
(defmethod frame-standard-input ((frame standard-application-frame))
  (if (not (member '*standard-input* (slot-value frame 
						  'non-frame-stream-names)))
      (or (find-frame-pane-of-type frame 'interactor-pane)
	  (frame-standard-output frame))))
  
cer's avatar
cer committed
(defmethod frame-query-io ((frame standard-application-frame))
  (if (not (member '*query-io* (slot-value frame 
					   'non-frame-stream-names)))
      (or (frame-standard-input frame)
	  (frame-standard-output frame))
      nil))
cer's avatar
cer committed

cer's avatar
cer committed
(defmethod frame-error-output ((frame standard-application-frame))
  (if (not (member '*error-output* (slot-value frame
					       'non-frame-stream-names)))
      (frame-standard-output frame)
      nil))
cer's avatar
cer committed

cer's avatar
cer committed
(defmethod frame-pointer-documentation-output ((frame standard-application-frame))
  (if (not (member '*pointer-documentation-output* 
		   (slot-value frame 'non-frame-stream-names)))
      (find-frame-pane-of-type frame 'pointer-documentation-pane)
      nil))
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

(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*
    #-makes-things-fail 0
    #+makes-things-fail
    (max (floor (* 1/10 internal-time-units-per-second)) 1))

(setq *pointer-documentation-interval* 0)
cer's avatar
cer committed
(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)
  (let ((frame-manager (frame-manager frame)))
    #+(or aclpc acl86win32)
    (unless frame-manager
      (setq frame (pane-frame window))
      (setq frame-manager (or (frame-manager frame)(find-frame-manager))))
    (frame-manager-display-pointer-documentation
     frame-manager frame presentation input-context window x y stream)))

(defmethod frame-manager-pointer-documentation-stream 
           ((framem standard-frame-manager) frame stream)
cer's avatar
cer committed
  (declare (ignore frame))
  stream)

(defmethod frame-manager-display-pointer-documentation
	   ((framem standard-frame-manager)
	    frame presentation input-context window x y stream)
  (let ((stream (frame-manager-pointer-documentation-stream framem frame stream)))
    (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)))))))

cer's avatar
cer committed
(defmethod frame-manager-display-pointer-documentation :around
cer's avatar
cer committed
	   ((framem standard-frame-manager)
	    frame presentation input-context window x y stream)
  (declare (ignore x y input-context))
cer's avatar
cer committed
  (when (frame-manager-pointer-documentation-stream framem frame 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
      (frame-manager-display-pointer-documentation-string
	framem frame stream nil))
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))
cer's avatar
cer committed
    (call-next-method)))

(defmethod frame-manager-display-pointer-documentation-string 
cer's avatar
cer committed
	   ((framem standard-frame-manager) frame stream string)
  (let ((stream (frame-manager-pointer-documentation-stream framem frame stream)))
    (when stream
      (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 string
	      (write-string string stream))))))))
cer's avatar
cer committed

(defmethod frame-pointer-button-documentation
    ((frame standard-application-frame) button)
  (case button
    (:left "L")
    (:middle "M")
    (:right "R")))

(defmethod frame-modifier-key-documentation
    ((frame standard-application-frame) modifier)
  (case modifier
    (:shift "sh")
    (:control "c")
    (:meta "m")
    (:super "s")
    (:hyper "h")
    (:double "dbl")))
cer's avatar
cer committed
(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)
layer's avatar
layer 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))
        (flet ((document-translator (translator presentation context-type
                                     button-names separator)
layer's avatar
layer committed
                 ;; Assumes 6 modifier keys and the reverse ordering of
*modifier-keys*
layer's avatar
layer committed
                 (let ((bit #b100000)
                       (shift-name '(:double :hyper :super :meta :control
:shift)))
                   (repeat 6                ;length of shift-name
                           (unless (zerop (logand bit modifier-state))
                             (write-string
                              (frame-modifier-key-documentation frame
layer's avatar
layer committed
                                                                (car
shift-name))
                              stream)
                             (write-string "-" stream))
                           (pop shift-name)
                           (setq bit (the fixnum (ash bit -1)))))
                 (write-string
layer's avatar
layer committed
                  (frame-pointer-button-documentation frame (car
button-names))
                  stream)
                 (dolist (button-name (cdr button-names))
                   (write-string "," stream)
                   (write-string
                    (frame-pointer-button-documentation frame button-name)
                    stream))
                 (write-string ": " stream)
layer's avatar
layer committed
                 (document-presentation-translator translator presentation
context-type
                                                   frame nil window x y
                                                   :stream stream
layer's avatar
layer committed
                                                   :documentation-type
:pointer)
                 (write-string separator stream)))
          (declare (dynamic-extent #'document-translator))
          ;;--- The button names should be hard-wired in.  Consider 1-button
          ;;--- Macs and 2-button PCs...
          (when left
            (let ((button-name (cond ((and (eq left middle)
                                           (eq left right))
                                      (setq middle nil
                                            right nil)
                                      '(:left :middle :right))
                                     ((eq left middle)
                                      (setq middle nil)
                                      '(:left :middle))
                                     (t '(:left)))))
              (document-translator left left-presentation left-context
layer's avatar
layer committed
                                   button-name (if (or middle right) "; "
"."))))
          (when middle
            (let ((button-name (cond ((eq middle right)
                                      (setq right nil)
                                      (list :middle :right))
                                     (t '(:middle)))))
              (document-translator middle middle-presentation middle-context
                                   button-name (if right "; " "."))))
          (when right
            (document-translator right right-presentation right-context
                                 '(:right) "."))
          ;; Return non-NIL if any pointer documentation was produced
          (or left middle right))))))
cer's avatar
cer committed

;; 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))
cer's avatar
cer committed
    (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)))
                   `(when (and (null ,button-translator)
                               (button-and-modifier-state-matches-gesture-name-p
                                 (button-index ,button) modifier-state
                                 (presentation-translator-gesture-name ,translator)))
                      (setq ,button-translator ,translator
                            ,button-presentation ,presentation
                            ,button-context ,context-type)))))
cer's avatar
cer committed
      (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)
                      (match translator presentation context-type :left)
                      (match translator presentation context-type :middle)
                      (match translator presentation context-type :right)))))
              (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))
                (match *presentation-menu-translator* presentation context-type :left)
                (match *presentation-menu-translator* presentation context-type :middle)
                (match *presentation-menu-translator* presentation context-type :right)))))))
cer's avatar
cer committed
    (values left   left-presentation   left-context
            middle middle-presentation middle-context
            right  right-presentation  right-context)))

(defmethod frame-menu-translator-documentation
    ((frame standard-application-frame))
  "Menu")