917 lines
34 KiB
Racket
917 lines
34 KiB
Racket
#lang racket/base
|
|
(require ffi/unsafe
|
|
ffi/unsafe/define
|
|
racket/class
|
|
net/uri-codec
|
|
ffi/unsafe/atomic
|
|
"../../syntax.rkt"
|
|
"../../lock.rkt"
|
|
"../common/event.rkt"
|
|
"../common/freeze.rkt"
|
|
"../common/queue.rkt"
|
|
"../common/local.rkt"
|
|
"../common/delay.rkt"
|
|
racket/draw/unsafe/bstr
|
|
"keycode.rkt"
|
|
"keymap.rkt"
|
|
"queue.rkt"
|
|
"utils.rkt"
|
|
"const.rkt"
|
|
"types.rkt"
|
|
"widget.rkt"
|
|
"clipboard.rkt")
|
|
|
|
(provide
|
|
(protect-out window%
|
|
queue-window-event
|
|
queue-window-refresh-event
|
|
|
|
gtk_widget_realize
|
|
gtk_container_add
|
|
gtk_widget_add_events
|
|
gtk_widget_size_request
|
|
gtk_widget_set_size_request
|
|
gtk_widget_size_allocate
|
|
gtk_widget_get_preferred_size
|
|
gtk_widget_grab_focus
|
|
gtk_widget_has_focus
|
|
gtk_widget_get_mapped
|
|
gtk_widget_get_has_window
|
|
gtk_widget_set_can_default
|
|
gtk_widget_set_can_focus
|
|
gtk_widget_set_sensitive
|
|
gtk_widget_get_scale_factor
|
|
|
|
connect-focus
|
|
connect-key
|
|
connect-key-and-mouse
|
|
connect-enter-and-leave
|
|
do-button-event
|
|
|
|
(struct-out GtkRequisition) _GtkRequisition-pointer
|
|
(struct-out GtkAllocation) _GtkAllocation-pointer
|
|
|
|
widget-window
|
|
widget-allocation
|
|
widget-parent
|
|
|
|
the-accelerator-group
|
|
gtk_window_add_accel_group
|
|
gtk_menu_set_accel_group
|
|
|
|
flush-display
|
|
gdk_display_get_default
|
|
|
|
request-flush-delay
|
|
cancel-flush-delay
|
|
win-box-valid?
|
|
window->win-box
|
|
unrealize-win-box)
|
|
gtk->wx
|
|
gtk_widget_show
|
|
gtk_widget_hide)
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define-gtk gtk_container_add (_fun _GtkWidget _GtkWidget -> _void))
|
|
(define-gtk gtk_container_remove (_fun _GtkWidget _GtkWidget -> _void))
|
|
(define-gtk gtk_widget_realize (_fun _GtkWidget -> _void))
|
|
(define-gtk gtk_widget_add_events (_fun _GtkWidget _int -> _void))
|
|
|
|
(define-gdk gdk_keyval_to_unicode (_fun _uint -> _uint32))
|
|
|
|
(define-gtk gtk_widget_get_display (_fun _GtkWidget -> _GdkDisplay))
|
|
(define-gtk gtk_widget_get_screen (_fun _GtkWidget -> _GdkScreen))
|
|
(define-gdk gdk_display_warp_pointer (_fun _GdkDisplay _GdkScreen _int _int -> _void))
|
|
|
|
(define-cstruct _GtkRequisition ([width _int]
|
|
[height _int]))
|
|
(define-cstruct _GtkAllocation ([x _int]
|
|
[y _int]
|
|
[width _int]
|
|
[height _int]))
|
|
|
|
(define-gtk gtk_widget_size_request (_fun _GtkWidget _GtkRequisition-pointer -> _void))
|
|
(define-gtk gtk_widget_size_allocate (_fun _GtkWidget _GtkAllocation-pointer -> _void))
|
|
(define-gtk gtk_widget_set_size_request (_fun _GtkWidget _int _int -> _void))
|
|
(define-gtk gtk_widget_grab_focus (_fun _GtkWidget -> _void))
|
|
(define-gtk gtk_widget_is_focus (_fun _GtkWidget -> _gboolean))
|
|
(define-gtk gtk_widget_set_sensitive (_fun _GtkWidget _gboolean -> _void))
|
|
(define-gtk gtk_widget_get_preferred_size (_fun _GtkWidget _GtkRequisition-pointer/null _GtkRequisition-pointer/null -> _void)
|
|
#:fail (lambda () #f))
|
|
(define-gtk gtk_widget_get_scale_factor (_fun _GtkWidget -> _int)
|
|
#:fail (lambda () (lambda (gtk) 1)))
|
|
|
|
(define-gdk gdk_keyboard_grab (_fun _GdkWindow _gboolean _int -> _void))
|
|
(define-gdk gdk_keyboard_ungrab (_fun _int -> _void))
|
|
|
|
(define _GtkAccelGroup (_cpointer 'GtkAccelGroup))
|
|
(define-gtk gtk_accel_group_new (_fun -> _GtkAccelGroup))
|
|
(define-gtk gtk_window_add_accel_group (_fun _GtkWindow _GtkAccelGroup -> _void))
|
|
(define-gtk gtk_menu_set_accel_group (_fun _GtkWidget _GtkAccelGroup -> _void))
|
|
|
|
(define the-accelerator-group (gtk_accel_group_new))
|
|
|
|
;; Only for Gtk2
|
|
(define-cstruct _GtkWidgetT ([obj _GtkObject]
|
|
[private_flags _uint16]
|
|
[state _byte]
|
|
[saved_state _byte]
|
|
[name _pointer]
|
|
[style _pointer]
|
|
[req _GtkRequisition]
|
|
[alloc _GtkAllocation]
|
|
[window _GdkWindow]
|
|
[parent _GtkWidget]))
|
|
|
|
(define-gtk widget-window (_fun _GtkWidget -> _GdkWindow)
|
|
#:c-id gtk_widget_get_window
|
|
#:fail (lambda ()
|
|
(lambda (gtk)
|
|
(GtkWidgetT-window (cast gtk _GtkWidget _GtkWidgetT-pointer)))))
|
|
|
|
(define-gtk widget-parent (_fun _GtkWidget -> _GtkWidget)
|
|
#:c-id gtk_widget_get_parent
|
|
#:fail (lambda ()
|
|
(lambda (gtk)
|
|
(GtkWidgetT-parent (cast gtk _GtkWidget _GtkWidgetT-pointer)))))
|
|
|
|
(define-gtk widget-allocation (_fun _GtkWidget (o : (_ptr o _GtkAllocation)) -> _void -> o)
|
|
#:c-id gtk_widget_get_allocation
|
|
#:fail (lambda ()
|
|
(lambda (gtk)
|
|
(GtkWidgetT-alloc (cast gtk _GtkWidget _GtkWidgetT-pointer)))))
|
|
|
|
;; Fallbacks for old Gtk2 versions:
|
|
(define ((get-one-flag flag [wrap values]) gtk)
|
|
(wrap (positive? (bitwise-and (get-gtk-object-flags gtk)
|
|
flag))))
|
|
(define ((set-one-flag! flag) gtk on?)
|
|
(define v (get-gtk-object-flags gtk))
|
|
(set-gtk-object-flags! gtk
|
|
(if on?
|
|
(bitwise-ior v flag)
|
|
(bitwise-and v (bitwise-not flag)))))
|
|
|
|
(define-gtk gtk_widget_has_focus (_fun _GtkWidget -> _gboolean)
|
|
#:fail (lambda () (get-one-flag GTK_HAS_FOCUS)))
|
|
(define-gtk gtk_widget_get_mapped (_fun _GtkWidget -> _gboolean)
|
|
#:fail (lambda () (get-one-flag GTK_MAPPED)))
|
|
(define-gtk gtk_widget_get_has_window (_fun _GtkWidget -> _gboolean)
|
|
#:fail (lambda () (get-one-flag GTK_NO_WINDOW not)))
|
|
(define-gtk gtk_widget_set_can_default (_fun _GtkWidget _gboolean -> _void)
|
|
#:fail (lambda () (set-one-flag! GTK_CAN_DEFAULT)))
|
|
(define-gtk gtk_widget_set_can_focus (_fun _GtkWidget _gboolean -> _void)
|
|
#:fail (lambda () (set-one-flag! GTK_CAN_FOCUS)))
|
|
|
|
(define-gtk gtk_drag_dest_add_uri_targets (_fun _GtkWidget -> _void))
|
|
(define-gtk gtk_drag_dest_set (_fun _GtkWidget _int (_pointer = #f) (_int = 0) _int -> _void))
|
|
(define-gtk gtk_drag_dest_unset (_fun _GtkWidget -> _void))
|
|
|
|
(define-gtk gdk_event_get_scroll_deltas (_fun _GdkEventScroll-pointer
|
|
(dx : (_ptr o _double))
|
|
(dy : (_ptr o _double))
|
|
-> _void
|
|
-> (values dx dy))
|
|
#:make-fail make-not-available)
|
|
|
|
(define GTK_DEST_DEFAULT_ALL #x07)
|
|
(define GDK_ACTION_COPY (arithmetic-shift 1 1))
|
|
|
|
(define-signal-handler connect-drag-data-received "drag-data-received"
|
|
(_fun _GtkWidget _pointer _int _int _GtkSelectionData _uint _uint -> _void)
|
|
(lambda (gtk context x y data info time)
|
|
(let ([wx (gtk->wx gtk)])
|
|
(when wx
|
|
(let ([bstr (scheme_make_sized_byte_string
|
|
(gtk_selection_data_get_data data)
|
|
(gtk_selection_data_get_length data)
|
|
1)])
|
|
(for ([m (regexp-match* #rx#"file://([^\r]*)\r\n" bstr
|
|
#:match-select cadr)])
|
|
(queue-window-event wx
|
|
(lambda ()
|
|
(let ([path
|
|
(string->path
|
|
(uri-decode
|
|
(bytes->string/utf-8 m)))])
|
|
(send wx on-drop-file path))))))))))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define-signal-handler connect-focus-in "focus-in-event"
|
|
(_fun _GtkWidget _GdkEventFocus-pointer -> _gboolean)
|
|
(lambda (gtk event)
|
|
(let ([wx (gtk->wx gtk)])
|
|
(when wx
|
|
(send wx focus-change #t)
|
|
(when (send wx on-focus? #t)
|
|
(queue-window-event wx (lambda () (send wx on-set-focus)))))
|
|
#f)))
|
|
(define-signal-handler connect-focus-out "focus-out-event"
|
|
(_fun _GtkWidget _GdkEventFocus-pointer -> _gboolean)
|
|
(lambda (gtk event)
|
|
(let ([wx (gtk->wx gtk)])
|
|
(when wx
|
|
(send wx focus-change #f)
|
|
(when (send wx on-focus? #f)
|
|
(queue-window-event wx (lambda () (send wx on-kill-focus)))))
|
|
#f)))
|
|
(define (connect-focus gtk)
|
|
(connect-focus-in gtk)
|
|
(connect-focus-out gtk))
|
|
|
|
(define-signal-handler connect-size-allocate "size-allocate"
|
|
(_fun _GtkWidget _GtkAllocation-pointer -> _gboolean)
|
|
(lambda (gtk a)
|
|
(let ([wx (gtk->wx gtk)])
|
|
(when wx
|
|
(send wx save-size
|
|
(->normal (GtkAllocation-x a))
|
|
(->normal (GtkAllocation-y a))
|
|
(->normal (GtkAllocation-width a))
|
|
(->normal (GtkAllocation-height a)))))
|
|
#t))
|
|
;; ----------------------------------------
|
|
|
|
(define-signal-handler connect-key-press "key-press-event"
|
|
(_fun _GtkWidget _GdkEventKey-pointer -> _gboolean)
|
|
(lambda (gtk event)
|
|
(do-key-event gtk event #t #f)))
|
|
|
|
(define-signal-handler connect-key-release "key-release-event"
|
|
(_fun _GtkWidget _GdkEventKey-pointer -> _gboolean)
|
|
(lambda (gtk event)
|
|
(do-key-event gtk event #f #f)))
|
|
|
|
(define-signal-handler connect-scroll "scroll-event"
|
|
(_fun _GtkWidget _GdkEventScroll-pointer -> _gboolean)
|
|
(lambda (gtk event)
|
|
(do-key-event gtk event #f #t)))
|
|
|
|
(define (do-key-event gtk event down? scroll?)
|
|
(let ([wx (gtk->wx gtk)])
|
|
(and
|
|
wx
|
|
(let ([im-str (if scroll?
|
|
'none
|
|
;; Result from `filter-key-event' is one of
|
|
;; - #f => drop the event
|
|
;; - 'none => no replacement; handle as usual
|
|
;; - a string => use as the keycode
|
|
(send wx filter-key-event event))])
|
|
(when im-str
|
|
(let* ([modifiers (if scroll?
|
|
(GdkEventScroll-state event)
|
|
(GdkEventKey-state event))]
|
|
[bit? (lambda (m v) (positive? (bitwise-and m v)))]
|
|
[keyval->code (lambda (kv)
|
|
(or
|
|
(map-key-code kv)
|
|
(integer->char (gdk_keyval_to_unicode kv))))]
|
|
[key-code (if scroll?
|
|
(let ([dir (GdkEventScroll-direction event)])
|
|
(cond
|
|
[(= dir GDK_SCROLL_UP) 'wheel-up]
|
|
[(= dir GDK_SCROLL_DOWN) 'wheel-down]
|
|
[(= dir GDK_SCROLL_LEFT) 'wheel-left]
|
|
[(= dir GDK_SCROLL_RIGHT) 'wheel-right]
|
|
[(= dir GDK_SCROLL_SMOOTH)
|
|
(define-values (dx dy) (gdk_event_get_scroll_deltas event))
|
|
(cond
|
|
[(positive? dy) 'wheel-down]
|
|
[(negative? dy) 'wheel-up]
|
|
[(positive? dx) 'wheel-right]
|
|
[(negative? dx) 'wheel-left]
|
|
[else #f])]
|
|
[else #f]))
|
|
(keyval->code (GdkEventKey-keyval event)))]
|
|
[k (new key-event%
|
|
[key-code (if (and (string? im-str)
|
|
(= 1 (string-length im-str)))
|
|
(string-ref im-str 0)
|
|
key-code)]
|
|
[shift-down (bit? modifiers GDK_SHIFT_MASK)]
|
|
[control-down (bit? modifiers GDK_CONTROL_MASK)]
|
|
[meta-down (bit? modifiers GDK_MOD1_MASK)]
|
|
[mod3-down (bit? modifiers GDK_MOD3_MASK)]
|
|
[mod4-down (bit? modifiers GDK_MOD4_MASK)]
|
|
[mod5-down (bit? modifiers GDK_MOD5_MASK)]
|
|
[alt-down (bit? modifiers GDK_META_MASK)]
|
|
[x 0]
|
|
[y 0]
|
|
[time-stamp (if scroll?
|
|
(GdkEventScroll-time event)
|
|
(GdkEventKey-time event))]
|
|
[caps-down (bit? modifiers GDK_LOCK_MASK)])])
|
|
(when (or (and (not scroll?)
|
|
(let-values ([(s ag sag cl) (get-alts event)]
|
|
[(keyval->code*) (lambda (v)
|
|
(and v
|
|
(let ([c (keyval->code v)])
|
|
(and (not (equal? #\u0000 c))
|
|
c))))])
|
|
(let ([s (keyval->code* s)]
|
|
[ag (keyval->code* ag)]
|
|
[sag (keyval->code* sag)]
|
|
[cl (keyval->code* cl)])
|
|
(when s (send k set-other-shift-key-code s))
|
|
(when ag (send k set-other-altgr-key-code ag))
|
|
(when sag (send k set-other-shift-altgr-key-code sag))
|
|
(when cl (send k set-other-caps-key-code cl))
|
|
(or s ag sag cl))))
|
|
(not (equal? #\u0000 key-code)))
|
|
(unless (or scroll? down?)
|
|
;; swap altenate with main
|
|
(send k set-key-release-code (send k get-key-code))
|
|
(send k set-key-code 'release))
|
|
(if (send wx handles-events? gtk)
|
|
(begin
|
|
(queue-window-event wx (lambda () (send wx dispatch-on-char k #f)))
|
|
#t)
|
|
(constrained-reply (send wx get-eventspace)
|
|
(lambda () (send wx dispatch-on-char k #t))
|
|
#t)))))))))
|
|
|
|
(define-signal-handler connect-button-press "button-press-event"
|
|
(_fun _GtkWidget _GdkEventButton-pointer -> _gboolean)
|
|
(lambda (gtk event)
|
|
(unless (gtk_widget_is_focus gtk)
|
|
(let ([wx (gtk->wx gtk)])
|
|
(when wx
|
|
(unless (other-modal? wx)
|
|
(gtk_widget_grab_focus gtk)))))
|
|
(do-button-event gtk event #f #f)))
|
|
|
|
(define-signal-handler connect-button-release "button-release-event"
|
|
(_fun _GtkWidget _GdkEventButton-pointer -> _gboolean)
|
|
(lambda (gtk event)
|
|
(do-button-event gtk event #f #f)))
|
|
|
|
(define-signal-handler connect-pointer-motion "motion-notify-event"
|
|
(_fun _GtkWidget _GdkEventMotion-pointer -> _gboolean)
|
|
(lambda (gtk event)
|
|
(do-button-event gtk event #t #f)))
|
|
|
|
(define-signal-handler connect-enter "enter-notify-event"
|
|
(_fun _GtkWidget _GdkEventCrossing-pointer -> _gboolean)
|
|
(lambda (gtk event)
|
|
(let ([wx (gtk->wx gtk)]) (when wx (send wx enter-window)))
|
|
(do-button-event gtk event #f #t)))
|
|
|
|
(define-signal-handler connect-leave "leave-notify-event"
|
|
(_fun _GtkWidget _GdkEventCrossing-pointer -> _gboolean)
|
|
(lambda (gtk event)
|
|
(let ([wx (gtk->wx gtk)]) (when wx (send wx leave-window)))
|
|
(do-button-event gtk event #f #t)))
|
|
|
|
(define (connect-enter-and-leave gtk)
|
|
(connect-enter gtk)
|
|
(connect-leave gtk))
|
|
|
|
(define (connect-key gtk)
|
|
(connect-key-press gtk)
|
|
(connect-key-release gtk))
|
|
|
|
(define (connect-key-and-mouse gtk [skip-press? #f])
|
|
(connect-key gtk)
|
|
(connect-scroll gtk)
|
|
(connect-button-press gtk)
|
|
(unless skip-press? (connect-button-release gtk))
|
|
(connect-pointer-motion gtk)
|
|
(connect-enter-and-leave gtk))
|
|
|
|
(define (do-button-event gtk event motion? crossing?)
|
|
(let ([type (if motion?
|
|
GDK_MOTION_NOTIFY
|
|
(if crossing?
|
|
(GdkEventCrossing-type event)
|
|
(GdkEventButton-type event)))])
|
|
(let ([wx (gtk->wx gtk)])
|
|
(when (or (= type GDK_BUTTON_PRESS)
|
|
(= type GDK_2BUTTON_PRESS)
|
|
(= type GDK_3BUTTON_PRESS))
|
|
(let ([floating? (send wx in-floating?)])
|
|
(if floating?
|
|
(gdk_keyboard_grab (widget-window gtk) #t 0)
|
|
(gdk_keyboard_ungrab 0))))
|
|
(and
|
|
wx
|
|
(if (or (= type GDK_2BUTTON_PRESS)
|
|
(= type GDK_3BUTTON_PRESS)
|
|
(and (or (= type GDK_ENTER_NOTIFY)
|
|
(= type GDK_LEAVE_NOTIFY))
|
|
(send wx skip-enter-leave-events)))
|
|
#t
|
|
(let* ([modifiers (if motion?
|
|
(GdkEventMotion-state event)
|
|
(if crossing?
|
|
(GdkEventCrossing-state event)
|
|
(GdkEventButton-state event)))]
|
|
[bit? (lambda (m v) (positive? (bitwise-and m v)))]
|
|
[type (cond
|
|
[(= type GDK_MOTION_NOTIFY)
|
|
'motion]
|
|
[(= type GDK_ENTER_NOTIFY)
|
|
'enter]
|
|
[(= type GDK_LEAVE_NOTIFY)
|
|
'leave]
|
|
[(= type GDK_BUTTON_PRESS)
|
|
(case (GdkEventButton-button event)
|
|
[(1) 'left-down]
|
|
[(3) 'right-down]
|
|
[else 'middle-down])]
|
|
[else
|
|
(case (GdkEventButton-button event)
|
|
[(1) 'left-up]
|
|
[(3) 'right-up]
|
|
[else 'middle-up])])]
|
|
[m (let-values ([(x y)
|
|
(send wx
|
|
adjust-event-position
|
|
(->normal
|
|
(->long ((if motion?
|
|
GdkEventMotion-x
|
|
(if crossing? GdkEventCrossing-x GdkEventButton-x))
|
|
event)))
|
|
(->normal
|
|
(->long ((if motion? GdkEventMotion-y
|
|
(if crossing? GdkEventCrossing-y GdkEventButton-y))
|
|
event))))])
|
|
(new mouse-event%
|
|
[event-type type]
|
|
[left-down (case type
|
|
[(left-down) #t]
|
|
[(left-up) #f]
|
|
[else (bit? modifiers GDK_BUTTON1_MASK)])]
|
|
[middle-down (case type
|
|
[(middle-down) #t]
|
|
[(middle-up) #f]
|
|
[else (bit? modifiers GDK_BUTTON2_MASK)])]
|
|
[right-down (case type
|
|
[(right-down) #t]
|
|
[(right-up) #f]
|
|
[else (bit? modifiers GDK_BUTTON3_MASK)])]
|
|
[x x]
|
|
[y y]
|
|
[shift-down (bit? modifiers GDK_SHIFT_MASK)]
|
|
[control-down (bit? modifiers GDK_CONTROL_MASK)]
|
|
[meta-down (bit? modifiers GDK_META_MASK)]
|
|
[alt-down (bit? modifiers GDK_MOD1_MASK)]
|
|
[mod3-down (bit? modifiers GDK_MOD3_MASK)]
|
|
[mod4-down (bit? modifiers GDK_MOD4_MASK)]
|
|
[mod5-down (bit? modifiers GDK_MOD5_MASK)]
|
|
[time-stamp ((if motion? GdkEventMotion-time
|
|
(if crossing? GdkEventCrossing-time GdkEventButton-time))
|
|
event)]
|
|
[caps-down (bit? modifiers GDK_LOCK_MASK)]))])
|
|
(if (send wx handles-events? gtk)
|
|
(begin
|
|
(queue-window-event wx (lambda ()
|
|
(send wx dispatch-on-event m #f)))
|
|
#t)
|
|
(constrained-reply (send wx get-eventspace)
|
|
(lambda () (or (send wx dispatch-on-event m #t)
|
|
(send wx internal-pre-on-event gtk m)))
|
|
#t
|
|
#:fail-result
|
|
;; an enter event is synthesized when a button is
|
|
;; enabled and the mouse is over the button, and the
|
|
;; event is not dispatched via the eventspace; leave
|
|
;; events are perhaps similarly synthesized, so allow
|
|
;; them, too
|
|
(if (or (eq? type 'enter) (eq? type 'leave))
|
|
#f
|
|
#t)))))))))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define (internal-error str)
|
|
(log-error
|
|
(apply string-append
|
|
(format "internal error: ~a" str)
|
|
(append
|
|
(for/list ([c (continuation-mark-set->context (current-continuation-marks))])
|
|
(let ([name (car c)]
|
|
[loc (cdr c)])
|
|
(cond
|
|
[loc
|
|
(string-append
|
|
"\n"
|
|
(cond
|
|
[(srcloc-line loc)
|
|
(format "~a:~a:~a"
|
|
(srcloc-source loc)
|
|
(srcloc-line loc)
|
|
(srcloc-column loc))]
|
|
[else
|
|
(format "~a::~a"
|
|
(srcloc-source loc)
|
|
(srcloc-position loc))])
|
|
(if name (format " ~a" name) ""))]
|
|
[else (format "\n ~a" name)])))
|
|
'("\n")))))
|
|
|
|
(define window%
|
|
(class widget%
|
|
(init-field parent
|
|
gtk)
|
|
(init [no-show? #f]
|
|
[extra-gtks null]
|
|
[add-to-parent? #t]
|
|
[connect-size-allocate? #t])
|
|
|
|
(super-new [gtk gtk]
|
|
[extra-gtks extra-gtks]
|
|
[parent parent])
|
|
|
|
(define save-x (get-unset-pos))
|
|
(define save-y (get-unset-pos))
|
|
(define save-w 0)
|
|
(define save-h 0)
|
|
|
|
(define/public (get-unset-pos) 0)
|
|
|
|
(when connect-size-allocate?
|
|
(connect-size-allocate gtk))
|
|
|
|
(when add-to-parent?
|
|
(gtk_container_add (send parent get-container-gtk) gtk))
|
|
|
|
(define/public (get-gtk) gtk)
|
|
(define/public (get-client-gtk) gtk)
|
|
(define/public (get-container-gtk) (get-client-gtk))
|
|
(define/public (get-window-gtk) (send parent get-window-gtk))
|
|
|
|
(define/public (move x y)
|
|
(set-size x y -1 -1))
|
|
|
|
(define/public (set-size x y w h)
|
|
(unless (and (or (not x) (equal? save-x x))
|
|
(or (not y) (equal? save-y y))
|
|
(or (= w -1) (= save-w (max w client-delta-w)))
|
|
(or (= h -1) (= save-h (max h client-delta-h))))
|
|
(unless (not x) (set! save-x x))
|
|
(unless (not y) (set! save-y y))
|
|
(unless (= w -1) (set! save-w w))
|
|
(unless (= h -1) (set! save-h h))
|
|
(set! save-w (max save-w client-delta-w))
|
|
(set! save-h (max save-h client-delta-h))
|
|
(really-set-size gtk x y (or save-x 0) (or save-y 0) save-w save-h)
|
|
(queue-on-size)))
|
|
|
|
(define/public (save-size x y w h)
|
|
(set! save-w w)
|
|
(set! save-h h))
|
|
|
|
(define/public (really-set-size gtk given-x given-y x y w h)
|
|
(send parent set-child-size gtk x y w h))
|
|
|
|
(define/public (set-child-size child-gtk x y w h)
|
|
(gtk_widget_set_size_request child-gtk (->screen w) (->screen h))
|
|
(gtk_widget_size_allocate child-gtk (make-GtkAllocation (->screen x) (->screen y)
|
|
(->screen w) (->screen h))))
|
|
|
|
(define/public (remember-size x y w h)
|
|
;; called in event-pump thread
|
|
(unless (and (= save-w w)
|
|
(= save-h h)
|
|
(equal? save-x x)
|
|
(equal? save-y y))
|
|
(set! save-w w)
|
|
(set! save-h h)
|
|
(set! save-x x)
|
|
(set! save-y y)
|
|
(queue-on-size)))
|
|
|
|
(define/public (queue-on-size) (void))
|
|
|
|
(define client-delta-w 0)
|
|
(define client-delta-h 0)
|
|
|
|
(define/public (adjust-client-delta dw dh)
|
|
(set! client-delta-w dw)
|
|
(set! client-delta-h dh))
|
|
|
|
(define/public (infer-client-delta [w? #t] [h? #t] [sub-h-gtk #f]
|
|
#:inside [inside-gtk (get-container-gtk)])
|
|
(let ([req (make-GtkRequisition 0 0)]
|
|
[creq (make-GtkRequisition 0 0)]
|
|
[hreq (make-GtkRequisition 0 0)])
|
|
(when gtk3? (gtk_widget_show gtk))
|
|
(gtk_widget_size_request gtk req)
|
|
(gtk_widget_size_request inside-gtk creq)
|
|
(when sub-h-gtk
|
|
(gtk_widget_size_request sub-h-gtk hreq))
|
|
(when w?
|
|
(set! client-delta-w (->normal
|
|
(- (GtkRequisition-width req)
|
|
(max (GtkRequisition-width creq)
|
|
(GtkRequisition-width hreq))))))
|
|
(when h?
|
|
(set! client-delta-h (->normal
|
|
(- (GtkRequisition-height req)
|
|
(GtkRequisition-height creq)))))
|
|
(when gtk3? (gtk_widget_show gtk))))
|
|
|
|
(define/public (set-auto-size [dw 0] [dh 0])
|
|
(let ([req (make-GtkRequisition 0 0)])
|
|
(cond
|
|
[gtk3?
|
|
(unless shown? (gtk_widget_show gtk))
|
|
(gtk_widget_get_preferred_size gtk req #f)
|
|
(unless shown? (gtk_widget_hide gtk))]
|
|
[else (gtk_widget_size_request gtk req)])
|
|
(set-size #f
|
|
#f
|
|
(+ (->normal (GtkRequisition-width req)) dw)
|
|
(+ (->normal (GtkRequisition-height req)) dh))))
|
|
|
|
(define shown? #f)
|
|
(define/public (direct-show on?)
|
|
;; atomic mode
|
|
(if on?
|
|
(gtk_widget_show gtk)
|
|
(gtk_widget_hide gtk))
|
|
(set! shown? (and on? #t))
|
|
(register-child-in-parent on?)
|
|
(when on? (reset-child-dcs)))
|
|
(define/public (show on?)
|
|
(atomically
|
|
(direct-show on?)))
|
|
(define/public (reset-child-freezes) (void))
|
|
(define/public (reset-child-dcs) (void))
|
|
(define/public (is-shown?) shown?)
|
|
(define/public (is-shown-to-root?)
|
|
(and shown?
|
|
(if parent
|
|
(send parent is-shown-to-root?)
|
|
#t)))
|
|
|
|
(unless no-show? (show #t))
|
|
|
|
(define/public (get-x) (or save-x 0))
|
|
(define/public (get-y) (or save-y 0))
|
|
(define/public (get-width) save-w)
|
|
(define/public (get-height) save-h)
|
|
|
|
(define/public (get-parent) parent)
|
|
(define/public (set-parent p)
|
|
;; in atomic mode
|
|
(reset-child-freezes)
|
|
(g_object_ref gtk)
|
|
(gtk_container_remove (send parent get-container-gtk) gtk)
|
|
(set! parent p)
|
|
(gtk_container_add (send parent get-container-gtk) gtk)
|
|
(set! save-x 0)
|
|
(set! save-y 0)
|
|
(g_object_unref gtk))
|
|
|
|
(define/public (get-top-win) (send parent get-top-win))
|
|
|
|
(define/public (get-dialog-level) (send parent get-dialog-level))
|
|
|
|
(define/public (get-size xb yb)
|
|
(set-box! xb save-w)
|
|
(set-box! yb save-h))
|
|
(define/public (get-client-size xb yb)
|
|
(get-size xb yb)
|
|
(set-box! xb (max 0 (- (unbox xb) client-delta-w)))
|
|
(set-box! yb (max 0 (- (unbox yb) client-delta-h))))
|
|
|
|
(define enabled? #t)
|
|
(define/pubment (is-enabled-to-root?)
|
|
(and enabled?
|
|
(inner (send parent is-enabled-to-root?)
|
|
is-enabled-to-root?)))
|
|
(define/public (enable on?)
|
|
(set! enabled? on?)
|
|
(gtk_widget_set_sensitive gtk on?))
|
|
(define/public (is-window-enabled?) enabled?)
|
|
|
|
(define drag-connected? #f)
|
|
(define/public (drag-accept-files on?)
|
|
(if on?
|
|
(begin
|
|
(unless drag-connected?
|
|
(connect-drag-data-received gtk)
|
|
(set! drag-connected? #t))
|
|
(gtk_drag_dest_set gtk GTK_DEST_DEFAULT_ALL GDK_ACTION_COPY)
|
|
(gtk_drag_dest_add_uri_targets gtk))
|
|
(gtk_drag_dest_unset gtk)))
|
|
|
|
(define/public (in-floating?)
|
|
(send parent in-floating?))
|
|
|
|
(define/public (set-focus)
|
|
(gtk_widget_grab_focus (get-client-gtk)))
|
|
|
|
(define cursor-handle #f)
|
|
(define/public (set-cursor v)
|
|
(set! cursor-handle (and v
|
|
(send (send v get-driver) get-handle)))
|
|
(check-window-cursor this))
|
|
(define/public (enter-window)
|
|
(set-window-cursor this #f))
|
|
(define/public (leave-window)
|
|
(when parent
|
|
(send parent enter-window)))
|
|
(define/public (set-window-cursor in-win c)
|
|
(set-parent-window-cursor in-win (or c cursor-handle)))
|
|
(define/public (set-parent-window-cursor in-win c)
|
|
(when parent
|
|
(send parent set-window-cursor in-win c)))
|
|
(define/public (check-window-cursor win)
|
|
(when parent
|
|
(send parent check-window-cursor win)))
|
|
|
|
(define/public (on-set-focus) (void))
|
|
(define/public (on-kill-focus) (void))
|
|
|
|
(define/public (focus-change on?) (void))
|
|
(define/public (filter-key-event e) 'none)
|
|
|
|
(define/public (on-focus? on?) #t)
|
|
|
|
(define/private (pre-event-refresh)
|
|
;; Since we break the connection between the
|
|
;; Gtk queue and event handling, we
|
|
;; re-sync the display in case a stream of
|
|
;; events (e.g., key repeat) have a corresponding
|
|
;; stream of screen updates.
|
|
(flush-display))
|
|
|
|
(define/public (handles-events? gtk) #f)
|
|
(define/public (dispatch-on-char e just-pre?)
|
|
(pre-event-refresh)
|
|
(cond
|
|
[(other-modal? this) #t]
|
|
[(call-pre-on-char this e) #t]
|
|
[just-pre? #f]
|
|
[else (when enabled? (on-char e)) #t]))
|
|
(define/public (dispatch-on-event e just-pre?)
|
|
(pre-event-refresh)
|
|
(cond
|
|
[(other-modal? this e) #t]
|
|
[(call-pre-on-event this e) #t]
|
|
[just-pre? #f]
|
|
[else (when enabled? (on-event e)) #t]))
|
|
|
|
(define/public (internal-pre-on-event gtk e) #f)
|
|
|
|
(define/public (call-pre-on-event w e)
|
|
(or (send parent call-pre-on-event w e)
|
|
(pre-on-event w e)))
|
|
(define/public (call-pre-on-char w e)
|
|
(or (send parent call-pre-on-char w e)
|
|
(pre-on-char w e)))
|
|
(define/public (pre-on-event w e) #f)
|
|
(define/public (pre-on-char w e) #f)
|
|
|
|
(define/public (on-char e) (void))
|
|
(define/public (on-event e) (void))
|
|
|
|
(define skip-enter-leave? #f)
|
|
(define/public skip-enter-leave-events
|
|
(case-lambda
|
|
[(skip?) (set! skip-enter-leave? skip?)]
|
|
[else skip-enter-leave?]))
|
|
|
|
(define/public (register-child child on?)
|
|
(void))
|
|
(define/public (register-child-in-parent on?)
|
|
(when parent
|
|
(send parent register-child this on?)))
|
|
|
|
(define/public (paint-children)
|
|
(void))
|
|
|
|
(define/public (on-drop-file path) (void))
|
|
|
|
(define/public (get-handle) (get-gtk))
|
|
(define/public (get-client-handle) (get-container-gtk))
|
|
|
|
(define/public (popup-menu m x y)
|
|
(let ([gx (box x)]
|
|
[gy (box y)])
|
|
(client-to-screen gx gy)
|
|
(send m popup (unbox gx) (unbox gy)
|
|
(lambda (thunk) (queue-window-event this thunk)))))
|
|
|
|
(define/public (center a b) (void))
|
|
(define/public (refresh) (refresh-all-children))
|
|
|
|
(define/public (refresh-all-children) (void))
|
|
|
|
(define/public (screen-to-client x y)
|
|
(internal-screen-to-client x y))
|
|
(define/public (internal-screen-to-client x y)
|
|
(let ([xb (box 0)]
|
|
[yb (box 0)])
|
|
(internal-client-to-screen xb yb)
|
|
(set-box! x (- (unbox x) (unbox xb)))
|
|
(set-box! y (- (unbox y) (unbox yb)))))
|
|
(define/public (client-to-screen x y)
|
|
(internal-client-to-screen x y))
|
|
(define/public (internal-client-to-screen x y)
|
|
(let-values ([(dx dy) (get-client-delta)])
|
|
(send parent internal-client-to-screen x y)
|
|
(set-box! x (+ (unbox x) save-x dx))
|
|
(set-box! y (+ (unbox y) save-y dy))))
|
|
|
|
(define event-position-wrt-wx #f)
|
|
(define/public (set-event-positions-wrt wx)
|
|
(set! event-position-wrt-wx wx))
|
|
|
|
(define/public (adjust-event-position x y)
|
|
(if event-position-wrt-wx
|
|
(let ([xb (box x)]
|
|
[yb (box y)])
|
|
(internal-client-to-screen xb yb)
|
|
(send event-position-wrt-wx internal-screen-to-client xb yb)
|
|
(values (unbox xb) (unbox yb)))
|
|
(values x y)))
|
|
|
|
(define/public (get-client-delta)
|
|
(values 0 0))
|
|
(define/public (get-stored-client-delta)
|
|
(values client-delta-w client-delta-h))
|
|
|
|
(define/public (warp-pointer x y)
|
|
(define xb (box x))
|
|
(define yb (box y))
|
|
(client-to-screen xb yb)
|
|
(gdk_display_warp_pointer (gtk_widget_get_display gtk)
|
|
(gtk_widget_get_screen gtk)
|
|
(->screen (unbox xb))
|
|
(->screen (unbox yb))))
|
|
|
|
(define/public (gets-focus?) #t)))
|
|
|
|
(define (queue-window-event win thunk)
|
|
(queue-event (send win get-eventspace) thunk))
|
|
(define (queue-window-refresh-event win thunk)
|
|
(queue-refresh-event (send win get-eventspace) thunk))
|
|
|
|
(define-gdk gdk_display_flush (_fun _GdkDisplay -> _void))
|
|
(define-gdk gdk_display_get_default (_fun -> _GdkDisplay))
|
|
(define (flush-display)
|
|
(try-to-sync-refresh)
|
|
(gdk_window_process_all_updates)
|
|
(gdk_display_flush (gdk_display_get_default)))
|
|
|
|
(define-gdk gdk_window_freeze_updates (_fun _GdkWindow -> _void))
|
|
(define-gdk gdk_window_thaw_updates (_fun _GdkWindow -> _void))
|
|
(define-gdk gdk_window_invalidate_rect (_fun _GdkWindow _pointer _gboolean -> _void))
|
|
(define-gdk gdk_window_process_all_updates (_fun -> _void))
|
|
(define-gdk gdk_window_ensure_native (_fun _GdkWindow -> _gboolean)
|
|
;; Requires 2.18
|
|
#:fail (lambda () (lambda (win) #f)))
|
|
|
|
(define (win-box-valid? win-box)
|
|
(mcar win-box))
|
|
(define (window->win-box win)
|
|
(mcons win 0))
|
|
(define (unrealize-win-box win-box)
|
|
(let ([win (mcar win-box)])
|
|
(when win
|
|
(set-mcar! win-box #f)
|
|
(for ([i (in-range (mcdr win-box))])
|
|
(gdk_window_thaw_updates win)))))
|
|
|
|
(define (request-flush-delay win-box transparentish?)
|
|
(do-request-flush-delay
|
|
win-box
|
|
(lambda (win-box)
|
|
(let ([win (mcar win-box)])
|
|
(and win
|
|
;; The freeze/thaw state is actually with the window's
|
|
;; implementation, so force a native implementation of the
|
|
;; window to try to avoid it changing out from underneath
|
|
;; us between the freeze and thaw actions.
|
|
;; With Gtk3, we can't use a native window for transparent
|
|
;; windows; that means we have to be extra careful that
|
|
;; the underlying window doesn't change while a freeze is
|
|
;; in effect; the `reset-child-freezes` helps with that.
|
|
(unless (and transparentish? gtk3?)
|
|
(gdk_window_ensure_native win))
|
|
(begin
|
|
(gdk_window_freeze_updates win)
|
|
(set-mcdr! win-box (add1 (mcdr win-box)))
|
|
#t))))
|
|
(lambda (win-box)
|
|
(let ([win (mcar win-box)])
|
|
(when win
|
|
(gdk_window_thaw_updates win)
|
|
(set-mcdr! win-box (sub1 (mcdr win-box))))))))
|
|
|
|
(define (cancel-flush-delay req)
|
|
(when req
|
|
(do-cancel-flush-delay
|
|
req
|
|
(lambda (win-box)
|
|
(let ([win (mcar win-box)])
|
|
(when win
|
|
(gdk_window_thaw_updates win)
|
|
(set-mcdr! win-box (sub1 (mcdr win-box)))))))))
|