[mcclim-cvs] CVS mcclim/ESA

[thenriksen]

Update of /project/mcclim/cvsroot/mcclim/ESA
In directory clnet:/tmp/cvs-serv7171/ESA

Modified Files:
	esa.lisp 
Log Message:
Improved the ESA minibuffer - can now resize itself if necessary and
doesn't flicker.


--- /project/mcclim/cvsroot/mcclim/ESA/esa.lisp	2008/05/01 06:48:22	1.23
+++ /project/mcclim/cvsroot/mcclim/ESA/esa.lisp	2008/05/17 21:25:35	1.24
@@ -106,30 +106,45 @@
 current message was set."))
   (:default-initargs
    :scroll-bars nil
-    :display-function 'display-minibuffer
-    :display-time :no-clear
-    :incremental-redisplay t))
+   :display-function 'display-minibuffer
+   :display-time :command-loop
+   :incremental-redisplay t))
+
+(defmethod handle-repaint ((pane minibuffer-pane) region)
+  (when (and (message pane)
+             (> (get-universal-time)
+                (+ *minimum-message-time* (message-time pane))))
+    (window-clear pane)
+    (setf (message pane) nil))
+  (call-next-method))
+
+(defmethod (setf message) :after (new-value (pane minibuffer-pane))
+  (change-space-requirements pane))
+
+(defmethod pane-needs-redisplay ((pane minibuffer-pane))
+  ;; Always call the display function, never clear the window. This
+  ;; allows us to time-out the message in the minibuffer.
+  (values t nil))
 
-(defmethod stream-accept :before ((pane minibuffer-pane) type &rest args)
-  (declare (ignore type args))
-  (window-clear pane)
-  (when (message pane)
-    (setf (message pane) nil)
-    ;; FIXME: If we do not redisplay here, the area occupied by the
-    ;; message will be blanked with a white rectangle at the first
-    ;; keystroke.
-    (redisplay-frame-pane (pane-frame pane) pane)))
+(defun display-minibuffer (frame pane)
+  (declare (ignore frame))
+  (handle-repaint pane +everywhere+))
 
 (defmethod stream-accept :around ((pane minibuffer-pane) type &rest args)
   (declare (ignore args))
+  (when (message pane)
+    (setf (message pane) nil))
+  (window-clear pane)
   ;; FIXME: this isn't the friendliest way of indicating a parse
   ;; error: there's no feedback, unlike emacs' quite nice "[no
   ;; match]".
-  (loop
-   (handler-case
-       (with-input-focus (pane)
-         (return (call-next-method)))
-     (parse-error () nil))))
+  (unwind-protect
+       (loop
+        (handler-case
+            (with-input-focus (pane)
+              (return (call-next-method)))
+          (parse-error () nil)))
+    (window-clear pane)))
 
 (defmethod stream-accept ((pane minibuffer-pane) type &rest args
                           &key (view (stream-default-view pane))
@@ -139,6 +154,21 @@
   ;; but we need to turn some of ACCEPT-1 off.
   (apply #'accept-1-for-minibuffer pane type args))
 
+(defmethod compose-space ((pane minibuffer-pane) &key width height)
+  (declare (ignore width height))
+  (with-sheet-medium (medium pane)
+    (let* ((sr (call-next-method))
+           (height (max (text-style-height (medium-merged-text-style medium)
+                                           medium)
+                        (if (message pane)
+                            (bounding-rectangle-height (message pane))
+                            0))))
+      (make-space-requirement
+       :height height :min-height height :max-height height
+       :width (space-requirement-width sr)
+       :min-width (space-requirement-min-width sr)
+       :max-width (space-requirement-max-width sr)))))
+
 ;;; simpler version of McCLIM's internal operators of the same names:
 ;;; HANDLE-EMPTY-INPUT to make default processing work, EMPTY-INPUT-P
 ;;; and INVOKE-HANDLE-EMPTY-INPUT to support it.  We don't support
@@ -288,24 +318,15 @@
           stream object object-type view :rescan nil))
        (values object object-type)))))
 
-(defun display-minibuffer (frame pane)
-  (declare (ignore frame))
-  (if (message pane)
-      (if (> (get-universal-time)
-             (+ *minimum-message-time* (message-time pane)))
-          (setf (message pane) nil)
-          (replay-output-record (message pane) pane))
-      ;; Even if there isn't a message, someone else might still have
-      ;; scribbled in the pane. We shouldn't disappoint them.
-      (replay (stream-output-history pane) pane)))
-
 (defgeneric invoke-with-minibuffer-stream (minibuffer continuation))
 
 (defmethod invoke-with-minibuffer-stream ((minibuffer minibuffer-pane) continuation)
+  (window-clear minibuffer)
   (setf (message minibuffer)
-        (with-output-to-output-record (minibuffer)
+        (with-new-output-record (minibuffer)
           (setf (message-time minibuffer) (get-universal-time))
-          (funcall continuation minibuffer))))
+          (filling-output (minibuffer :fill-width (bounding-rectangle-width minibuffer))
+            (funcall continuation minibuffer)))))
 
 (defmethod invoke-with-minibuffer-stream ((minibuffer pointer-documentation-pane) continuation)
   (clim-extensions:with-output-to-pointer-documentation (stream (pane-frame minibuffer))
@@ -900,7 +921,7 @@
                                 ;; for presentation-to-command-translators,
                                 ;; which are searched for in
                                 ;; (frame-command-table *application-frame*)
-                                (redisplay-frame-pane ,frame (frame-standard-input ,frame) :force-p t)
+                                (redisplay-frame-pane ,frame (frame-standard-input ,frame))
                                 (setf (frame-command-table ,frame) command-table)
                                 (process-gestures-or-command ,frame))
                             (unbound-gesture-sequence (c)