fix slider value display and 'plain option

collects/mred/private/wx/cocoa/queue.rkt

@@ -259,8 +259,7 @@
 
 (define (try-to-sync-refresh)
   (atomically
-   (pre-event-sync #t)
+   (pre-event-sync #t)))
-   (check-one-event #f #f)))
 
 ;; ------------------------------------------------------------
 ;; Install an alternate "sleep" function (in the PLT Scheme core)

collects/mred/private/wx/cocoa/slider.rkt

@@ -19,7 +19,7 @@
 
 ;; ----------------------------------------
 
-(import-class NSSlider)
+(import-class NSSlider NSTextField NSView)
 
 (define-objc-class MySlider NSSlider
   #:mixins (FocusResponder KeyMouseResponder CursorDisplayer)
@@ -27,6 +27,7 @@
   (-a _void (changed: [_id sender])
       (let ([wx (->wx wxb)])
         (when wx
+          (send wx update-message)
           (queue-window-event wx (lambda () (send wx changed)))
           (constrained-reply
            (send wx get-eventspace)
@@ -40,12 +41,14 @@
         x y w
         style
         font)
-  (inherit get-cocoa register-as-child)
+  (inherit get-cocoa register-as-child
+           init-font)
 
-  (super-new [parent parent]
+  (define vert? (memq 'vertical style))
-             [cocoa (let ([cocoa (as-objc-allocation
+
-                                  (tell (tell MySlider alloc) init))]
+  (define slider-cocoa
-                          [vert? (memq 'vertical style)])
+    (let ([cocoa (as-objc-allocation
+                  (tell (tell MySlider alloc) init))])
       (tellv cocoa setMinValue: #:type _double* lo)
       (tellv cocoa setMaxValue: #:type _double* hi)
       (tellv cocoa setDoubleValue: #:type _double* val)
@@ -56,15 +59,86 @@
                                              (make-NSSize (if vert? 24 32)
                                                           (if vert? 64 24))))
       (tellv cocoa setContinuous: #:type _BOOL #t)
-                      ; (tellv cocoa sizeToFit)
+      ;; (tellv cocoa sizeToFit)
-                      cocoa)]
+      cocoa))
+
+  (define-values (message-cocoa message-w message-h)
+    (if (memq 'plain style)
+        (values #f #f #f)
+        (let ([cocoa (as-objc-allocation
+                      (tell (tell NSTextField alloc) init))])
+          (init-font cocoa font)
+          (tellv cocoa setSelectable: #:type _BOOL #f)
+          (tellv cocoa setEditable: #:type _BOOL #f)
+          (tellv cocoa setBordered: #:type _BOOL #f)
+          (tellv cocoa setDrawsBackground: #:type _BOOL #f)
+          (tellv cocoa setTitleWithMnemonic: #:type _NSString (format "~a" hi))
+          (tellv cocoa sizeToFit)
+          (let ([r1 (tell #:type _NSRect cocoa frame)])
+            (tellv cocoa setTitleWithMnemonic: #:type _NSString (format "~a" lo))
+            (tellv cocoa sizeToFit)
+            (let ([r2 (tell #:type _NSRect cocoa frame)])
+              (tellv cocoa setTitleWithMnemonic: #:type _NSString (format "~a" val))
+              (values cocoa
+                      (max (NSSize-width (NSRect-size r1))
+                           (NSSize-width (NSRect-size r2)))
+                      (max (NSSize-height (NSRect-size r1))
+                           (NSSize-height (NSRect-size r2)))))))))
+
+  (define cocoa
+    (if message-cocoa
+        (let* ([f (tell #:type _NSRect slider-cocoa frame)]
+               [w (+ (if vert?
+                         message-w
+                         0)
+                     (NSSize-width (NSRect-size f)))]
+               [h (+ (if vert?
+                         0
+                         message-h)
+                     (NSSize-height (NSRect-size f)))])
+          (let ([cocoa (as-objc-allocation
+                        (tell (tell NSView alloc)
+                              initWithFrame: #:type _NSRect (make-NSRect 
+                                                             (make-init-point x y)
+                                                             (make-NSSize w h))))])
+            (tellv cocoa addSubview: slider-cocoa)
+            (tellv cocoa addSubview: message-cocoa)
+            (arrange-parts w h)
+            cocoa))
+        slider-cocoa))
+
+  (define/private (arrange-parts w h)
+    (tellv slider-cocoa setFrame: #:type _NSRect (make-NSRect
+                                                  (make-NSPoint 0
+                                                                (if vert? 0 message-h))
+                                                  (make-NSSize (- w (if vert? message-w 0))
+                                                               (- h (if vert? 0 message-h)))))
+    (tellv message-cocoa setFrame: #:type _NSRect (make-NSRect
+                                                   (make-NSPoint (if vert? 
+                                                                     (- w message-w)
+                                                                     (/ (- w message-w) 2))
+                                                                 (if vert?
+                                                                     (/ (- h message-h) 2)
+                                                                     0))
+                                                   (make-NSSize message-w message-h))))
+
+  (define/override (set-size x y w h)
+    (super set-size x y w h)
+    (when message-cocoa
+      (arrange-parts w h)))
+  
+  (when message-cocoa
+    (set-ivar! slider-cocoa wxb (->wxb this)))
+
+  (super-new [parent parent]
+             [cocoa cocoa]
              [callback cb]
              [no-show? (memq 'deleted style)])
 
-  (define cocoa (get-cocoa))
+  (define/override (get-cocoa-control) slider-cocoa)
 
-  (tellv cocoa setTarget: cocoa)
+  (tellv slider-cocoa setTarget: slider-cocoa)
-  (tellv cocoa setAction: #:type _SEL (selector changed:))
+  (tellv slider-cocoa setAction: #:type _SEL (selector changed:))
 
   (define callback cb)
   (define/public (changed)
@@ -74,9 +148,14 @@
 
 
   (define/public (set-value v)
-    (tellv cocoa setDoubleValue: #:type _double* v))
+    (atomically
+     (tellv slider-cocoa setDoubleValue: #:type _double* v)
+     (update-message v)))
   (define/public (get-value)
-    (inexact->exact (floor (tell #:type _double cocoa doubleValue))))
+    (inexact->exact (floor (tell #:type _double slider-cocoa doubleValue))))
+
+  (define/public (update-message [val (get-value)])
+    (tellv message-cocoa setTitleWithMnemonic: #:type _NSString (format "~a" val)))
 
   (define/override (maybe-register-as-child parent on?)
     (register-as-child parent on?)))

collects/mred/private/wx/gtk/slider.rkt

@@ -21,6 +21,7 @@
 (define-gtk gtk_range_set_increments (_fun _GtkWidget _double* _double* -> _void))
 (define-gtk gtk_range_set_value (_fun _GtkWidget _double* -> _void))
 (define-gtk gtk_range_get_value (_fun _GtkWidget -> _double))
+(define-gtk gtk_scale_set_draw_value (_fun _GtkWidget _gboolean -> _void))
 
 (define-signal-handler connect-changed "value-changed"
   (_fun _GtkWidget -> _void)
@@ -51,6 +52,9 @@
   (gtk_range_set_increments gtk 1.0 1.0)
   (gtk_range_set_value gtk val)
 
+  (when (memq 'plain style)
+    (gtk_scale_set_draw_value gtk #f))
+
   (set-auto-size)
 
   (connect-changed gtk)

collects/tests/gracket/item.rkt

@@ -1561,7 +1561,7 @@
   (instructions p "choice-list-steps.txt")
   (send f show #t))
 
-(define (slider-frame)
+(define (slider-frame style)
   (define f (make-frame frame% "Slider Test"))
   (define p (make-object vertical-panel% f))
   (define old-list null)
@@ -1570,7 +1570,8 @@
 			 (lambda (sl e)
 			   (check-callback-event s sl e commands #f)
 			   (printf "slid: ~a\n" (send s get-value)))
-			 3))
+			 3
+                         (cons 'horizontal style)))
   (define c (make-object button% "Check" p
 			 (lambda (c e)
 			   (for-each
@@ -2168,17 +2169,18 @@
 (send gsp stretchable-height #f)
 (make-object button% "Make Gauge Frame" gsp (lambda (b e) (gauge-frame)))
 (make-object vertical-pane% gsp) ; filler
-(make-object button% "Make Slider Frame" gsp (lambda (b e) (slider-frame)))
+(make-object button% "Make Slider Frame" gsp (lambda (b e) (slider-frame null)))
+(make-object button% "Make Plain Slider Frame" gsp (lambda (b e) (slider-frame '(plain))))
 (make-object vertical-pane% gsp) ; filler
 (make-object button% "Make Tab Panel" gsp (lambda (b e) (test-tab-panel #f)))
 (make-object button% "Make Tabs" gsp (lambda (b e) (test-tab-panel #t)))
-(make-object vertical-pane% gsp) ; filler
-(make-object button% "Make Modified Frame" gsp (lambda (b e) (test-modified-frame)))
 
 (define tp (make-object horizontal-pane% ap))
 (send tp stretchable-width #f)
 (make-object button% "Make Text Frame" tp (lambda (b e) (text-frame '(single))))
 (make-object button% "Make Multitext Frame" tp (lambda (b e) (text-frame '(multiple))))
+(make-object vertical-pane% tp) ; filler
+(make-object button% "Make Modified Frame" tp (lambda (b e) (test-modified-frame)))
 
 (define cnp (make-object horizontal-pane% ap))
 (send cnp stretchable-width #t)