racket/gui cocoa: fix over-eager refresh for 'gl canvas%

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

@@ -308,6 +308,8 @@
        (get-cocoa-window))
 
      (define/private (refresh-one)
+       (when is-gl?
+         (tellv content-cocoa setNeedsDisplay: #:type _BOOL #t))
        (queue-paint))
      (define/override (refresh)
        ;; can be called from any thread, including the event-pump thread
@@ -315,8 +317,9 @@
        (refresh-all-children))
 
      (define/public (queue-backing-flush)
-       ;; called atomically (not expecting exceptions)
-       (tellv content-cocoa setNeedsDisplay: #:type _BOOL #t))
+       (unless is-gl?
+         ;; called atomically (not expecting exceptions)
+         (tellv content-cocoa setNeedsDisplay: #:type _BOOL #t)))
 
      (define/override (get-cocoa-content) content-cocoa)
 

collects/tests/gracket/gl-refresh.rkt

@@ -0,0 +1,21 @@
+#lang racket/gui
+(require sgl)
+
+(define c%
+   (class canvas%
+     (inherit with-gl-context swap-gl-buffers)
+     (define/override (on-paint)
+       (with-gl-context
+        (lambda ()
+          (gl-clear-color (random) (random) (random) 1)
+          (gl-clear 'color-buffer-bit)
+          (swap-gl-buffers)
+          (gl-flush))))
+     (super-new (style '(gl no-autoclear)))))
+
+(define f (new frame% [label ""] [width 100] [height 300]))
+(define c (new c% [parent f]))
+(new message% [parent f] [label "Canvas changes color on refresh,"])
+(new message% [parent f] [label "so check that it's not too often."])
+(new button% [parent f] [label "Refresh"] [callback (lambda (b e) (send c refresh))])
+(send f show #t)