core: implement missing operators for presentation highlight

SET-HIGHLIGHTED-PRESENTATION and UNHIGHLIGHT-HIGHLIGHTED-PRESENTATION
This also encapsulates uses of the accessor FRAME-HIGHLITED-PRESENTATION.

2 files changed, 41 insertions, 20 deletions

diff --git a/Core/clim-core/frames/frames.lisp b/Core/clim-core/frames/frames.lisp
index f411ff2f..c52764c0 100644
--- a/Core/clim-core/frames/frames.lisp
+++ b/Core/clim-core/frames/frames.lisp
@@ -445,7 +445,7 @@
         (multiple-value-bind (redisplayp clearp)
             (pane-needs-redisplay pane-object)
           (when (or force-p clearp)
-            (setf (frame-highlited-presentation frame) nil))
+            (unhighlight-highlighted-presentation pane))
           (when (or force-p redisplayp)
             (do-redisplay-pane pane-object #'call-next-method clearp)
             (unless (or (eq redisplayp :command-loop) (eq redisplayp :no-clear))
@@ -849,20 +849,7 @@ frames and will not have focus.
                        x y
                        :frame frame
                        :modifier-state modifier)))
-    (when (and (frame-highlited-presentation frame)
-               (not (eq presentation
-                        (car (frame-highlited-presentation frame)))))
-      (highlight-presentation-1 (car (frame-highlited-presentation frame))
-                                (cdr (frame-highlited-presentation frame))
-                                :unhighlight)
-      (setf (frame-highlited-presentation frame) nil))
-    (when (and presentation
-               (not (eq presentation
-                        (car (frame-highlited-presentation frame)))))
-      (setf (frame-highlited-presentation frame)
-            (cons presentation stream))
-      (highlight-presentation-1 presentation stream :highlight))
-    presentation))
+    (set-highlighted-presentation stream presentation)))
 
 (defmethod frame-input-context-track-pointer :before
     ((frame standard-application-frame) input-context
diff --git a/Core/clim-core/presentations/translators.lisp b/Core/clim-core/presentations/translators.lisp
index 23cab011..bc044292 100644
--- a/Core/clim-core/presentations/translators.lisp
+++ b/Core/clim-core/presentations/translators.lisp
@@ -729,6 +729,45 @@ a presentation"
                   :modifier-state 0
                   :button +pointer-left-button+)))
 
+(defun set-highlighted-presentation
+    (stream presentation &optional (prefer-pointer-window t))
+  (declare (ignore prefer-pointer-window))
+  (let* ((frame (pane-frame stream))
+         (highl (frame-highlited-presentation frame))
+         (highlighted-presentation (car highl))
+         (highlighted-stream (cdr highl))
+         (same-presentation-p (eq presentation highlighted-presentation))
+         (unhighlight-p (and highlighted-presentation (not same-presentation-p)))
+         (rehighlight-p (and presentation (not same-presentation-p))))
+    (flet ((highlight (record sheet state)
+             (funcall-presentation-generic-function highlight-presentation
+                                                    (presentation-type record)
+                                                    record sheet state)))
+      (when (or unhighlight-p rehighlight-p)
+        (with-output-recording-options (stream :record nil)
+          (when unhighlight-p
+            (highlight highlighted-presentation highlighted-stream :unhighlight))
+          (when rehighlight-p
+            (highlight presentation stream :highlight)))
+        (setf (frame-highlited-presentation frame)
+              (and presentation (cons presentation stream))))))
+  presentation)
+
+(defun unhighlight-highlighted-presentation
+    (stream &optional (prefer-pointer-window t))
+  (declare (ignore prefer-pointer-window))
+  (when-let* ((frame (pane-frame stream))
+              (highl (frame-highlited-presentation frame)))
+    (setf (frame-highlited-presentation frame) nil)
+    (destructuring-bind (presentation . stream) highl
+      (with-output-recording-options (stream :record nil)
+        (funcall-presentation-generic-function highlight-presentation
+                                               (presentation-type presentation)
+                                               presentation
+                                               stream
+                                               :unhighlight))))
+  nil)
+
 (defun highlight-current-presentation (frame input-context)
   (when-let* ((port (port frame))
               (port-pointer (port-pointer port))
@@ -741,8 +780,3 @@ a presentation"
   (when (or prefer-pointer-window
             (eq stream (pointer-sheet (port-pointer (port frame)))))
     (highlight-current-presentation frame input-context)))
-
-;;; FIXME missing functions
-;;;
-;;; set-highlighted-presentation
-;;; unhighlight-highlighted-presentation