Newer
Older
(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))
(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))
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
(defmethod execute-command-in-frame ((frame standard-application-frame) command)
(distribute-event
(port frame)
(make-instance 'presentation-event
:frame frame
:sheet (frame-top-level-sheet frame)
:value command)))
(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)))))
(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
#'(lambda (c)
(return-from read-frame-command
(synchronous-command-event-command c)))))
(call-next-method)))))
;; Actually this should be treated as a command event
(defclass presentation-event (event)
((value :initarg :value :reader presentation-event-value)
(sheet :initarg :sheet :reader event-sheet)
(frame :initarg :frame :reader event-frame)
(presentation-type :initarg :presentation-type :reader event-presentation-type)))
(defmethod handle-event (sheet (event presentation-event))
(process-command-event sheet event))
(defun process-command-event (sheet event)
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
;; 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*
(make-instance 'pointer-button-press-event
:sheet sheet
:x 0
:y 0
:modifiers 0
:button 256))
(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,
(queue-frame-command (event-frame event) (presentation-event-value event))))))
(defun queue-frame-command (frame command)
(queue-push (frame-command-queue frame) command))
(defvar *pointer-documentation-interval*
(max (floor (* 1/10 internal-time-units-per-second)) 1))
(defvar *last-pointer-documentation-time* 0)
;;; Produce pointer documentation
(defmethod frame-document-highlighted-presentation
((frame standard-application-frame) presentation input-context window x y stream)
(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
;; The documentation should never say anything if we're not over a presentation
(when (null presentation)
;; 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))
(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)))
(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)))