#lang racket/base
(require ffi/unsafe
	 ffi/unsafe/define
         racket/class
         racket/promise
         racket/runtime-path
         racket/draw
         (for-syntax (only-in racket/base quote))
         "../../syntax.rkt"
         "../../lock.rkt"
         "utils.rkt"
         "const.rkt"
         "types.rkt"
         "window.rkt"
         "client-window.rkt"
         "widget.rkt"
         "cursor.rkt"
         "pixbuf.rkt"
         "resolution.rkt"
         "queue.rkt"
         "../common/queue.rkt")

(provide 
 (protect-out frame%
              display-origin
              display-size
              display-count
              display-bitmap-resolution
              location->window
              get-current-mouse-state
              gtk_window_set_transient_for

              gtk_fixed_new
              gtk_fixed_move

              tell-all-frames-request-refresh-all-canvas-children))

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

(define GDK_GRAVITY_NORTH_WEST 1)
(define GDK_GRAVITY_STATIC 10)

(define _GList (_cpointer/null 'GList))
(define-glib g_list_insert (_fun _GList _pointer _int -> _GList))
(define-glib g_list_free (_fun _GList -> _void))

(define-gtk gtk_window_new (_fun _int -> _GtkWidget))
(define-gtk gtk_window_set_title (_fun _GtkWindow _string -> _void))
(define-gtk gtk_fixed_new (_fun -> _GtkWidget))
(define-gtk gtk_fixed_move (_fun _GtkWidget _GtkWidget _int _int -> _void))
(define-gtk gtk_window_get_size (_fun _GtkWidget (w : (_ptr o _int)) (h : (_ptr o _int))
                                      -> _void
                                      -> (values w h)))
(define-gtk gtk_window_set_decorated (_fun _GtkWidget _gboolean -> _void))
(define-gtk gtk_window_set_keep_above (_fun _GtkWidget _gboolean -> _void))
(define-gtk gtk_window_set_focus_on_map (_fun _GtkWidget _gboolean -> _void))
(define-gtk gtk_window_maximize (_fun _GtkWidget -> _void))
(define-gtk gtk_window_unmaximize (_fun _GtkWidget -> _void))
(define-gtk gtk_window_move (_fun _GtkWidget _int _int -> _void))
(define-gtk gtk_widget_set_uposition (_fun _GtkWidget _int _int -> _void)
  #:fail (lambda () (lambda (w x y) (gtk_window_move w x y))))
(define-gtk gtk_window_get_position (_fun _GtkWidget (x : (_ptr o _int)) (y : (_ptr o _int)) 
                                          -> _void
                                          -> (values x y)))
(define-gtk gtk_window_set_gravity (_fun _GtkWindow _int -> _void))
(define-gtk gtk_window_set_icon_list (_fun _GtkWindow _GList -> _void))
(define-gtk gtk_window_fullscreen (_fun _GtkWindow -> _void))
(define-gtk gtk_window_unfullscreen (_fun _GtkWindow -> _void))
(define-gtk gtk_window_get_focus (_fun _GtkWindow -> (_or-null _GtkWidget)))

(define-gtk gtk_window_resize (_fun _GtkWidget _int _int -> _void))

(define-gdk gdk_window_set_cursor (_fun _GdkWindow _pointer -> _void))
(define-gdk gdk_screen_get_root_window (_fun _GdkScreen -> _GdkWindow))
(define-gdk gdk_screen_get_monitor_scale_factor (_fun _GdkScreen _int -> _int)
  #:fail (lambda () (lambda (s n) 1)))
(define-gdk gdk_window_get_pointer (_fun _GdkWindow 
                                         (x : (_ptr o _int))
                                         (y : (_ptr o _int))
                                         (mods : (_ptr o _uint))
                                         -> _GdkWindow
                                         -> (values x y mods)))

(define-gtk gtk_window_iconify (_fun _GtkWindow -> _void))
(define-gtk gtk_window_deiconify (_fun _GtkWindow -> _void))

(define-cstruct _GdkGeometry ([min_width _int]
                              [min_height _int]
                              [max_width _int]
                              [max_height _int]
                              [base_width _int]
                              [base_height _int]
                              [width_inc _int]
                              [height_inc _int]
                              [min_aspect _double]
                              [max_aspect _double]
                              [win_gravity _int]))
(define-gtk gtk_window_set_geometry_hints (_fun _GtkWindow _pointer _GdkGeometry-pointer _int -> _void))
(define-gtk gtk_widget_get_allocated_width (_fun _GtkWidget -> _int)
  #:make-fail make-not-available)
(define-gtk gtk_widget_get_allocated_height (_fun _GtkWidget -> _int)
  #:make-fail make-not-available)

(define-gtk gtk_get_major_version (_fun -> _uint) #:fail (lambda () (lambda () 2)))
(define-gtk gtk_get_minor_version (_fun -> _uint) #:fail (lambda () (lambda () 2)))
(define-gtk gtk_get_micro_version (_fun -> _uint) #:fail (lambda () (lambda () 2)))

(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_window_set_transient_for (_fun _GtkWidget _GtkWidget -> _void))

(define-signal-handler connect-delete "delete-event"
  (_fun _GtkWidget -> _gboolean)
  (lambda (gtk)
    (let ([wx (gtk->wx gtk)])
      (when wx
        (queue-window-event wx (lambda () 
                                 (unless (other-modal? wx)
                                   (when (send wx on-close)
                                     (send wx direct-show #f)))))))))

(define-signal-handler connect-configure "configure-event"
  (_fun _GtkWidget _GdkEventConfigure-pointer -> _gboolean)
  (lambda (gtk a)
    (let ([wx (gtk->wx gtk)])
      (when wx
        (define-values (w h) (if gtk3?
				 (gtk_window_get_size gtk)
				 (values (GdkEventConfigure-width a)
					 (GdkEventConfigure-height a))))
        (send wx remember-size 
              (->normal (GdkEventConfigure-x a))
              (->normal (GdkEventConfigure-y a))
              (->normal w)
              (->normal h))))
    #f))

(define-signal-handler connect-map "map"
  (_fun _GtkWidget _pointer -> _void)
  (lambda (gtk event)
    (let ([wx (gtk->wx gtk)])
      (when wx
        (send wx notify-children-top-realize)))))

(define-cstruct _GdkEventWindowState ([type _int]
                                      [window _GtkWindow]
                                      [send_event _int8]
                                      [changed_mask _int]
                                      [new_window_state _int]))


(define-signal-handler connect-window-state "window-state-event"
  (_fun _GtkWidget _GdkEventWindowState-pointer -> _gboolean)
  (lambda (gtk evt)
    (let ([wx (gtk->wx gtk)])
      (when wx
        (send wx on-window-state 
              (GdkEventWindowState-changed_mask evt)
              (GdkEventWindowState-new_window_state evt))))
    #f))

(define-runtime-path plt-16x16-file '(lib "icons/plt-icon-16x16.png"))
(define-runtime-path plt-32x32-file '(lib "icons/plt-icon-32x32.png"))
(define-runtime-path plt-48x48-file '(lib "icons/plt-icon-48x48.png"))

(define icon-pixbufs+glist
  (delay
    (let ([icons (map
                  (lambda (fn)
                    (bitmap->pixbuf (make-object bitmap% fn 'png/alpha)))
                  (list plt-16x16-file
                        plt-32x32-file
                        plt-48x48-file))])
      (cons 
       ;; keep pixbuf pointers to avoid GC:
       icons
       ;; a glist:
       (for/fold ([l #f]) ([i (in-list icons)])
	 (g_list_insert l i -1))))))

;; used for location->window
(define all-frames (make-weak-hasheq))

(define frame%
  (class (client-size-mixin window%)
    (init parent
          label
          x y w h
          style)
    (init [is-dialog? #f])

    (inherit get-gtk set-size
             pre-on-char pre-on-event
             get-stored-client-delta get-size
             get-parent get-eventspace
             adjust-client-delta
             queue-on-size)

    (define floating? (memq 'float style))

    (define gtk (as-gtk-window-allocation
                 (gtk_window_new (if floating?
				     GTK_WINDOW_POPUP
				     GTK_WINDOW_TOPLEVEL))))
    (when (and parent wayland?)
      (gtk_window_set_transient_for gtk (send parent get-gtk)))

    (when (memq 'no-caption style)
      (gtk_window_set_decorated gtk #f))
    (when floating?
      (gtk_window_set_keep_above gtk #t)
      (gtk_window_set_focus_on_map gtk #f))
    (define-values (vbox-gtk layout-gtk panel-gtk)
      (atomically
       (let ([vbox-gtk (gtk_vbox_new #f 0)]
             [layout-gtk (and gtk3? (gtk_layout_new))]
             [panel-gtk (gtk_fixed_new)])
         (gtk_container_add gtk vbox-gtk)
         (gtk_box_pack_end vbox-gtk (or layout-gtk panel-gtk) #t #t 0)
	 (when layout-gtk
	   (gtk_layout_put layout-gtk panel-gtk 0 0))
         (values vbox-gtk layout-gtk panel-gtk))))
    (gtk_widget_show vbox-gtk)
    (when layout-gtk (gtk_widget_show layout-gtk))
    (gtk_widget_show panel-gtk)
    (connect-enter-and-leave gtk)

    ;; Enable key events on the panel to catch events
    ;; that would otherwise go undelivered:
    (gtk_widget_set_can_focus panel-gtk #t)
    (gtk_widget_add_events panel-gtk (bitwise-ior GDK_KEY_PRESS_MASK
						  GDK_KEY_RELEASE_MASK))
    (connect-key panel-gtk)

    (when wayland?
      (connect-map gtk))

    (unless is-dialog?
      (gtk_window_set_icon_list gtk (cdr (force icon-pixbufs+glist))))

    (define/override (get-client-gtk) panel-gtk)
    (define/override (get-window-gtk) gtk)

    (define/override (in-floating?) floating?)

    (super-new [parent parent]
               [gtk gtk]
               [client-gtk panel-gtk]
               [no-show? #t]
               [add-to-parent? #f]
               [extra-gtks (list panel-gtk)]
               [connect-size-allocate? #f])

    (set-size x y w h)

    (when (memq 'hide-menu-bar style)
      (gtk_window_fullscreen gtk))

    (connect-delete gtk)
    (connect-configure gtk)
    (connect-focus gtk)
    (connect-window-state gtk)

    (define saved-title (or label ""))
    (define is-modified? #f)

    (when label
      (gtk_window_set_title gtk label))

    ;(gtk_window_add_accel_group (widget-window gtk) the-accelerator-group)

    (define/override (set-child-size child-gtk x y w h)
      (gtk_fixed_move panel-gtk child-gtk (->screen x) (->screen y))
      ;; gtk3: we expect a panel in a frame to be always visible, so
      ;; this size request should work
      (avoid-preferred-size-warning child-gtk)
      (gtk_widget_set_size_request child-gtk (->screen w) (->screen h)))

    (define/public (on-close) #t)

    (define/public (set-menu-bar mb)
      (let ([mb-gtk (send mb get-gtk)])
	(gtk_box_pack_start vbox-gtk mb-gtk #f #f 0)
        (gtk_widget_show mb-gtk))
      (let ([h (send mb set-top-window this)])
        ;; adjust client delta right away, so that we make
        ;; better assumptions about the client size and more
        ;; quickly converge to the right size of the frame
        ;; based on its content
        (adjust-client-delta 0 h))
      ;; Hack: calls back into the mred layer to re-compute
      ;;  sizes. By calling this early enough, the frame won't 
      ;;  grow if it doesn't have to grow to accommodate the menu bar.
      (send this resized))

    (define/public (reset-menu-height h)
      (adjust-client-delta 0 h))

    (define saved-enforcements (vector 0 0 -1 -1))

    (define/public (enforce-size min-x min-y max-x max-y inc-x inc-y)
      (define (to-max v) (if (= v -1) #x3FFFFF (->screen v)))
      (set! saved-enforcements (vector min-x min-y max-x max-y))
      (define-values (dx dy)
	(if wayland?
	    ;; Hints work at a layer of geometry below some offset that
	    ;; `gtk_window_get_size` works but above where allocations
	    ;; work:
	    (let-values ([(w h) (gtk_window_get_size gtk)])
	      (values (- (gtk_widget_get_allocated_width gtk) w)
		      (- (gtk_widget_get_allocated_height gtk) h)))
	    (values 0 0)))
      (gtk_window_set_geometry_hints gtk #f
                                     (make-GdkGeometry (->screen min-x) (->screen min-y)
                                                       (+ dx (to-max max-x)) (+ dy (to-max max-y))
                                                       0 0
                                                       (->screen inc-x) (->screen inc-y)
                                                       0.0 0.0
                                                       0)
                                     (bitwise-ior GDK_HINT_MIN_SIZE
                                                  GDK_HINT_MAX_SIZE
                                                  GDK_HINT_RESIZE_INC)))

    (define/override (get-top-win) this)

    (define dc-lock (and (eq? 'windows (system-type)) (make-semaphore 1)))
    (define/public (get-dc-lock) dc-lock)

    (define/override (get-dialog-level) 0)
    (define/public (frame-relative-dialog-status win) #f)

    (define/override (get-unset-pos) #f)

    (define/override (center dir wrt)
      (let ([w-box (box 0)]
            [h-box (box 0)]
            [sx-box (box 0)]
            [sy-box (box 0)]
            [sw-box (box 0)]
            [sh-box (box 0)])
        (get-size w-box h-box)
        (let ([p (get-parent)])
          (if p
              (begin
                (send p get-size sw-box sh-box)
                (set-box! sx-box (send p get-x))
                (set-box! sy-box (send p get-y)))
              (display-size sw-box sh-box #t 0 void)))
        (let* ([sw (unbox sw-box)]
               [sh (unbox sh-box)]
               [fw (unbox w-box)]
               [fh (unbox h-box)])
          (set-top-position (if (or (eq? dir 'both)
                                    (eq? dir 'horizontal))
                                (+ (unbox sx-box) (quotient (- sw fw) 2))
                                #f)
                            (if (or (eq? dir 'both)
                                    (eq? dir 'vertical))
                                (+ (unbox sy-box) (quotient (- sh fh) 2))
                                #f)))))

    (define/public (set-top-position x y)
      (unless (and (not x) (not y))
        (gtk_widget_set_uposition gtk
                                  (or (and x (->screen x)) -2)
                                  (or (and y (->screen y)) -2))))

    (define/override (really-set-size gtk x y processed-x processed-y w h)
      (set-top-position x y)
      (gtk_window_resize gtk (max 1 (->screen w)) (max 1 (->screen h))))

    (define/override (show on?)
      (let ([es (get-eventspace)])
        (when (and on?
                   (eventspace-shutdown? es))
          (error (string->symbol
                  (format "show method in ~a"
                          (if (frame-relative-dialog-status this)
                              'dialog%
                              'frame%)))
                 "eventspace has been shutdown")
          (when saved-child
            (if (eq? (current-thread) (eventspace-handler-thread es))
                (send saved-child paint-children)
                (let ([s (make-semaphore)])
                  (queue-callback (lambda ()
                                    (when saved-child
                                      (send saved-child paint-children))
                                    (semaphore-post s)))
                  (sync/timeout 1 s))))))
      (super show on?))

    (define saved-child #f)
    (define/override (register-child child on?)
      (unless on? (error 'register-child-in-frame "did not expect #f"))
      (unless (or (not saved-child) (eq? child saved-child))
        (error 'register-child-in-frame "expected only one child"))
      (set! saved-child child))
    (define/override (register-child-in-parent on?)
      (void))

    (define/override (refresh-all-children)
      (when saved-child
        (send saved-child refresh)))

    (define/override (notify-children-top-realize)
      (when saved-child
	(send saved-child notify-children-top-realize)))

    (define/override (direct-show on?)
      ;; atomic mode
      (if on?
          (hash-set! all-frames this #t)
          (hash-remove! all-frames this))
      (super direct-show on?)
      (when on? (gtk_window_deiconify gtk))
      (register-frame-shown this on?))

    (define/public (destroy)
      ;; atomic mode
      (direct-show #f))

    (define/override (on-client-size w h)
      (void))

    (define/augment (is-enabled-to-root?) #t)

    (define big-icon #f)
    (define small-icon #f)
    (define/public (set-icon bm [mask #f] [mode 'both])
      (let ([bm (if mask
		    (let* ([nbm (make-object bitmap%
					     (send bm get-width)
					     (send bm get-height)
					     #f
					     #t)]
			   [dc (make-object bitmap-dc% nbm)])
		      (send dc draw-bitmap bm 0 0
			    'solid (make-object color% "black")
			    mask)
		      (send dc set-bitmap #f)
		      nbm)
		    bm)])
	(case mode
	  [(small) (set! small-icon bm)]
	  [(big) (set! big-icon bm)]
	  [(both) 
	   (set! small-icon bm)
	   (set! big-icon bm)])
	(let ([small-pixbuf
	       (if small-icon
		   (bitmap->pixbuf small-icon)
		   (car (car (force icon-pixbufs+glist))))]
	      [big-pixbufs
	       (if big-icon
		   (list (bitmap->pixbuf big-icon))
		   (cdr (car (force icon-pixbufs+glist))))])
          (atomically
           (let ([l (for/fold ([l #f]) ([i (cons small-pixbuf big-pixbufs)])
                      (g_list_insert l i -1))])
             (gtk_window_set_icon_list gtk l)
             (g_list_free l))))))
    
    (define child-has-focus? #f)
    (define reported-activate #f)
    (define queued-active? #f)
    (define/public (on-focus-child on?)
      ;; atomic mode
      (set! child-has-focus? on?)
      (unless queued-active?
	(set! queued-active? #t)
	(queue-window-event this
			    (lambda ()
			      (let ([on? child-has-focus?])
				(set! queued-active? #f)
				(unless (eq? on? reported-activate)
				  (set! reported-activate on?)
				  (on-activate on?)))))))

    (define treat-focus-out-as-menu-click? #f)
    (define/public (treat-focus-out-as-menu-click)
      (set! treat-focus-out-as-menu-click? #t))

    (define focus-here? #f)
    (define/override (on-focus? on?)
      (when (and (not on?) treat-focus-out-as-menu-click?)
        (on-menu-click))
      (on-focus-child on?)
      (cond
       [on?
	(if (ptr-equal? (gtk_window_get_focus gtk) gtk)
	    (begin
	      (set! focus-here? #t)
	      (super on-focus? on?))
	    #f)]
       [focus-here?
	(set! focus-here? #f)
	(super on-focus? on?)]
       [else #f]))

    (define/public (get-focus-window [even-if-not-active? #f])
      (let ([f-gtk (gtk_window_get_focus gtk)])
        (and f-gtk
             (or even-if-not-active?
		 (gtk_widget_has_focus f-gtk))
             (gtk->wx f-gtk))))
    
    (define/override (call-pre-on-event w e)
      (pre-on-event w e))
    (define/override (call-pre-on-char w e)
      (pre-on-char w e))

    (define/override (internal-client-to-screen x y)
      (gtk_window_set_gravity gtk GDK_GRAVITY_STATIC)
      (let-values ([(dx dy) (gtk_window_get_position gtk)]
                   [(cdx cdy) (get-stored-client-delta)])
        (gtk_window_set_gravity gtk GDK_GRAVITY_NORTH_WEST)
        (set-box! x (+ (unbox x) (->normal (+ dx cdx))))
        (set-box! y (+ (unbox y) (->normal (+ dy cdy))))))

    (define/public (on-toolbar-click) (void))
    (define/public (on-menu-click) (void))

    (define/public (on-menu-command c) (void))

    (def/public-unimplemented on-mdi-activate)

    (define/public (on-activate on?) (void))

    (define/public (designate-root-frame) (void))

    (def/public-unimplemented system-menu)

    (define/public (set-modified mod?)
      (unless (eq? is-modified? (and mod? #t))
        (set! is-modified? (and mod? #t))
        (set-title saved-title)))

    (define waiting-cursor? #f)
    (define/public (set-wait-cursor-mode on?)
      (set! waiting-cursor? on?)
      (when in-window
        (send in-window enter-window)))

    (define current-cursor-handle #f)
    (define in-window #f)
    (define/override (set-parent-window-cursor in-win c)
      (set! in-window in-win)
      (let ([c (if waiting-cursor?
                   (get-watch-cursor-handle)
                   c)])
        (unless (eq? c current-cursor-handle)
          (atomically
           (set! current-cursor-handle c)
           (gdk_window_set_cursor (widget-window (get-gtk)) (if (eq? c (get-arrow-cursor-handle))
                                                                #f
                                                                c))))))
    (define/override (enter-window) (void))
    (define/override (leave-window) (void))

    (define/override (check-window-cursor win)
      (when in-window
        (send in-window enter-window)))
      
    (define maximized? #f)
    (define is-iconized? #f)
    (define fullscreen? #f)
    
    (define/public (is-maximized?)
      maximized?)
    (define/public (maximize on?)
      ((if on? gtk_window_maximize gtk_window_unmaximize) gtk))

    (define/public (on-window-state changed value)
      (when (positive? (bitwise-and changed GDK_WINDOW_STATE_MAXIMIZED))
        (set! maximized? (positive? (bitwise-and value GDK_WINDOW_STATE_MAXIMIZED))))
      (when (positive? (bitwise-and changed GDK_WINDOW_STATE_FULLSCREEN))
	(set! fullscreen? (positive? (bitwise-and value GDK_WINDOW_STATE_FULLSCREEN))))
      (when (positive? (bitwise-and changed GDK_WINDOW_STATE_ICONIFIED))
        (set! is-iconized? (positive? (bitwise-and value GDK_WINDOW_STATE_ICONIFIED)))))

    (define/public (iconized?)
      is-iconized?)
    (define/public (iconize on?)
      (if on?
          (gtk_window_iconify gtk)
          (gtk_window_deiconify gtk)))

    (define/public (fullscreened?)
      fullscreen?)
    (define/public (fullscreen on?)
      (if on?
	  (gtk_window_fullscreen gtk)
	  (gtk_window_unfullscreen gtk)))
      
    (def/public-unimplemented get-menu-bar)

    (define/public (set-title s)
      (set! saved-title s)
      (gtk_window_set_title gtk (if is-modified?
                                    (string-append s "*")
                                    s)))
    
    (define/public (display-changed) (void))))

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

(define-gdk gdk_screen_get_width (_fun _GdkScreen -> _int))
(define-gdk gdk_screen_get_height (_fun _GdkScreen -> _int))

(define-gdk gdk_screen_get_monitor_geometry (_fun _GdkScreen _int _GdkRectangle-pointer -> _void))
(define-gdk gdk_screen_get_n_monitors (_fun _GdkScreen -> _int))

(define (monitor-rect num fail)
  (let ([s (gdk_screen_get_default)]
	[r (make-GdkRectangle 0 0 0 0)])
    (unless (num . < . (gdk_screen_get_n_monitors s))
      (fail))
    (gdk_screen_get_monitor_geometry s num r)
    (cond
      ;; work around the upstream issue https://gitlab.gnome.org/GNOME/gtk/-/issues/2599
      [(and wayland?
            ;; for gtk3 >= 3.24.9 and < 3.24.42
            gtk3?
            (or
             (> (gtk_get_minor_version) 24)
             (and (= (gtk_get_minor_version) 24)
                  (>= (gtk_get_micro_version) 9)
                  (< (gtk_get_micro_version) 42))))
       (define scale (gdk_screen_get_monitor_scale_factor
                      (gdk_screen_get_default)
                      num))
       (make-GdkRectangle (floor (inexact->exact (/ (GdkRectangle-x r) scale)))
                          (floor (inexact->exact (/ (GdkRectangle-y r) scale)))
                          (floor (inexact->exact (/ (GdkRectangle-width r) scale)))
                          (floor (inexact->exact (/ (GdkRectangle-height r) scale))))]
      [else r])))

(define (display-origin x y all? num fail)
  (let ([r (monitor-rect num fail)])
    (set-box! x (->normal (- (GdkRectangle-x r))))
    (set-box! y (->normal (- (GdkRectangle-y r))))))

(define (display-size w h all? num fail)
  (let ([r (monitor-rect num fail)])
    (set-box! w (->normal (GdkRectangle-width r)))
    (set-box! h (->normal (GdkRectangle-height r)))))

(define (display-count)
  (gdk_screen_get_n_monitors (gdk_screen_get_default)))

(define (display-bitmap-resolution num fail)
  (define (get)
    (* (or (get-interface-scale-factor num)
           1.0)
       (gdk_screen_get_monitor_scale_factor
        (gdk_screen_get_default)
        num)))
  (if (zero? num)
      (get)
      (if (num . < . (gdk_screen_get_n_monitors (gdk_screen_get_default)))
          (get)
          (fail))))

(define (location->window x y)
  (for/or ([f (in-hash-keys all-frames)])
    (let ([fx (send f get-x)]
          [fw (send f get-width)])
      (and (<= fx x (+ fx fw))
           (let ([fy (send f get-y)]
                 [fh (send f get-height)])
             (<= fy y (+ fy fh)))
           f))))

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

(define (get-current-mouse-state)
  (define-values (x y mods) (gdk_window_get_pointer
                             (gdk_screen_get_root_window
                              (gdk_screen_get_default))))
  (define (maybe mask sym)
    (if (zero? (bitwise-and mods mask))
        null
        (list sym)))
  (values (make-object point% x y)
          (append
           (maybe GDK_BUTTON1_MASK 'left)
           (maybe GDK_BUTTON2_MASK 'middle)
           (maybe GDK_BUTTON3_MASK 'right)
           (maybe GDK_SHIFT_MASK 'shift)
           (maybe GDK_LOCK_MASK 'caps)
           (maybe GDK_CONTROL_MASK 'control)
           (maybe GDK_MOD1_MASK 'alt)
           (maybe GDK_META_MASK 'meta))))

(define (tell-all-frames-request-refresh-all-canvas-children)
  (tell-all-frames-something
   (λ (f)
     (send f request-refresh-all-canvas-children))))

(define (tell-all-frames-signal-changed n)
  (tell-all-frames-something
   (λ (f)
     (send f display-changed))))

(define (tell-all-frames-something proc)
  (define frames (for/list ([f (in-hash-keys all-frames)]) f))
  (for ([f (in-hash-keys all-frames)])
    (define e (send f get-eventspace))
    (unless (eventspace-shutdown? e)
      (parameterize ([current-eventspace e])
        (queue-callback
         (λ () 
           (proc f)))))))

(define-signal-handler 
  connect-monitor-changed-signal
  "monitors-changed"
  (_fun _GdkScreen -> _void)
  (λ (screen) (tell-all-frames-signal-changed 1)))

(define-signal-handler 
  connect-size-changed-signal
  "size-changed"
  (_fun _GdkScreen -> _void)
  (λ (screen) (tell-all-frames-signal-changed 2)))

(define-signal-handler 
  connect-composited-changed-signal
  "composited-changed"
  (_fun _GdkScreen -> _void)
  (λ (screen) (tell-all-frames-signal-changed 3)))

(define (screen-size-signal-connect connect-signal)
  (void (connect-signal (cast (gdk_screen_get_default) _GdkScreen _GtkWidget))))
(screen-size-signal-connect connect-monitor-changed-signal)
(screen-size-signal-connect connect-size-changed-signal)
(screen-size-signal-connect connect-composited-changed-signal)
