#lang racket/base
(require ffi/unsafe/objc
         ffi/unsafe
         racket/class
         racket/draw
         racket/draw/private/gl-context
         (except-in racket/draw/private/color
                    color% make-color)
         (only-in racket/draw/private/bitmap quartz-bitmap%)
         "pool.rkt"
         "utils.rkt"
         "const.rkt"
         "types.rkt"
         "window.rkt"
         "frame.rkt"
         "dc.rkt"
         "cg.rkt"
         "queue.rkt"
         "item.rkt"
         "gc.rkt"
         "image.rkt"
         "panel.rkt"
         "../common/backing-dc.rkt"
         "../common/canvas-mixin.rkt"
         "../common/event.rkt"
         "../common/queue.rkt"
         "../../syntax.rkt"
         "../../lock.rkt"
         "../common/freeze.rkt")

(provide 
 (protect-out canvas%
              canvas-panel%))

;; ----------------------------------------

(import-class NSView NSGraphicsContext NSScroller NSComboBox NSWindow 
              NSImageView NSTextFieldCell 
              NSOpenGLView NSOpenGLContext NSOpenGLPixelFormat)

(import-protocol NSComboBoxDelegate)

(define NSWindowAbove 1)

(define gc-via-gl? (version-10.11-or-later?))

;; Called when a canvas has no backing store ready
(define (clear-background wxb r)
  (let ([wx (->wx wxb)])
    (when wx
      (let ([bg (send wx get-canvas-background-for-clearing)])
        (when bg
          (let ([ctx (tell NSGraphicsContext currentContext)])
            (tellv ctx saveGraphicsState)
            (let ([cg (tell #:type _CGContextRef ctx graphicsPort)]
                  [adj (lambda (v) (/ v 255.0))])
              (CGContextSetRGBFillColor cg
                                        (adj (color-red bg))
                                        (adj (color-blue bg))
                                        (adj (color-green bg))
                                        1.0)
              (CGContextFillRect cg r))
            (tellv ctx restoreGraphicsState)))))))

(define-objc-mixin (RacketViewMixin Superclass)
  #:mixins (KeyMouseTextResponder CursorDisplayer FocusResponder) 
  [wxb]
  (-a #:async-apply (box (void))
      _void (drawRect: [_NSRect r])
      (when wxb
        (let ([wx (->wx wxb)])
          (when wx
            (send wx drawing-requested)
            (unless (send wx paint-or-queue-paint)
              (clear-background wxb r)
              ;; ensure that `nextEventMatchingMask:' returns
              (post-dummy-event))))))
  (-a _void (viewWillMoveToWindow: [_id w])
      (when wxb
        (let ([wx (->wx wxb)])
          (when wx
            (queue-window-event wx (lambda () (send wx fix-dc)))))))
  (-a _void (onHScroll: [_id scroller])
      (when wxb 
        (let ([wx (->wx wxb)])
          (when wx (send wx do-scroll 'horizontal scroller)))))
  (-a _void (onVScroll: [_id scroller])
      (when wxb 
        (let ([wx (->wx wxb)])
          (when wx (send wx do-scroll 'vertical scroller))))))

(define-objc-class RacketView NSView 
  #:mixins (RacketViewMixin)
  [wxb])

(define-objc-class RacketGLView NSOpenGLView
  #:mixins (RacketViewMixin)
  [wxb])

(define-objc-class RacketGCGLView NSOpenGLView
  #:mixins (KeyMouseResponder)
  [wxb]
  (-a #:async-apply (box (void))
      _void (drawRect: [_NSRect r])
      (when wxb
        (let ([wx (->wx wxb)])
          (when wx
            (send wx draw-gc-background))))))

(define-objc-class RacketGCWindow NSWindow
  #:mixins (RacketEventspaceMethods)
  [wxb])

(install-RacketGCWindow! RacketGCWindow)

(define-objc-class CornerlessFrameView NSView 
  []
  (-a #:async-apply (box (void))
      _void (drawRect: [_NSRect r])
      (let ([ctx (tell NSGraphicsContext currentContext)])
        (tellv ctx saveGraphicsState)
        (let ([cg (tell #:type _CGContextRef ctx graphicsPort)]
              [r (tell #:type _NSRect self bounds)])
          (CGContextSetRGBFillColor cg 0 0 0 1.0)
          (let* ([l (NSPoint-x (NSRect-origin r))]
                 [t (NSPoint-y (NSRect-origin r))]
                 [b (+ t (NSSize-height (NSRect-size r)))]
                 [r (+ l (NSSize-width (NSRect-size r)))])
            (CGContextAddLines cg
                               (vector
                                (make-NSPoint r (+ t scroll-width))
                                (make-NSPoint r b)
                                (make-NSPoint l b)
                                (make-NSPoint l t)
                                (make-NSPoint (- r scroll-width) t))))
          (CGContextStrokePath cg))
        (tellv ctx restoreGraphicsState))))

(define-cocoa NSSetFocusRingStyle (_fun _int -> _void))
(define-cocoa NSRectFill (_fun _NSRect -> _void))

(define bezel-cell
  (tell (tell NSTextFieldCell alloc) initTextCell: #:type _NSString ""))
(tellv bezel-cell setBezeled: #:type _BOOL #t)

(define-objc-class FocusView NSView 
  [on?]
  (-a _void (setFocusState: [_BOOL is-on?])
      (set! on? is-on?))
  (-a #:async-apply (box (void))
      _void (drawRect: [_NSRect r])
      (let ([f (tell #:type _NSRect self frame)])
        (tellv bezel-cell 
               drawWithFrame: #:type _NSRect (make-NSRect (make-NSPoint 2 2)
                                                          (let ([s (NSRect-size r)])
                                                            (make-NSSize (- (NSSize-width s) 4)
                                                                         (- (NSSize-height s) 4))))
               inView: self))
      (when on?
        (let ([ctx (tell NSGraphicsContext currentContext)])
          (tellv ctx saveGraphicsState)
          (NSSetFocusRingStyle 0)
          (let ([r (tell #:type _NSRect self bounds)])
            (NSRectFill (make-NSRect (make-NSPoint
                                      (+ (NSPoint-x (NSRect-origin r)) 2)
                                      (+ (NSPoint-y (NSRect-origin r)) 2))
                                     (make-NSSize
                                      (- (NSSize-width (NSRect-size r)) 4)
                                      (- (NSSize-height (NSRect-size r)) 4)))))
          (tellv ctx restoreGraphicsState)))))

(define-objc-class RacketComboBox NSComboBox
  #:mixins (FocusResponder KeyMouseTextResponder CursorDisplayer) 
  #:protocols (NSComboBoxDelegate)
  [wxb]
  (-a #:async-apply (box (void))
      _void (drawRect: [_NSRect r])
      (super-tell #:type _void drawRect: #:type _NSRect r)
      (let ([wx (->wx wxb)])
        (when wx
          (unless (send wx paint-or-queue-paint)
            (unless (send wx during-menu-click?)
              (clear-background wxb r)
              ;; ensure that `nextEventMatchingMask:' returns
              (post-dummy-event))))))
  (-a _void (comboBoxWillPopUp: [_id notification])
      (let ([wx (->wx wxb)])
        (when wx
          (send wx starting-combo))))
  (-a _void (comboBoxWillDismiss: [_id notification])
      (let ([wx (->wx wxb)])
        (when wx
          (send wx ending-combo))))
  (-a _void (viewWillMoveToWindow: [_id w])
      (when wxb
        (let ([wx (->wx wxb)])
          (when wx
            (queue-window-event wx (lambda () (send wx fix-dc))))))))

(define NSOpenGLPFADoubleBuffer 5)
(define NSOpenGLPFAStereo 6)
(define NSOpenGLPFAColorSize 8)
(define NSOpenGLPFAAlphaSize 11)
(define NSOpenGLPFADepthSize 12)
(define NSOpenGLPFAStencilSize 13)
(define NSOpenGLPFAAccumSize 14)
(define NSOpenGLPFAOffScreen 53)
(define NSOpenGLPFASampleBuffers 55)
(define NSOpenGLPFASamples 56)
(define NSOpenGLPFAMultisample 59)
(define NSOpenGLPFAAllowOfflineRenderers 96)
(define NSOpenGLPFAOpenGLProfile 99)

(define NSOpenGLProfileVersionLegacy #x1000)
(define NSOpenGLProfileVersion3_2Core #x3200)

(define (gl-config->pixel-format conf allow-offline?)
  (let ([conf (or conf (new gl-config%))])
    (tell (tell NSOpenGLPixelFormat alloc)
          initWithAttributes: #:type (_list i _int)
          (append
           (if (version-10.7-or-later?)
             (list NSOpenGLPFAOpenGLProfile
                   (if (send conf get-legacy?)
                     NSOpenGLProfileVersionLegacy
                     NSOpenGLProfileVersion3_2Core))             
             null)
           (if allow-offline?
               (list NSOpenGLPFAAllowOfflineRenderers)
               null)
           (if (send conf get-double-buffered) (list NSOpenGLPFADoubleBuffer) null)
           (if (send conf get-stereo) (list NSOpenGLPFAStereo) null)
           (list
            NSOpenGLPFADepthSize (send conf get-depth-size)
            NSOpenGLPFAStencilSize (send conf get-stencil-size)
            NSOpenGLPFAAccumSize (send conf get-accum-size))
           (let ([ms (send conf get-multisample-size)])
             (if (zero? ms)
                 null
                 (list NSOpenGLPFAMultisample
                       NSOpenGLPFASampleBuffers 1
                       NSOpenGLPFASamples ms)))
           (list 0)))))
        
  
(define-struct scroller (cocoa [range #:mutable] [page #:mutable]))
(define scroll-width (tell #:type _CGFloat NSScroller scrollerWidth))

;; Customizing by version is a terrible idea, but I can't figure
;; out the right way to get the content area of an NSComboBox
(define combo-dx (if (version-10.7-or-later?)
                     2
                     2))
(define combo-dy (if (version-10.7-or-later?)
                     4
                     2))
(define combo-dw (if (version-10.7-or-later?)
                     24
                     22))
(define combo-dh (if (version-10.7-or-later?)
                     6
                     5))
;; extra height shaved off drawing; we can't just increase
;; combo-dh, because that just creates a request for an even taller
;; combo box whose primitive drawing overlaps the focus ring
(define combo-backing-dh 1)

(define canvas%
  (canvas-mixin
   (class (canvas-autoscroll-mixin window%)
     (init parent
           x y w h
           style
           [ignored-name #f]
           [gl-config #f])

     (inherit get-cocoa
              get-cocoa-window
              get-wx-window
              get-eventspace
              make-graphics-context
              is-shown-to-root?
              is-shown-to-before-root?
              is-enabled-to-root?
              is-window-enabled?
              block-mouse-events
              move get-x get-y
              register-as-child
              get-size get-position
              set-focus
              client-to-screen
              is-auto-scroll? is-disabled-scroll? 
              get-virtual-width get-virtual-height
              reset-auto-scroll
              refresh-for-autoscroll
              refresh-all-children
              flush)

     (define vscroll-ok? (and (or (memq 'vscroll style) 
                                  (memq 'auto-vscroll style)) ; 'auto variant falls through from panel
                              #t))
     (define vscroll? vscroll-ok?)
     (define hscroll-ok? (and (or (memq 'hscroll style) 
                                  (memq 'auto-hscroll style))
                              #t))
     (define hscroll? hscroll-ok?)

     (define wants-focus? (and (not (memq 'no-focus style))
                               (not (is-panel?))))
     (define is-combo? (memq 'combo style))
     (define has-control-border? (and (not is-combo?)
                                      (memq 'control-border style)))

     (define-values (x-margin y-margin x-sb-margin y-sb-margin)
       (cond
        [has-control-border? (values 3 3 3 3)]
        [(memq 'border style) (values 1 1 0 0)]
        [else (values 0 0 0 0)]))

     (define canvas-style style)

     (define/override (focus-is-on on?)
       (when has-control-border?
         (tellv cocoa setFocusState: #:type _BOOL on?)
         (tellv cocoa setNeedsDisplay: #:type _BOOL #t))
       (super focus-is-on on?))

     ;; The `queue-paint' and `paint-children' methods
     ;; are defined by `canvas-mixin' from ../common/canvas-mixin
     (define/public (queue-paint) (void))
     (define/public (request-canvas-flush-delay)
       (unless is-gl?
         (request-flush-delay (get-wx-window))))
     (define/public (cancel-canvas-flush-delay req)
       (unless is-gl?
         (cancel-flush-delay req)))
     (define/public (queue-canvas-refresh-event thunk)
       (queue-window-refresh-event this  thunk))
     (define/public (skip-pre-paint?) 
       (cond
        [is-gl?
         ;; We can't use GL on the window until it is ready,
         ;; as indicated by a request to draw.
         (unless drawing-requested?
           (sync/timeout 0.1 drawing-requested-sema))
         (not drawing-requested?)]
        [else #f]))

     (define drawing-requested? #f)
     (define drawing-requested-sema (make-semaphore))
     (define/public (drawing-requested) 
       (unless drawing-requested?
         (set! drawing-requested? #t)
         (semaphore-post drawing-requested-sema)))

     (define/public (paint-or-queue-paint)
       (cond
        [is-gl? (do-canvas-backing-flush #f)
                (queue-paint)
                #t]
        [(do-canvas-backing-flush #f) #t]
        [else (queue-paint)
              #f]))

     (define/public (do-canvas-backing-flush ctx)
       (do-backing-flush this dc (tell NSGraphicsContext currentContext)
                         (if is-combo? combo-dx 0) (if is-combo? combo-dy 0)))

     ;; not used, because Cocoa canvas refreshes do not go through
     ;;  the eventspace queue:
     (define/public (schedule-periodic-backing-flush)
       (void))

     (define/public (begin-refresh-sequence)
       (send dc suspend-flush))
     (define/public (end-refresh-sequence)
       (send dc resume-flush))

     (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
       (refresh-one)
       (refresh-all-children))

     (define/public (queue-backing-flush)
       (unless is-gl?
         ;; called atomically (not expecting exceptions)
         (tellv content-cocoa setNeedsDisplay: #:type _BOOL #t)))

     (define/override (get-cocoa-content) content-cocoa)

     (define is-gl? (and (not is-combo?) (memq 'gl style)))
     (define want-sync-gl? (and is-gl? gl-config (send gl-config get-sync-swap)))
     (define/public (can-gl?) is-gl?)
     (define/public (sync-gl?) want-sync-gl?)

     (define dc #f)
     (define blits null)
     (define reg-blits null)

     (super-new 
      [parent parent]
      [cocoa
       (as-objc-allocation
        (tell (tell (cond
                     [is-combo? NSView]
                     [has-control-border? FocusView]
                     [(memq 'border style) (if (memq 'vscroll style)
                                               CornerlessFrameView
                                               FrameView)]
                     [else NSView])
                    alloc) 
              initWithFrame: #:type _NSRect (make-NSRect (make-init-point x y)
                                                         (make-NSSize (max w (* 2 x-margin))
                                                                      (max h (* 2 y-margin))))))]
      [no-show? (memq 'deleted style)])

     (define cocoa (get-cocoa))

     (define content-cocoa
       (let ([r (make-NSRect (make-NSPoint 0 0)
                             (make-NSSize (max 0 (- w (if vscroll? scroll-width 0) (* 2 x-margin)))
                                          (max 0 (- h (if hscroll? scroll-width 0) (* 2 y-margin)))))])
         (as-objc-allocation
          (if (or is-combo? (not (memq 'gl style)))
              (tell (tell (if is-combo? RacketComboBox RacketView)
                          alloc)
                    initWithFrame: #:type _NSRect r)
              (let* ([share-context (and gl-config (send gl-config get-share-context))]
                     [context-handle (and share-context (send share-context get-handle))]
                     [pf (gl-config->pixel-format gl-config #f)]
                     [new-context (and
                                   context-handle
                                   (tell (tell NSOpenGLContext alloc)
                                         initWithFormat: pf
                                         shareContext: context-handle))]
                     [gl-view (tell (tell RacketGLView alloc)
                                    initWithFrame: #:type _NSRect r
                                    pixelFormat: pf)])
                (when (and gl-config (send gl-config get-hires-mode))
                  (tellv gl-view setWantsBestResolutionOpenGLSurface: #:type _uint 1))
                (when new-context
                  (tellv gl-view setOpenGLContext: new-context)
                  ;; We're supposed to sync via `setView:' but it fails,
                  ;; perhaps because the view isn't yet visible:
                  ;;   (tellv new-context setView: gl-view)
                  (tellv new-context release))
                (tellv pf release)
                gl-view)))))
     (tell #:type _void cocoa addSubview: content-cocoa)
     (set-ivar! content-cocoa wxb (->wxb this))

     (when is-combo?
       (tellv content-cocoa setEditable: #:type _BOOL #f)
       (tellv content-cocoa setDelegate: content-cocoa)
       (install-control-font content-cocoa #f))

     (set! dc (make-object dc% this (memq 'transparent canvas-style)))

     (send dc start-backing-retained)

     (queue-paint)

     (define/public (is-panel?) #f)
     
     (define/public (get-dc) dc)

     (define/public (make-compatible-bitmap w h)
       (make-window-bitmap w h (get-cocoa-window)))

     (define/override (fix-dc [refresh? #t])
       (when (pair? blits)
         (atomically
          (suspend-all-reg-blits)
          (when (is-shown-to-root?)
            (resume-all-reg-blits))))
       (when (dc . is-a? . dc%)
         (send dc reset-backing-retained)
         (send dc set-auto-scroll
               (if (is-auto-scroll?) (scroll-pos h-scroller) 0)
               (if (is-auto-scroll?) (scroll-pos v-scroller) 0)))
       (when refresh? (refresh-one)))

     (define/override (get-client-size xb yb)
       (super get-client-size xb yb)
       (when is-combo?
         (set-box! xb (max 0 (- (unbox xb) combo-dw)))
         (set-box! yb (max 0 (- (unbox yb) combo-dh)))))

     (define/override (maybe-register-as-child parent on?)
       (register-as-child parent on?))

     (define/public (on-paint) (void))

     (define/override (set-size x y w h)
       (do-set-size x y w h))

     (define tr 0)

     (define/override (show on?)
       ;; FIXME: what if we're in the middle of an on-paint?
       (super show on?))

     (define/override (hide-children)
       (super hide-children)
       (fix-dc #f)
       (suspend-all-reg-blits))

     (define/override (show-children)
       (super show-children)
       ;; (fix-dc) ; inteferes with `paint-children''
       (resume-all-reg-blits))

     (define/override (fixup-locations-children)
       ;; in atomic mode
       (when (is-shown-to-root?)
         (suspend-all-reg-blits)
         (resume-all-reg-blits)))

     (define/private (do-set-size x y w h)
       (when (pair? blits)
         (atomically (suspend-all-reg-blits)))
       (super set-size x y w h)
       (when tr
         (tellv content-cocoa removeTrackingRect: #:type _NSInteger tr)
         (set! tr #f))
       (let ([sz (make-NSSize (- w (if vscroll? scroll-width 0) x-margin x-margin)
                              (- h (if hscroll? scroll-width 0) y-margin y-margin))]
             [pos (make-NSPoint x-margin (+ (if hscroll? scroll-width 0) y-margin))])
         (tellv content-cocoa setFrame: #:type _NSRect (make-NSRect pos sz))
         (set! tr (tell #:type _NSInteger
                        content-cocoa
                        addTrackingRect: #:type _NSRect (make-NSRect (make-NSPoint x-margin y-margin) sz)
                        owner: content-cocoa
                        userData: #f
                        assumeInside: #:type _BOOL #f)))
       (when v-scroller
         (tellv (scroller-cocoa v-scroller) setFrame: #:type _NSRect
                (make-NSRect
                 (make-NSPoint (- w scroll-width x-sb-margin)
                               (+ (if hscroll?
                                      scroll-width
                                      0)
                                  y-sb-margin))
                 (make-NSSize scroll-width
                              (max 0 (- h (if hscroll? scroll-width 0)
                                        x-sb-margin x-sb-margin))))))
       (when h-scroller
         (tellv (scroller-cocoa h-scroller) setFrame: #:type _NSRect
                (make-NSRect
                 (make-NSPoint x-sb-margin y-sb-margin)
                 (make-NSSize (max 0 (- w (if vscroll? scroll-width 0)
                                        x-sb-margin x-sb-margin))
                              scroll-width))))
       (when (and (pair? blits)
                  (is-shown-to-root?))
         (atomically (resume-all-reg-blits)))
       (fix-dc)
       (when (and (is-auto-scroll?)
                  (not (is-panel?)))
         (reset-auto-scroll))
       (on-size))

     ;; this `on-size' method is for `editor-canvas%', only:
     (define/public (on-size) (void))

     (define/public (show-scrollbars h? v?)
       (let ([h? (and h? hscroll-ok?)]
             [v? (and v? vscroll-ok?)])
         (unless (and (eq? h? hscroll?)
                      (eq? v? vscroll?))
           (cond
            [(and h? (not hscroll?))
             (tell #:type _void cocoa addSubview: (scroller-cocoa h-scroller))]
            [(and hscroll? (not h?))
             (tell #:type _void (scroller-cocoa h-scroller) removeFromSuperview)])
           (set! hscroll? h?)
           (cond
            [(and v? (not vscroll?))
             (tell #:type _void cocoa addSubview: (scroller-cocoa v-scroller))]
            [(and vscroll? (not v?))
             (tell #:type _void (scroller-cocoa v-scroller) removeFromSuperview)])
           (set! vscroll? v?)
           (let ([x (box 0)] [y (box 0)] [w (box 0)] [h (box 0)])
             (get-position x y)
             (get-size w h)
             (do-set-size (unbox x) (unbox y) (unbox w) (unbox h))))))

     (define/override (do-set-scrollbars h-step v-step
                                         h-len v-len
                                         h-page v-page
                                         h-pos v-pos)
       (scroll-range h-scroller h-len)
       (scroll-page h-scroller h-page)
       (unless (= h-pos -1)
         (scroll-pos h-scroller h-pos))
       (when h-scroller
         (tellv (scroller-cocoa h-scroller) setEnabled: #:type _BOOL (and h-step (positive? h-len))))
       (scroll-range v-scroller v-len)
       (scroll-page v-scroller v-page)
       (unless (= v-pos -1)
         (scroll-pos v-scroller v-pos))
       (when v-scroller
         (tellv (scroller-cocoa v-scroller) setEnabled: #:type _BOOL (and v-step (positive? v-len)))))

     (define/override (reset-dc-for-autoscroll)
       (fix-dc))

     (define/private (update which scroll- v)
       (if (eq? which 'vertical)
           (scroll- v-scroller v)
           (scroll- h-scroller v)))

     (define/public (set-scroll-page which v)
       (update which scroll-page v))
     (define/public (set-scroll-range which v)
       (update which scroll-range v))
     (define/public (set-scroll-pos which v)
       (update which scroll-pos v))

     (define/private (guard-scroll skip-guard? which get-v)
       (if skip-guard?
           (get-v)
           (if (or (if (eq? which 'vertical)
                       (not vscroll-ok?)
                       (not hscroll-ok?))
                   (is-disabled-scroll?)
                   (is-auto-scroll?))
               0
               (get-v))))

     (define/public (get-scroll-page which [skip-guard? #f]) 
       (guard-scroll skip-guard?
                     which
                     (lambda ()
                       (scroll-page (if (eq? which 'vertical) v-scroller h-scroller)))))
     (define/public (get-scroll-range which [skip-guard? #f])
       (guard-scroll skip-guard?
                     which
                     (lambda ()
                       (scroll-range (if (eq? which 'vertical) v-scroller h-scroller)))))
     (define/public (get-scroll-pos which [skip-guard? #f])
       (guard-scroll skip-guard?
                     which
                     (lambda ()
                       (scroll-pos (if (eq? which 'vertical) v-scroller h-scroller)))))
     
     (define v-scroller
       (and vscroll-ok?
            (make-scroller
             (as-objc-allocation
              (tell (tell NSScroller alloc) initWithFrame: 
                    #:type _NSRect (make-NSRect
                                    (make-NSPoint (- w scroll-width x-sb-margin)
                                                  (+ (if hscroll?
                                                         scroll-width
                                                         0)
                                                     y-sb-margin))
                                    (make-NSSize scroll-width
                                                 (max (- h (if hscroll? scroll-width 0)
                                                         y-sb-margin y-sb-margin)
                                                      (+ scroll-width 10))))))
             1
             1)))
     (define h-scroller
       (and hscroll-ok?
            (make-scroller
             (as-objc-allocation
              (tell (tell NSScroller alloc) initWithFrame: 
                    #:type _NSRect (make-NSRect
                                    (make-NSPoint x-sb-margin y-sb-margin)
                                    (make-NSSize (max (- w (if vscroll? scroll-width 0)
                                                         x-sb-margin x-sb-margin)
                                                      (+ scroll-width 10))
                                                 scroll-width))))
             1
             1)))

     (when v-scroller
       (tell #:type _void cocoa addSubview: (scroller-cocoa v-scroller))
       (tellv (scroller-cocoa v-scroller) setTarget: content-cocoa)
       (tellv (scroller-cocoa v-scroller) setAction: #:type _SEL (selector onVScroll:)))
     (when h-scroller
       (tell #:type _void cocoa addSubview: (scroller-cocoa h-scroller))
       (tellv (scroller-cocoa h-scroller) setTarget: content-cocoa)
       (tellv (scroller-cocoa h-scroller) setAction: #:type _SEL (selector onHScroll:)))
     
     (define scroll-pos
       (case-lambda
        [(scroller val)
         (when scroller
           (tellv (scroller-cocoa scroller) setFloatValue:
                  #:type _float (max (min 1.0 (/ val (exact->inexact (scroller-range scroller))))
                                     0.0)))]
        [(scroller)
         (if scroller
             (->long (round (* (tell #:type _float (scroller-cocoa scroller) floatValue)
                               (scroller-range scroller))))
             0)]))

     (define scroll-range
       (case-lambda
        [(scroller val)
         (when scroller
           (let ([pos (scroll-pos scroller)]
                 [page (scroll-page scroller)])
             (set-scroller-range! scroller val)
             (tell (scroller-cocoa scroller) setEnabled: #:type _BOOL (positive? val))
             (scroll-pos scroller pos)
             (scroll-page scroller page)))]
        [(scroller) 
         (if scroller
             (scroller-range scroller)
             1)]))
     
     (define scroll-page
       (case-lambda
        [(scroller val)
         (when scroller
           (set-scroller-page! scroller val)
           (let ([proportion
                  (max (min 1.0 (/ val 
                                   (+ val (exact->inexact (scroller-range scroller)))))
                       0.0)])
             (if old-cocoa?
                 (tellv (scroller-cocoa scroller) 
                        setFloatValue: #:type _float (tell #:type _float (scroller-cocoa scroller)  
                                                           floatValue)
                        knobProportion: #:type _CGFloat proportion)
                 (tellv (scroller-cocoa scroller) setKnobProportion:
                        #:type _CGFloat proportion))))]
        [(scroller)
         (if scroller
             (scroller-page scroller)
             1)]))

     (define/override (enable-window on?)
       ;; in atomic mode
       (let ([on? (and on? (is-window-enabled?))])
         (let ([w (tell content-cocoa window)])
           (when (ptr-equal? content-cocoa (tell w firstResponder))
             (tellv w makeFirstResponder: #f)))
         (block-mouse-events (not on?))
         (when is-combo?
           (tellv content-cocoa setEnabled: #:type _BOOL on?))))

     (define/public (clear-combo-items)
       (tellv content-cocoa removeAllItems))
     (define/public (append-combo-item str)
       (tellv content-cocoa addItemWithObjectValue: #:type _NSString str)
       #t)
     (define/public (on-combo-select i) (void))
     (define/public (popup-combo)
       ;; Pending refresh events interfere with combo popups
       ;; for some reason, so flush them:
       (yield-refresh)
       (flush)
       ;; Beware that the `popUp:' method is undocumented:
       (atomically
        (tellv (tell content-cocoa cell) popUp: #f)))

     (define clear-bg? (and (not (memq 'transparent canvas-style)) 
                            (not (memq 'no-autoclear canvas-style))))
     (define bg-col (make-object color% "white"))
     (define/public (get-canvas-background) (if (memq 'transparent canvas-style)
                                                #f
                                                bg-col))
     (define/public (set-canvas-background col) (set! bg-col col))
     (define/public (get-canvas-background-for-backing) (and clear-bg? bg-col))
     (define/public (get-canvas-background-for-clearing) 
       (and clear-bg?
            bg-col))

     (define/public (reject-partial-update r)
       ;; Called in the event-pump thread.
       ;; A transparent canvas cannot handle a partial update.
       (and (or 
             ;; Multiple clipping rects?
             (let ([i (malloc _NSInteger)]
                   [r (malloc 'atomic _pointer)])
               (tellv content-cocoa getRectsBeingDrawn: #:type _pointer r 
                      count: #:type _pointer i)
               ((ptr-ref i _NSInteger) . > . 1))
             ;; Single clipping not whole area?
             (let ([s1 (NSRect-size (tell #:type _NSRect content-cocoa frame))]
                   [s2 (NSRect-size r)])
               (or ((NSSize-width s2) . < . (NSSize-width s1))
                   ((NSSize-height s2) . < . (NSSize-height s1)))))
            (begin
              (queue-window-event this (lambda () (refresh-one)))
              #t)))

     (define/public (do-scroll direction scroller)
       ;; Called from the Cocoa handler thread
       (let ([part (tell #:type _int scroller hitPart)])
         (queue-window-event 
          this
          (lambda ()
            (let ([kind
                   (cond
                    [(= part NSScrollerDecrementPage)
                     (set-scroll-pos direction (- (get-scroll-pos direction #t)
                                                  (get-scroll-page direction #t)))
                     'page-up]
                    [(= part NSScrollerIncrementPage)
                     (set-scroll-pos direction (+ (get-scroll-pos direction #t)
                                                  (get-scroll-page direction #t)))
                     'page-down]
                    [(= part NSScrollerDecrementLine)
                     (set-scroll-pos direction (- (get-scroll-pos direction #t) 1))
                     'line-up]
                    [(= part NSScrollerIncrementLine)
                     (set-scroll-pos direction (+ (get-scroll-pos direction #t) 1))
                     'line-down]
                    [(= part NSScrollerKnob)
                     'thumb]
                    [else #f])])
              (when kind
                (if (is-auto-scroll?)
                    (refresh-for-autoscroll)
                    (on-scroll (new scroll-event%
                                    [event-type kind]
                                    [direction direction]
                                    [position (get-scroll-pos direction)]))))))))
       (constrained-reply (get-eventspace)
                          (lambda ()
                            (let loop () (pre-event-sync #t) (when (yield/no-sync) (loop))))
                          (void)))
     (define/public (on-scroll e) (void))
     
     (define/override (definitely-wants-event? e) 
       ;; Called in Cocoa event-handling mode
       (when (and wants-focus?
                  (e . is-a? . mouse-event%)
                  (send e button-down? 'left))
         (set-focus))
       (and (not (is-panel?))
            (or (not is-combo?)
                (e . is-a? . key-event%)
                (not (send e button-down? 'left))
                (not (on-menu-click? e)))))

     (define/override (can-accept-focus?)
       wants-focus?)
     (define/override (can-be-responder?)
       (and wants-focus? (is-enabled-to-root?)))

     (define/private (on-menu-click? e)
       ;; Called in Cocoa event-handling mode
       (let ([xb (box 0)]
             [yb (box 0)])
         (get-client-size xb yb)
         ((send e get-x) . > . (unbox xb))))

     (define/public (on-popup) (void))

     (define/public (starting-combo)
       (set! in-menu-click? #t)
       (tellv content-cocoa setStringValue: #:type _NSString current-text)
       (constrained-reply (get-eventspace)
                          (lambda () (on-popup))
                          (void)))
       
     (define/public (ending-combo)
       (set! in-menu-click? #f)
       (let ([pos (tell #:type _NSInteger content-cocoa indexOfSelectedItem)])
         (when (pos . > . -1)
           (queue-window-event this (lambda () (on-combo-select pos)))))
       (refresh-one))

     (define current-text "")
     (define/public (set-combo-text t)
       (set! current-text t))

     (define in-menu-click? #f)

     (define/public (during-menu-click?)
       ;; Called in Cocoa event-handling mode
       in-menu-click?)

     (define/public (scroll x y)
       (when (is-auto-scroll?) 
         (when (x . >= . 0) (scroll-pos h-scroller (floor (* x (scroll-range h-scroller)))))
         (when (y . >= . 0) (scroll-pos v-scroller (floor (* y (scroll-range v-scroller)))))
         (refresh-for-autoscroll)))

     (define/override (get-virtual-h-pos)
       (scroll-pos h-scroller))

     (define/override (get-virtual-v-pos)
       (scroll-pos v-scroller))

     (define/public (set-resize-corner on?)
       (void))

     (define/public (get-backing-size xb yb)
       (get-client-size xb yb)
       (when is-combo?
         (set-box! yb (max 0 (- (unbox yb) combo-backing-dh)))))

     (define/public (get-scaled-client-size)
       (define bsr (tell #:type _NSRect (get-cocoa-content) bounds))
       (define csr
         (tell #:type _NSRect (get-cocoa-content)
               convertRectToBacking:
               #:type _NSRect bsr))
       (define cs (NSRect-size csr))
       (define cw (->long (NSSize-width cs)))
       (define ch (->long (NSSize-height cs)))
       (values cw ch))
     
     (define/public (get-gl-client-size)
       (if (or (not is-gl?)
               (tell #:type _BOOL content-cocoa wantsBestResolutionOpenGLSurface))
           (get-scaled-client-size)
           (let ([x (box 0)]
                 [y (box 0)])
             (get-client-size x y)
             (values (unbox x) (unbox y)))))

     (define/override (get-cursor-width-delta)
       0)

     (define/public (is-flipped?)
       (tell #:type _BOOL (get-cocoa-content) isFlipped))

     (define/private (suspend-all-reg-blits)
       (let ([cocoa-win (get-cocoa-window)])
         (for ([r (in-list reg-blits)])
           (tellv cocoa-win removeChildWindow: (vector-ref r 0))
           ; removeChildWindow doesn't hide the window
           (tellv (vector-ref r 0) orderOut: #f)
           (release (vector-ref r 0))
           (scheme_remove_gc_callback (vector-ref r 1))))
       (set! reg-blits null))

     (define/public (resume-all-reg-blits)
       (unless (pair? reg-blits)
         (when (pair? blits)
           (set! reg-blits
                 (for/list ([b (in-list blits)])
                   (let-values ([(x y w h s img us unimg) (apply values b)])
                     (register-one-blit x y w h s img us unimg)))))))

     (define/private (register-one-blit x y w h s img us unimg)
       (let ([xb (box x)]
             [yb (box y)])
         (client-to-screen xb yb #f)
         (let* ([cocoa-win (get-cocoa-window)])
           (atomically
            (let ([win (as-objc-allocation
                        (tell (tell (if gc-via-gl? RacketGCWindow NSWindow) alloc)
                              initWithContentRect: #:type _NSRect (make-NSRect (make-NSPoint (unbox xb)
                                                                                             (- (unbox yb)
                                                                                                h))
                                                                               (make-NSSize w h))
                              styleMask: #:type _int NSBorderlessWindowMask
                              backing: #:type _int NSBackingStoreBuffered
                              defer: #:type _BOOL NO))]
                  [glv (and gc-via-gl?
                            (let ([pf (gl-config->pixel-format #f #t)])
                              (begin0
                               (tell (tell RacketGCGLView alloc)
                                     initWithFrame: #:type _NSRect (make-NSRect (make-NSPoint 0 0)
                                                                                (make-NSSize w h))
                                     pixelFormat: pf)
                               (tellv pf release))))]
                  [iv (and (not gc-via-gl?)
                           (tell (tell NSImageView alloc) init))])
              (cond
               [gc-via-gl?
                (tellv (tell glv openGLContext) setValues:
                       #:type (_ptr i _long) 0
                       forParameter: #:type _int NSOpenGLCPSwapInterval)
                (tellv win setAcceptsMouseMovedEvents: #:type _BOOL #t)
                (set-ivar! win wxb (->wxb this))
                (set-ivar! glv wxb (->wxb this))
                (unless (= s 1)
                  (tellv glv setWantsBestResolutionOpenGLSurface: #:type _uint 1))
                (tellv (tell win contentView) addSubview: glv)]
               [else
                (tellv win setAlphaValue: #:type _CGFloat 0.0)
                (tellv iv setImage: img)
                (tellv iv setFrame: #:type _NSRect (make-NSRect (make-NSPoint 0 0)
                                                                (make-NSSize w h)))
                (tellv (tell win contentView) addSubview: iv)
                (tellv iv release)])
              (tellv cocoa-win addChildWindow: win ordered: #:type _int NSWindowAbove)
              (when gc-via-gl?
                (tellv win orderWindow: #:type _int NSWindowAbove
                       relativeTo: #:type _NSInteger (tell #:type _NSInteger cocoa-win windowNumber)))
              (define uninstall-desc
                (if gc-via-gl?
                    (if (and unimg
                             ;; all white?
                             (not (for/and ([i (in-range 0 (bytes-length unimg) 4)])
                                    (or (= (bytes-ref unimg i) 0)
                                        (and (= (bytes-ref unimg (+ 1 i)) 255)
                                             (= (bytes-ref unimg (+ 2 i)) 255)
                                             (= (bytes-ref unimg (+ 3 i)) 255))))))
                        (make-gl-install win glv w h unimg us)
                        (make-gl-uninstall win glv w h))
                    (make-gc-action-desc win (selector setAlphaValue:) 0.0)))
              (let ([r (scheme_add_gc_callback
                        (if gc-via-gl?
                            (make-gl-install win glv w h img s)
                            (make-gc-action-desc win (selector setAlphaValue:) 1.0))
                        uninstall-desc)])
                (when gc-via-gl?
                  (tellv glv release))
                (vector win r uninstall-desc)))))))
     
     (define/public (register-collecting-blit x y w h on off on-x on-y off-x off-y)
       (let ([on (fix-bitmap-size on w h on-x on-y)]
             [off (and gc-via-gl?
                       (fix-bitmap-size off w h on-x on-y))]
             [s (send on get-backing-scale)]
             [us (send off get-backing-scale)])
         (define (bm->img on s)
           (let* ([xw (inexact->exact (ceiling (* s w)))]
                  [xh (inexact->exact (ceiling (* s h)))]
                  [rgba (make-bytes (* xw xh 4))])
             (send on get-argb-pixels 0 0 xw xh rgba #:unscaled? #t)
             rgba))
         (let ([img (if gc-via-gl?
                        (bm->img on s)
                        (bitmap->image on))]
               [unimg (and gc-via-gl? (bm->img off us))])
           (atomically
            (set! blits (cons (list x y w h s img us unimg) blits))
            (when (is-shown-to-root?)
              (set! reg-blits (cons (register-one-blit x y w h s img us unimg) reg-blits)))))))

     (define/public (unregister-collecting-blits)
       (atomically
        (suspend-all-reg-blits)
        (set! blits null)))

     (define/public (draw-gc-background)
       (for ([rb (in-list reg-blits)])
         (do-gl-action (vector-ref rb 2)))))))

(define canvas-panel%
  (class (panel-mixin canvas%)
    (inherit get-virtual-h-pos
             get-virtual-v-pos
             get-cocoa-content)

    (define/override (is-panel?) #t)

    (define/override (reset-dc-for-autoscroll)
      (let* ([content-cocoa (get-cocoa-content)])
        (tellv content-cocoa setBoundsOrigin: #:type _NSPoint
               (make-NSPoint (get-virtual-h-pos)
                             (- (get-virtual-v-pos)))))
      (super reset-dc-for-autoscroll))

    (super-new)))
