Newer
Older
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)))
(multiple-value-bind (left left-presentation left-context
middle middle-presentation middle-context
right right-presentation right-context)
(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-name separator)
;; Assumes 5 modifier keys and the reverse ordering of *MODIFIER-KEYS*
(let ((bit #o20)
(shift-name '("h-" "s-" "m-" "c-" "sh-")))
(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))
;;--- The button names should be hard-wired in. Consider 1-button
;;--- Macs and 2-button PCs...
(let ((button-name (cond ((and (eq left middle)
(eq left right))
(document-translator left left-presentation left-context
button-name (if (or middle right) "; " "."))))
(document-translator middle middle-presentation middle-context
button-name (if right "; " "."))))
(document-translator right right-presentation right-context
"R: " "."))
;; 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
(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)))
`(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
,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)
(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)))))))
(values left left-presentation left-context
middle middle-presentation middle-context
right right-presentation right-context)))