#lang racket/base
(require ffi/unsafe
         ffi/unsafe/define
         racket/class
         racket/draw
         ffi/unsafe/alloc
         (except-in racket/draw/private/color
                    color% make-color)
         racket/draw/private/local
         racket/draw/unsafe/cairo
         "../common/backing-dc.rkt"
         "../common/canvas-mixin.rkt"
         "../../syntax.rkt"
	 "../../lock.rkt"
         "../common/event.rkt"
         "utils.rkt"
         "const.rkt"
         "types.rkt"
         "window.rkt"
         "client-window.rkt"
         "widget.rkt"
         "dc.rkt"
         "gl-context.rkt"
         "combo.rkt"
         "gcwin.rkt"
         "panel.rkt")

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

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

(define-gobj g_object_freeze_notify (_fun _GtkWidget -> _void))
(define-gobj g_object_thaw_notify (_fun _GtkWidget -> _void))

(define-gobj g_object_set_double (_fun _GtkWidget _string _double* (_pointer = #f) -> _void)
  #:c-id g_object_set)
(define-gobj g_object_get_double (_fun _GtkWidget _string (r : (_ptr o _double)) (_pointer = #f) 
				       -> _void -> r)
  #:c-id g_object_get)

(define-gtk gtk_drawing_area_new (_fun -> _GtkWidget))

(define-gtk gtk_layout_new (_fun (_pointer = #f) (_pointer = #f) -> _GtkWidget))
(define-gtk gtk_layout_put (_fun _GtkWidget _GtkWidget _int _int -> _void))
(define-gtk gtk_layout_move (_fun _GtkWidget _GtkWidget _int _int -> _void))

(define-gtk gtk_combo_box_text_new (_fun -> _GtkWidget)
  #:make-fail make-not-available)
(define-gtk gtk_combo_box_entry_new_text (_fun -> _GtkWidget)
  #:fail (lambda () gtk_combo_box_text_new))

(define-gtk gtk_combo_box_text_append_text (_fun _GtkWidget _string -> _void)
  #:make-fail make-not-available)
(define-gtk gtk_combo_box_append_text (_fun _GtkWidget _string -> _void)
  #:fail (lambda () gtk_combo_box_text_append_text))

(define-gtk gtk_combo_box_text_remove (_fun _GtkWidget _int -> _void)
  #:make-fail make-not-available)
(define-gtk gtk_combo_box_remove_text (_fun _GtkWidget _int -> _void)
  #:fail (lambda () gtk_combo_box_text_remove))

(define-gtk gtk_combo_box_popup (_fun _GtkWidget -> _void))

(define-gtk gtk_widget_queue_draw (_fun _GtkWidget -> _void))

(define-gtk gtk_widget_set_has_window (_fun _GtkWidget _gboolean -> _void)
  #:make-fail make-not-available)
(define-gtk gtk_fixed_set_has_window (_fun _GtkWidget _gboolean -> _void)
  #:fail (lambda () gtk_widget_set_has_window))

(define-gtk gtk_hscrollbar_new (_fun _pointer -> _GtkWidget))
(define-gtk gtk_vscrollbar_new (_fun _pointer -> _GtkWidget))

(define-gtk gtk_widget_set_double_buffered (_fun _GtkWidget _gboolean -> _void))

(define _GtkAdjustment _GtkWidget) ; no, actually a GtkObject
(define-gtk gtk_adjustment_new (_fun _double* _double* _double* _double* _double* _double* -> _GtkAdjustment))
(define-gtk gtk_adjustment_configure (_fun _GtkAdjustment _double* _double* _double* _double* _double* _double* -> _void)
  #:fail (lambda ()
	   ;; This by-hand version doesn't produce quite the same notifications.
	   (lambda (gtk value lower upper step-inc page-inc page-size)
	     (atomically
              (g_object_freeze_notify gtk)
              (g_object_set_double gtk "lower" lower)
              (g_object_set_double gtk "upper" upper)
              (g_object_set_double gtk "step-increment" step-inc)
              (g_object_set_double gtk "page-increment" page-inc)
              (g_object_set_double gtk "page-size" page-size)
              (let ([value (max lower (min value (- upper page-size)))])
                (gtk_adjustment_set_value gtk value))
              (g_object_thaw_notify gtk)))))
(define-gtk gtk_adjustment_get_value (_fun _GtkAdjustment -> _double*))
(define-gtk gtk_adjustment_set_value (_fun _GtkAdjustment _double* -> _void))
(define-gtk gtk_adjustment_get_upper (_fun _GtkAdjustment -> _double*)
  #:fail (lambda ()
	   (lambda (gtk)
	     (g_object_get_double gtk "upper"))))
(define-gtk gtk_adjustment_set_upper (_fun _GtkAdjustment _double* -> _void)
  #:fail (lambda ()
	   (lambda (gtk upper)
	     (g_object_set_double gtk "upper" upper))))
(define-gtk gtk_adjustment_get_page_size (_fun _GtkAdjustment -> _double*)
  #:fail (lambda ()
	   (lambda (gtk)
	     (g_object_get_double gtk "page-size"))))
(define-gtk gtk_adjustment_set_page_size (_fun _GtkAdjustment _double* -> _void)
  #:fail (lambda ()
	   (lambda (gtk page-size)
	     (g_object_set_double gtk "page-size" page-size))))
(define-gtk gtk_adjustment_get_page_increment (_fun _GtkAdjustment -> _double*)
  #:fail (lambda ()
	   (lambda (gtk)
	     (g_object_get_double gtk "page-increment"))))
(define-gtk gtk_adjustment_set_page_increment (_fun _GtkAdjustment _double* -> _void)
  #:fail (lambda ()
	   (lambda (gtk page-inc)
	     (g_object_set_double gtk "page-increment" page-inc))))

(define-gtk gtk_container_remove (_fun _GtkWidget _GtkWidget -> _void))
(define-gtk gtk_bin_get_child (_fun _GtkWidget -> _GtkWidget))

(define-gobj g_object_set_bool (_fun _GtkWidget _string _gboolean [_pointer = #f] -> _void)
  #:c-id g_object_set)

(define _GtkIMContext (_cpointer 'GtkIMContext))
(define-gtk gtk_im_multicontext_new (_fun -> _GtkIMContext))
(define-gtk gtk_im_context_set_use_preedit (_fun _GtkIMContext _gboolean -> _void))
(define-gtk gtk_im_context_focus_in (_fun _GtkIMContext -> _void))
(define-gtk gtk_im_context_focus_out (_fun _GtkIMContext -> _void))
(define-gtk gtk_im_context_filter_keypress (_fun _GtkIMContext _GdkEventKey-pointer -> _gboolean))
(define-gtk gtk_im_context_set_client_window (_fun _GtkIMContext _GdkWindow -> _void))
(define-gtk gtk_im_context_set_cursor_location (_fun _GtkIMContext _GdkRectangle-pointer -> _void))

(define im-string-result #f)
(define im-filtering? #f)
(define im-canvas #f)

(define-signal-handler connect-commit "commit"
  (_fun _GtkIMContext _string -> _void)
  (lambda (im str)
    (cond
     [im-filtering?
      ;; filtering an event => we can handle the string
      ;; result directly
      (set! im-string-result str)]
     [(and im-canvas
	   (weak-box-value im-canvas))
      ;; not filtering, but there's a target canvas =>
      ;; queue a made-up key press event for each character
      ;; of the string
      => (lambda (wx)
	   (for ([c (in-string str)])
	     (let ([e (new key-event%
			   [key-code c]
			   [shift-down #f]
			   [control-down #f]
			   [meta-down #f]
			   [alt-down #f]
			   [x 0]
			   [y 0]
			   [time-stamp 0]
			   [caps-down #f])])
	       (queue-window-event wx (lambda () 
					(send wx dispatch-on-char e #f))))))])))

(define im (gtk_im_multicontext_new))
(void (connect-commit (cast im _pointer _GtkWidget)))

(gtk_im_context_set_use_preedit im #f)

;; We rely some on the implementation of GtkComboBoxEntry to replace
;; the drawing routine.
(define-cstruct _GList ([data _pointer]))
(define-gdk gdk_window_get_children (_fun _pointer -> _GList-pointer/null))
(define-gdk gdk_window_hide (_fun _pointer -> _void))
(define (get-subwindow gtk)
  (let* ([win (widget-window gtk)]
         [subs (gdk_window_get_children win)])
    (if subs
        (GList-data subs)
        win)))

(define-signal-handler connect-changed "changed"
  (_fun _GtkWidget -> _void)
  (lambda (gtk)
    (let ([wx (gtk->wx gtk)])
      (when wx
        (send wx combo-maybe-clicked)))))

(define-gtk gtk_combo_box_set_active (_fun _GtkWidget _int -> _void))
(define-gtk gtk_combo_box_get_active (_fun _GtkWidget -> _int))
(define-gtk gtk_combo_box_set_button_sensitivity (_fun _GtkWidget _int -> _void)
  #:fail (lambda () 
	   ;; Not available? Too bad. A combo-field% will in rare
	   ;;  cases not be enabled as it should be.
	   (lambda (w m) (void))))
(define GTK_SENSITIVITY_ON 1)

(define-signal-handler connect-expose "expose-event"
  (_fun _GtkWidget _GdkEventExpose-pointer -> _gboolean)
  (lambda (gtk event)
    (let ([wx (gtk->wx gtk)])
      (if wx
          (begin
            (unless (send wx paint-or-queue-paint #f)
              (let ([gc (send wx get-canvas-background-for-clearing)])      
                (when gc
                  (gdk_draw_rectangle (widget-window gtk) gc #t
                                      0 0 32000 32000)
                  (gdk_gc_unref gc))))
            (not (send wx is-panel?)))
          #f))))

(define-signal-handler connect-draw "draw"
  (_fun _GtkWidget _cairo_t -> _gboolean)
  (lambda (gtk cr)
    (let ([wx (gtk->wx gtk)])
      (if wx
	  (let ([col (send wx get-canvas-background-for-backing)]
		[win (widget-window gtk)])
            (unless (send wx paint-or-queue-paint cr)
              (when col
                (cairo_set_source_rgb cr
				      (color-red col)
				      (color-green col)
				      (color-blue col))
		(cairo_rectangle cr 0 0 32000 32000)
		(cairo_fill cr)))
            (not (send wx is-panel?)))
          #f))))

(define-signal-handler connect-value-changed-h "value-changed"
  (_fun _GtkWidget -> _void)
  (lambda (gtk)
    (do-value-changed gtk 'horizontal)))

(define-signal-handler connect-value-changed-v "value-changed"
  (_fun _GtkWidget -> _void)
  (lambda (gtk)
    (do-value-changed gtk 'vertical)))

(define-signal-handler connect-unrealize "unrealize"
  (_fun _GtkWidget -> _void)
  (lambda (gtk)
    (let ([wx (gtk->wx gtk)])
      (when wx
        (send wx unrealize)))))

(define-signal-handler connect-unmap "unmap"
  (_fun _GtkWidget -> _void)
  (lambda (gtk)
    (let ([wx (gtk->wx gtk)])
      (when wx
        (send wx unrealize)))))

(define (do-value-changed gtk dir)
  (let ([wx (gtk->wx gtk)])
    (when wx
      (when (send wx deliver-scroll-callbacks?)
        (queue-window-event wx (lambda () 
                                 (send wx do-scroll dir)
                                 (flush-display))))))
  #t)

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

     (inherit get-gtk get-size get-client-size 
              get-top-win
              set-auto-size 
              adjust-client-delta infer-client-delta
              is-auto-scroll? is-disabled-scroll?
              get-virtual-width get-virtual-height
              refresh-for-autoscroll refresh-all-children
	      reset-auto-scroll
              get-eventspace
	      register-extra-gtk
	      call-pre-on-event set-focus on-event)

     (define is-combo? (memq 'combo style))
     (define has-border? (or (memq 'border style)
                             (memq 'control-border style)))
     (define for-gl? (memq 'gl style))
     (define transparent?
       (and (memq 'transparent style)
            (not for-gl?))) ; 'transparent is incompatible with 'gl

     (define transparentish? (or transparent? is-combo?))

     (define margin (if has-border? 1 0))

     (define flush-win-box (mcons #f 0))

     (define-values (client-gtk container-gtk gtk
                                hscroll-adj vscroll-adj hscroll-gtk vscroll-gtk resize-box
                                combo-button-gtk
                                scroll-width)
       (atomically ;; need to connect all children to gtk to avoid leaks
        (cond
         [(or (memq 'hscroll style)
              (memq 'auto-hscroll style)
              (memq 'vscroll style)
              (memq 'auto-vscroll style))
          (let* ([client-gtk (if (is-panel?)
                                 (if gtk3?
				     (gtk_layout_new)
				     (gtk_fixed_new))
                                 (gtk_drawing_area_new))]
                 [container-gtk (if (is-panel?)
                                    (gtk_fixed_new)
                                    client-gtk)]
                 [hadj (gtk_adjustment_new 0.0 0.0 1.0 1.0 1.0 1.0)]
                 [vadj (gtk_adjustment_new 0.0 0.0 1.0 1.0 1.0 1.0)]
                 [hs? (or (memq 'hscroll style)
                          (memq 'auto-hscroll style))]
                 [vs? (or (memq 'vscroll style)
                          (memq 'auto-vscroll style))])
            (let ([container (and gtk3?
				  ;; See `panel%` for information on why an extra
				  ;; event-box layer is needed here.
				  (as-gtk-allocation (gtk_event_box_new)))]
	          [border (and has-border?
			       (if gtk3?
				   (gtk_hbox_new #f 0)
				   (as-gtk-allocation (gtk_hbox_new #f 0))))]
		  [h (if (or has-border? gtk3?)
			 (gtk_hbox_new #f 0)
			 (as-gtk-allocation (gtk_hbox_new #f 0)))]
                  [v (gtk_vbox_new #f 0)]
                  [v2 (gtk_vbox_new #f 0)]
                  [h2 (gtk_vbox_new #f 0)]
                  [hscroll (gtk_hscrollbar_new hadj)]
                  [vscroll (gtk_vscrollbar_new vadj)]
                  [resize-box (gtk_drawing_area_new)])
              ;; |------------------------------------|
              ;; | h |-----------------| |-----------||
              ;; |   | v               | | v2        ||
              ;; |   |                 | | [vscroll] ||
              ;; |   | [h2 [hscroll]]  | | [resize]  ||
              ;; |   |-----------------| |-----------|| 
              ;; |------------------------------------|
              (unless (eq? client-gtk container-gtk)
                (gtk_fixed_set_has_window client-gtk #t)) ; imposes clipping
              (when has-border?
                (gtk_container_set_border_width h margin)
                (connect-expose/draw-border border h))
	      (when container
		(gtk_container_add container (or border h))
		(gtk_widget_show (or border h)))
              (when border (gtk_box_pack_start border h #t #t 0))
              (gtk_box_pack_start h v #t #t 0)
              (gtk_box_pack_start v client-gtk #t #t 0)
              (gtk_box_pack_start h v2 #f #f 0)
              (gtk_box_pack_start v2 vscroll #t #t 0)
              (gtk_box_pack_start v h2 #f #f 0)
              (gtk_box_pack_start h2 hscroll #t #t 0)
              (gtk_box_pack_start v2 resize-box #f #f 0)
              (when hs?
                (gtk_widget_show hscroll))
              (gtk_widget_show vscroll)
              (when border
	        (gtk_widget_show h))
              (gtk_widget_show v)
              (when vs?
                (gtk_widget_show v2))
              (gtk_widget_show h2)
              (when hs?
                (gtk_widget_show resize-box))
              (gtk_widget_show client-gtk)
              (unless (eq? client-gtk container-gtk)
		(if gtk3?
		    (gtk_layout_put client-gtk container-gtk 0 0)
		    (gtk_container_add client-gtk container-gtk))
                (gtk_widget_show container-gtk))
              (let ([req (make-GtkRequisition 0 0)])
                (gtk_widget_size_request vscroll req)
                (values client-gtk container-gtk (or container border h)
			hadj vadj 
                        (and hs? h2)
                        (and vs? v2)
                        (and hs? vs? resize-box)
                        #f
                        (GtkRequisition-width req)))))]
         [is-combo?
          (let* ([gtk (as-gtk-allocation (gtk_combo_box_entry_new_text))]
                 [orig-entry (gtk_bin_get_child gtk)])
	    (gtk_combo_box_set_button_sensitivity gtk GTK_SENSITIVITY_ON)
            (values orig-entry gtk gtk #f #f #f #f #f (extract-combo-button gtk) 0))]
         [has-border?
          (let ([client-gtk (gtk_drawing_area_new)]
                [h (gtk_hbox_new #f 0)]
                [border (as-gtk-allocation (gtk_hbox_new #f 0))])
            (gtk_box_pack_start border h #t #t 0)
            (gtk_box_pack_start h client-gtk #t #t 0)
            (gtk_container_set_border_width h margin)
            (connect-expose/draw-border border h)
            (gtk_widget_show h)
            (gtk_widget_show client-gtk)
            (values client-gtk client-gtk border #f #f #f #f #f #f 0))]
         [else
          (let ([client-gtk (as-gtk-allocation (gtk_drawing_area_new))])
            (values client-gtk client-gtk client-gtk #f #f #f #f #f #f 0))])))

     (when for-gl?
       (prepare-widget-gl-context client-gtk gl-config)
       (gtk_widget_set_double_buffered client-gtk #f))

     (define dc #f)

     (super-new [parent parent]
                [gtk gtk]
                [client-gtk client-gtk]
                [no-show? (memq 'deleted style)]
                [extra-gtks (append
                             (if (eq? client-gtk container-gtk)
                                 null
                                 (list container-gtk))
                             (if (eq? client-gtk gtk)
                                 null
                                 (if hscroll-adj
                                     (list client-gtk hscroll-adj vscroll-adj)
                                     (if combo-button-gtk
                                         (list client-gtk combo-button-gtk)
                                         (list client-gtk)))))])

     (define/private (check-combo)
       (when is-combo?
	 (set! combo-button-gtk (re-extract-combo-button gtk combo-button-gtk this))))

     (set-size x y w h)

     (define/override (set-size x y w h)
       (super set-size x y w h)
       (when (and (is-auto-scroll?)
                  (not (is-panel?)))
         (reset-auto-scroll))
       (on-size))
     
     (set! dc (new dc% [canvas this] [transparentish? transparentish?]))

     (gtk_widget_realize gtk)
     (gtk_widget_realize client-gtk)

     (when resize-box 
       (let ([r (make-GtkRequisition 0 0)])
         (gtk_widget_size_request hscroll-gtk r)
         (gtk_widget_set_size_request resize-box 
                                      (GtkRequisition-height r)
                                      (GtkRequisition-height r))))

     (if gtk3?
	 (connect-draw client-gtk)
	 (connect-expose client-gtk))
     #;(gtk_widget_set_double_buffered client-gtk #f)
     (connect-key-and-mouse client-gtk)
     (connect-focus client-gtk)
     (gtk_widget_add_events client-gtk (bitwise-ior GDK_KEY_PRESS_MASK
                                                    GDK_KEY_RELEASE_MASK
                                                    GDK_BUTTON_PRESS_MASK
                                                    GDK_BUTTON_RELEASE_MASK
                                                    GDK_POINTER_MOTION_MASK
                                                    GDK_FOCUS_CHANGE_MASK
                                                    GDK_ENTER_NOTIFY_MASK
                                                    GDK_LEAVE_NOTIFY_MASK))
     (unless (or (memq 'no-focus style)
                 (is-panel?))
       (gtk_widget_set_can_focus client-gtk #t))
     (check-combo)
     (when combo-button-gtk
       (connect-combo-key-and-mouse combo-button-gtk))
     (connect-unrealize client-gtk)
     (connect-unmap client-gtk)

     (when hscroll-adj (connect-value-changed-h hscroll-adj))
     (when vscroll-adj (connect-value-changed-v vscroll-adj))

     (when (and gtk3? (or hscroll-gtk vscroll-gtk))
       ;; Need to get scroll size now that the control is shown
       (let ([req (make-GtkRequisition 0 0)])
	 (gtk_widget_show gtk)
	 (gtk_widget_get_preferred_size (or vscroll-gtk hscroll-gtk) req #f)
	 (set! scroll-width (if vscroll-gtk
				(GtkRequisition-width req)
				(GtkRequisition-height req)))
	 (gtk_widget_hide gtk)))

     (when (and gtk3? is-combo?)
       ;; Needed for sizing:
       (gtk_combo_box_append_text gtk (make-string 8 #\X)))

     (set-auto-size)
     (adjust-client-delta (+ (* 2 margin) 
                             (if (or (memq 'vscroll style)
                                     (memq 'auto-vscroll style))
                                 scroll-width
                                 0))
                          (+ (* 2 margin) 
                             (if (or (memq 'hscroll style)
                                     (memq 'auto-hscroll style))
                                 scroll-width
                                 0)))
     (when (and gtk3? is-combo?)
       (infer-client-delta #:inside client-gtk)
       (gtk_combo_box_text_remove gtk 0))

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

     ;; Direct update is ok for a canvas, and it
     ;; allows pushing updates to the screen even
     ;; if the eventspace thread is busy indefinitely
     (define/override (direct-update?) #t)

     (define/public (get-dc) dc)

     (define/public (make-compatible-bitmap w h)
       (send dc make-backing-bitmap w h))

     (define/public (get-scaled-client-size)
       (define wb (box #f))
       (define hb (box #f))
       (get-client-size wb hb)
       (define s (if gtk3?
		     (gtk_widget_get_scale_factor gtk)
		     1))
       (values (* s (->screen (unbox wb))) (* s (->screen (unbox hb)))))

     (define/public (get-gl-client-size)
       (get-scaled-client-size))

     (define/override (get-client-gtk) client-gtk)
     (define/override (get-container-gtk) container-gtk)
     (define/override (handles-events? gtk) (not (ptr-equal? gtk combo-button-gtk)))

     (define/override (internal-pre-on-event gtk e)
       (if (ptr-equal? gtk combo-button-gtk)
           (cond
	    [gtk3?
	     (queue-window-event this (lambda ()
					(unless (call-pre-on-event this e)
					  (when (send e button-down?)
					    (set-focus))
					  (on-event e))))
	     #t]
	    [(send e button-down?)
	     (on-popup)
             #t]
	    [else #f])
           #f))
     (define/public (popup-combo)
       ;; Unfortunately, the user has to hold the mouse 
       ;; button down when popping up the menu this way,
       ;; whereas the default handler (that we subvert in
       ;; `internal-pre-on-event') keeps the menu open if
       ;; the user release the mouse button right away.
       (gtk_combo_box_popup gtk))

     (define/override (get-client-delta)
       (values margin margin))

     ;; 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)
       (request-flush-delay (get-flush-window) transparentish?))
     (define/public (cancel-canvas-flush-delay req)
       (cancel-flush-delay req))
     (define/public (queue-canvas-refresh-event thunk)
       (queue-window-refresh-event this thunk))
     (define/public (skip-pre-paint?) #f)

     (define/public (paint-or-queue-paint cr)
       ;; in atomic mode
       (if for-gl?
	   (queue-paint)
	   (or (do-canvas-backing-flush cr)
	       (begin
		 (queue-paint)
		 #f))))

     ;; overridden to extend for scheduled periodic flushes:
     (define/public (schedule-periodic-backing-flush)
       (void))
     (define/public (do-canvas-backing-flush cr)
       (do-backing-flush this dc (if gtk3?
				     cr
				     (if is-combo?
					 (get-subwindow client-gtk)
					 (widget-window client-gtk)))))

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

     (define/public (get-flush-window) 
       (atomically
	(if (not (gtk_widget_get_mapped client-gtk))
	    (mcons #f #f)
	    (if (win-box-valid? flush-win-box)
		flush-win-box
		(begin
		  (set! flush-win-box (window->win-box (widget-window client-gtk)))
		  flush-win-box)))))
     (define/public (unrealize)
       (unrealize-win-box flush-win-box))
     (define/override (reset-child-freezes)
       ;; A transparent canvas can't have a native window, so we
       ;; need to release any freezes befre the window implementation
       ;; might change.
       (when transparentish? (unrealize)))

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

     ;; The `flush' method should be improved to flush local
     ;; to the enclosing frame, instead of flushing globally.
     (define/public (flush)
       (flush-display))

     (define/private (refresh-one)
       (queue-paint))
     (define/override (refresh)
       (refresh-one)
       (refresh-all-children))

     (define/public (queue-backing-flush)
       ;; called atomically
       (unless for-gl?
         (gtk_widget_queue_draw client-gtk)))

     (define/override (reset-child-dcs)
       (when (dc . is-a? . dc%)
         (reset-dc)))

     (send dc start-backing-retained)

     (define/private (reset-dc)
       (send dc reset-backing-retained)
       (refresh-one)
       (send dc set-auto-scroll
             (if (get-virtual-width)
                 (gtk_adjustment_get_value hscroll-adj)
                 0)
             (if (get-virtual-height)
                 (gtk_adjustment_get_value vscroll-adj)
                 0)))

     (define/override (internal-on-client-size w h)
       (reset-dc))
     (define/override (on-client-size w h) 
       (on-size))

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

     (define/public (show-scrollbars h? v?)
       (when hscroll-gtk
         (if h?
             (gtk_widget_show hscroll-gtk)
             (gtk_widget_hide hscroll-gtk)))
       (when vscroll-gtk
         (if v?
             (gtk_widget_show vscroll-gtk)
             (gtk_widget_hide vscroll-gtk)))
       (when (and hscroll-gtk vscroll-gtk)
         (cond
          [(and v? h?)
           (gtk_widget_show resize-box)]
          [(and v? (not h?))
           ;; remove corner 
           (gtk_widget_hide resize-box)]))
       (unless is-combo?
         (adjust-client-delta (+ (* 2 margin) (if v? scroll-width 0))
                              (+ (* 2 margin) (if h? scroll-width 0)))))

     (define suspend-scroll-callbacks? #f)
     (define/public (deliver-scroll-callbacks?) (not suspend-scroll-callbacks?))
     (define/private (as-scroll-change thunk)
       (atomically
        (set! suspend-scroll-callbacks? #t)
        (begin0
         (thunk)
         (set! suspend-scroll-callbacks? #f))))


     (define/private (configure-adj adj scroll-gtk len page pos)
       (when (and scroll-gtk adj)
         (as-scroll-change
          (lambda ()
            (if (zero? len)
                (gtk_adjustment_configure adj 0 0 1 1 1 1)
                (let ([pos (if (= pos -1)
                               (gtk_adjustment_get_value adj)
                               pos)])
                  (gtk_adjustment_configure adj pos 0 (+ len page) 1 page page)))))))

     (define/override (do-set-scrollbars h-step v-step
                                         h-len v-len
                                         h-page v-page
                                         h-pos v-pos)
       (configure-adj hscroll-adj hscroll-gtk h-len h-page h-pos)
       (configure-adj vscroll-adj vscroll-gtk v-len v-page v-pos))

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

     (define/private (dispatch which proc [default (void)])
       (if (eq? which 'vertical)
           (if vscroll-adj (proc vscroll-adj) default)
           (if hscroll-adj (proc hscroll-adj) default)))

     (define/public (set-scroll-page which v)
       (dispatch which (lambda (adj)
                         (let ([old (gtk_adjustment_get_page_size adj)])
                           (unless (= old v)
                             (as-scroll-change
                              (lambda ()
                                (gtk_adjustment_set_page_size adj v)
                                (gtk_adjustment_set_page_increment adj v)
                                (gtk_adjustment_set_upper adj (+ (- v old)
                                                                 (gtk_adjustment_get_upper adj))))))))))
     (define/public (set-scroll-range which v)
       (dispatch which (lambda (adj)
                         (as-scroll-change
                          (lambda ()
                            (gtk_adjustment_set_upper adj (+ v (gtk_adjustment_get_page_size adj))))))))
     (define/public (set-scroll-pos which v)
       (dispatch which (lambda (adj) 
                         (as-scroll-change
                          (lambda ()
                            (gtk_adjustment_set_value adj v))))))

     (define/private (is-disabled-scroll-dir? which)
       (or (if (eq? which 'vertical)
               (not vscroll-gtk)
               (not hscroll-gtk))
           (is-disabled-scroll?)))

     (define/public (get-scroll-page which) 
       (if (or (is-disabled-scroll-dir? which) (is-auto-scroll?))
           0
           (->long (dispatch which gtk_adjustment_get_page_size 0))))
     (define/public (get-scroll-range which)
       (if (or (is-disabled-scroll-dir? which) (is-auto-scroll?))
           0
           (->long (dispatch which (lambda (adj)
                                     (- (gtk_adjustment_get_upper adj)
                                        (gtk_adjustment_get_page_size adj)))
                             0))))
     (define/public (get-scroll-pos which)
       (if (or (is-disabled-scroll-dir? which) (is-auto-scroll?))
           0
           (->long (dispatch which gtk_adjustment_get_value 0))))
     
     (define clear-bg?
       (and (not transparent?)
            (not (memq 'no-autoclear style))))
     (define gc #f)
     (define bg-col (make-object color% "white"))
     (define/public (get-canvas-background) (if transparent?
                                                #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) 
       ;; called in event-dispatch mode
       (if clear-bg?
           (let* ([conv (lambda (x) (bitwise-ior x (arithmetic-shift x 8)))]
                  [w (widget-window gtk)]
                  [gc (gdk_gc_new w)])
             (gdk_gc_set_rgb_fg_color gc (make-GdkColor 0
                                                        (conv (color-red bg-col))
                                                        (conv (color-green bg-col))
                                                        (conv (color-blue bg-col))))
             gc)
           #f))

     (when is-combo?
       (connect-changed (if gtk3? gtk client-gtk)))

     (define combo-count 0)
     (define/public (clear-combo-items)
       (atomically
        (for ([n (in-range combo-count)])
          (gtk_combo_box_remove_text gtk 0))
        (set! combo-count 0)))
     (define/public (append-combo-item str)
       (atomically
        (set! combo-count (add1 combo-count))
        (gtk_combo_box_append_text gtk str)))

     (when is-combo? (append-combo-item "..."))

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

     (define/public (combo-maybe-clicked)
       (let ([i (gtk_combo_box_get_active gtk)])
         (when (i . > . -1)
	   (set-no-active-item)
           (queue-window-event this (lambda () (on-combo-select i))))))
     (define/public (on-combo-select i) (void))

     (define/private (set-no-active-item)
       ;; (gtk_combo_box_set_active gtk -1) should work,
       ;; or using (.._iter #f) should work, but neither
       ;; causes the "changed" signal to be emitted when the
       ;; currently active item is re-selected, so we
       ;; hack around the problem by adding an item, making
       ;; it active, then removing it
       (atomically
	(gtk_combo_box_append_text gtk "dummy")
	(gtk_combo_box_set_active gtk combo-count)
	(gtk_combo_box_remove_text gtk combo-count)))

     (define/public (set-combo-text t) (void))

     (define/override (focus-change on?)
       ;; input-method management
       (if on?
	   (begin
	     (set! im-canvas (make-weak-box this))
	     (gtk_im_context_focus_in im)
	     (gtk_im_context_set_client_window im (widget-window client-gtk))
	     (let ([w (box 0)]
		   [h (box 0)])
	       (get-client-size w h)
	       (gtk_im_context_set_cursor_location 
		im 
		(make-GdkRectangle 0 0 (unbox w) (unbox h)))))
	   (when (and im-canvas
		      (eq? this (weak-box-value im-canvas)))
	     (gtk_im_context_focus_out im)
	     (set! im-canvas #f))))

     (define/override (filter-key-event e)
       ;; give the input method a chance to handle the
       ;; key event; see call in "window.rkt" for
       ;; information on the results
       (if (and im-canvas
		(eq? this (weak-box-value im-canvas)))
	   (begin
	     (set! im-filtering? #t)
	     (set! im-string-result #f)
	     (if (begin0
		  (gtk_im_context_filter_keypress im e)
		  (set! im-filtering? #f))
		 im-string-result
		 'none))
	   'none))
     
     (define/public (do-scroll direction)
       (if (is-auto-scroll?)
           (refresh-for-autoscroll)
           (on-scroll (new scroll-event%
                           [event-type 'thumb]
                           [direction direction]
                           [position (get-scroll-pos direction)]))))
     (define/public (on-scroll e) (void))

     (define/public (scroll x y)
       (when (is-auto-scroll?) 
         (as-scroll-change
          (lambda ()
            (when (and hscroll-adj (>= x 0))
              (gtk_adjustment_set_value 
               hscroll-adj 
               (floor
                (* x (- (gtk_adjustment_get_upper hscroll-adj)
                        (gtk_adjustment_get_page_size hscroll-adj))))))
            (when (and vscroll-adj  (>= y 0))
              (gtk_adjustment_set_value 
               vscroll-adj
               (floor
                (* y (- (gtk_adjustment_get_upper vscroll-adj)
                        (gtk_adjustment_get_page_size vscroll-adj))))))))
         (refresh-for-autoscroll)))

     (define/override (get-virtual-h-pos)
       (inexact->exact (ceiling (gtk_adjustment_get_value hscroll-adj))))
     (define/override (get-virtual-v-pos)
       (inexact->exact (ceiling (gtk_adjustment_get_value vscroll-adj))))

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

     (define reg-blits null)
     
     (define/private (register-one-blit x y w h on-gc-bitmap off-gc-bitmap)
       (atomically
	(let ([win (create-gc-window client-gtk x y w h)])
	  (let ([r (scheme_add_gc_callback
		    (make-gc-show-desc win on-gc-bitmap w h)
		    (make-gc-hide-desc win off-gc-bitmap w h))])
	    (cons win r)))))

     (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 (fix-bitmap-size off w h off-x off-y)])
         (let ([on-gc-bitmap (bitmap->gc-bitmap on client-gtk)]
               [off-gc-bitmap (bitmap->gc-bitmap off client-gtk)])
           (atomically
            (set! reg-blits (cons (register-one-blit (->screen x) (->screen y)
						     (->screen w) (->screen h)
						     on-gc-bitmap off-gc-bitmap)
				  reg-blits))))))
     
     (define/public (unregister-collecting-blits)
       (atomically
        (for ([r (in-list reg-blits)])
          (free-gc-window (car r))
          (scheme_remove_gc_callback (cdr r)))
        (set! reg-blits null))))))

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

(define canvas-panel%
  (class (panel-container-mixin (panel-mixin canvas%))
    (inherit get-container-gtk
             get-client-gtk
             get-virtual-h-pos
             get-virtual-v-pos)
    (define/override (is-panel?) #t)

    (define/override (set-child-size child-gtk x y w h)
      ;; ensure that container is big enough to hold the child:
      (let ([container-gtk (get-container-gtk)]
            [req (make-GtkRequisition 0 0)])
        (gtk_widget_size_request container-gtk req)
        (gtk_widget_set_size_request container-gtk
                                     (max (GtkRequisition-width req)
                                          (->screen (+ x w)))
                                     (max (GtkRequisition-height req)
                                          (->screen (+ y h)))))
      (super set-child-size child-gtk x y w h))

    (define/override (reset-dc-for-autoscroll)
      (super reset-dc-for-autoscroll)
      ((if (and gtk3? (is-panel?)) gtk_layout_move gtk_fixed_move)
       (get-client-gtk) (get-container-gtk)
       (- (get-virtual-h-pos))
       (- (get-virtual-v-pos))))

    (super-new)))
