[mcclim-cvs] CVS mcclim
thenriksen
thenriksen at common-lisp.net
Sun Jan 27 22:24:08 UTC 2008
Update of /project/mcclim/cvsroot/mcclim
In directory clnet:/tmp/cvs-serv28193
Modified Files:
frames.lisp package.lisp panes.lisp
Log Message:
Added some amazing hacks to pointer-documentation-panes for the notion of a "background message".
This is the beginning of extending pointer-documentation-panes into
more generally useful minibuffer-like panes.
For now, this just means that the Listener shows arglists and other
things for Drei commands. It's still a little flickery, though.
--- /project/mcclim/cvsroot/mcclim/frames.lisp 2008/01/22 08:51:02 1.129
+++ /project/mcclim/cvsroot/mcclim/frames.lisp 2008/01/27 22:24:07 1.130
@@ -1115,6 +1115,15 @@
(declare (ignore input-context stream))
(equal old-state new-state))
+(defun record-on-display (stream record)
+ "Return true if `record' is part of the output history of
+`stream', false otherwise."
+ (labels ((worker (record)
+ (or (eq record (stream-output-history stream))
+ (and (not (null (output-record-parent record)))
+ (worker (output-record-parent record))))))
+ (worker record)))
+
(defgeneric frame-print-pointer-documentation
(frame input-context stream state event))
@@ -1127,71 +1136,82 @@
(let ((x (device-event-x event))
(y (device-event-y event))
(pstream *pointer-documentation-output*))
- (loop for (button presentation translator context)
- in new-translators
- for name = (cadr (assoc button +button-documentation+))
- for first-one = t then nil
- do (progn
- (unless first-one
- (write-string "; " pstream))
- (unless (zerop current-modifier)
- (print-modifiers pstream current-modifier :short)
- (write-string "-" pstream))
- (format pstream "~A: " name)
- (document-presentation-translator translator
- presentation
- (input-context-type context)
- *application-frame*
- event
- stream
- x y
- :stream pstream
- :documentation-type
- :pointer))
- finally (when new-translators
- (write-char #\. pstream)))
+ (if (null new-translators)
+ (when (and (background-message pstream)
+ (not (record-on-display pstream (background-message pstream))))
+ (cond ((> (get-universal-time)
+ (+ (background-message-time pstream)
+ *background-message-minimum-lifetime*))
+ (setf (background-message pstream) nil))
+ (t
+ (setf (output-record-parent (background-message pstream)) nil)
+ (stream-add-output-record pstream (background-message pstream))
+ (replay (background-message pstream) pstream))))
+ (loop for (button presentation translator context)
+ in new-translators
+ for name = (cadr (assoc button +button-documentation+))
+ for first-one = t then nil
+ do (progn
+ (unless first-one
+ (write-string "; " pstream))
+ (unless (zerop current-modifier)
+ (print-modifiers pstream current-modifier :short)
+ (write-string "-" pstream))
+ (format pstream "~A: " name)
+ (document-presentation-translator translator
+ presentation
+ (input-context-type context)
+ *application-frame*
+ event
+ stream
+ x y
+ :stream pstream
+ :documentation-type
+ :pointer))
+ finally (when new-translators
+ (write-char #\. pstream))))
;; Wasteful to do this after doing
;; find-innermost-presentation-context above... look at doing this
;; first and then doing the innermost test.
(let ((all-translators (find-applicable-translators
- (stream-output-history stream)
- input-context
- *application-frame*
- stream
- x y
- :for-menu t))
- (other-modifiers nil))
- (loop for (translator) in all-translators
- for gesture = (gesture translator)
- unless (eq gesture t)
- do (loop for (name type modifier) in gesture
- unless (eql modifier current-modifier)
- do (pushnew modifier other-modifiers)))
- (when other-modifiers
- (setf other-modifiers (sort other-modifiers #'cmp-modifiers))
- (terpri pstream)
- (write-string "To see other commands, press " pstream)
- (loop for modifier-tail on other-modifiers
- for (modifier) = modifier-tail
- for count from 0
- do (progn
- (if (null (cdr modifier-tail))
- (progn
- (when (> count 1)
- (write-char #\, pstream))
- (when (> count 0)
- (write-string " or " pstream)))
- (when (> count 0)
- (write-string ", " pstream)))
- (print-modifiers pstream modifier :long)))
- (write-char #\. pstream))))))
+ (stream-output-history stream)
+ input-context
+ *application-frame*
+ stream
+ x y
+ :for-menu t))
+ (other-modifiers nil))
+ (loop for (translator) in all-translators
+ for gesture = (gesture translator)
+ unless (eq gesture t)
+ do (loop for (name type modifier) in gesture
+ unless (eql modifier current-modifier)
+ do (pushnew modifier other-modifiers)))
+ (when other-modifiers
+ (setf other-modifiers (sort other-modifiers #'cmp-modifiers))
+ (terpri pstream)
+ (write-string "To see other commands, press " pstream)
+ (loop for modifier-tail on other-modifiers
+ for (modifier) = modifier-tail
+ for count from 0
+ do (progn
+ (if (null (cdr modifier-tail))
+ (progn
+ (when (> count 1)
+ (write-char #\, pstream))
+ (when (> count 0)
+ (write-string " or " pstream)))
+ (when (> count 0)
+ (write-string ", " pstream)))
+ (print-modifiers pstream modifier :long)))
+ (write-char #\. pstream))))))
(defmethod frame-update-pointer-documentation
((frame standard-application-frame) input-context stream event)
(when *pointer-documentation-output*
(with-accessors ((frame-documentation-state frame-documentation-state)
(documentation-record documentation-record))
- frame
+ frame
(setf frame-documentation-state
(frame-compute-pointer-documentation-state frame
input-context
@@ -1206,63 +1226,55 @@
(%event% event))
(declare (special %input-context% %stream% %doc-state% %event&))
(if (and documentation-record
- (output-record-parent documentation-record))
+ (output-record-parent documentation-record))
(redisplay documentation-record *pointer-documentation-output*)
(progn
- (window-clear *pointer-documentation-output*)
+ (window-clear *pointer-documentation-output*)
(setf documentation-record
- (updating-output (*pointer-documentation-output*)
- (updating-output (*pointer-documentation-output*
- :cache-value %doc-state%
- :cache-test
- #'equal)
- (frame-print-pointer-documentation frame
- %input-context%
- %stream%
- %doc-state%
- %event%))))))))))
-
-#-(and)
-(defmethod frame-update-pointer-documentation
- ((frame standard-application-frame) input-context stream event)
- (when *pointer-documentation-output*
- (with-accessors ((frame-documentation-state frame-documentation-state))
- frame
- (let ((new-state (frame-compute-pointer-documentation-state frame
- input-context
- stream
- event)))
- (unless (frame-compare-pointer-documentation-state
- frame
- input-context
- stream
- frame-documentation-state
- new-state)
- (window-clear *pointer-documentation-output*)
- (frame-print-pointer-documentation frame
- input-context
- stream
- new-state
- event)
- (setq frame-documentation-state new-state))))))
+ (updating-output (*pointer-documentation-output*)
+ (updating-output (*pointer-documentation-output*
+ :cache-value %doc-state%
+ :cache-test #'equal)
+ (frame-print-pointer-documentation frame
+ %input-context%
+ %stream%
+ %doc-state%
+ %event%))))))))))
+
+(defgeneric invoke-with-output-to-pointer-documentation (frame continuation)
+ (:documentation "Invoke `continuation' with a single argument -
+a stream that the continuation can write to, the output of which
+will be used as the background message of the pointer
+documentation pane of `frame'. If the pointer-documentation of
+`frame' is not a `pointer-documentation-pane', `continuation'
+will not be called."))
+
+(defmethod invoke-with-output-to-pointer-documentation
+ ((frame standard-application-frame) continuation)
+ (with-accessors ((pointer-documentation frame-pointer-documentation-output)) frame
+ (when (typep pointer-documentation 'pointer-documentation-pane)
+ (setf (background-message pointer-documentation)
+ (with-output-to-output-record (pointer-documentation)
+ (funcall continuation pointer-documentation))
+ (background-message-time pointer-documentation) (get-universal-time)))))
+
+(defmacro with-output-to-pointer-documentation ((stream frame) &body body)
+ "Bind `stream' to the pointer-documentation pane of `frame' and
+capture the output of `body' on `stream' as the background
+message of the pointer documentation pane. If `frame' does not
+have a `pointer-documentation-pane' as pointer documentation,
+`body' will not be evaluated."
+ `(invoke-with-output-to-pointer-documentation
+ ,frame #'(lambda (,stream)
+ , at body)))
;;; A hook for applications to draw random strings in the
;;; *pointer-documentation-output* without screwing up the real pointer
;;; documentation too badly.
-(defgeneric frame-display-pointer-documentation-string
- (frame documentation-stream string))
-
-(defmethod frame-display-pointer-documentation-string
- ((frame standard-application-frame) documentation-stream string)
- (when *pointer-documentation-output*
- (with-accessors ((frame-documentation-state frame-documentation-state))
- frame
- (unless (frame-compare-pointer-documentation-state
- frame nil documentation-stream frame-documentation-state string)
- (window-clear documentation-stream)
- (write-string string documentation-stream)
- (setq frame-documentation-state string)))))
+(defun frame-display-pointer-documentation-string (frame string)
+ (with-output-to-pointer-documentation (stream frame)
+ (write-string string stream)))
(defmethod frame-input-context-track-pointer
((frame standard-application-frame)
--- /project/mcclim/cvsroot/mcclim/package.lisp 2008/01/12 11:04:05 1.64
+++ /project/mcclim/cvsroot/mcclim/package.lisp 2008/01/27 22:24:07 1.65
@@ -1935,6 +1935,8 @@
#:compose-space-aux
#:simple-event-loop
#:pointer-motion-hint-event
+ #:invoke-with-output-to-pointer-documentation
+ #:with-output-to-pointer-documentation
#:frame-display-pointer-documentation-string
#:list-pane-items
--- /project/mcclim/cvsroot/mcclim/panes.lisp 2008/01/01 23:23:07 1.186
+++ /project/mcclim/cvsroot/mcclim/panes.lisp 2008/01/27 22:24:07 1.187
@@ -27,7 +27,7 @@
;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;;; Boston, MA 02111-1307 USA.
-;;; $Id: panes.lisp,v 1.186 2008/01/01 23:23:07 thenriksen Exp $
+;;; $Id: panes.lisp,v 1.187 2008/01/27 22:24:07 thenriksen Exp $
(in-package :clim-internals)
@@ -2732,9 +2732,19 @@
(defparameter *default-pointer-documentation-background* +black+)
(defparameter *default-pointer-documentation-foreground* +white+)
+(defvar *background-message-minimum-lifetime* 1
+ "The amount of seconds a background message will be kept
+alive.")
(defclass pointer-documentation-pane (clim-stream-pane)
- ()
+ ((background-message :initform nil
+ :accessor background-message
+ :documentation "An output record, or NIL, that will
+be shown when there is no pointer documentation to show.")
+ (background-message-time :initform 0
+ :accessor background-message-time
+ :documentation "The universal time at which the
+current background message was set."))
(:default-initargs
:display-time nil
:scroll-bars nil
@@ -2748,6 +2758,12 @@
:end-of-line-action :allow
:end-of-page-action :allow))
+(defmethod stream-accept :before ((stream pointer-documentation-pane) type
+ &rest args)
+ (declare (ignore args))
+ (setf (background-message stream) nil)
+ (redisplay-frame-pane (pane-frame stream) stream :force-p t))
+
;;; CONSTRUCTORS
(defun make-clim-stream-pane (&rest options
More information about the Mcclim-cvs
mailing list