1#lang racket/base 2(require ffi/unsafe 3 ffi/unsafe/define 4 racket/class 5 net/uri-codec 6 ffi/unsafe/atomic 7 "../../syntax.rkt" 8 "../../lock.rkt" 9 "../common/event.rkt" 10 "../common/freeze.rkt" 11 "../common/queue.rkt" 12 "../common/local.rkt" 13 "../common/delay.rkt" 14 racket/draw/unsafe/bstr 15 "keycode.rkt" 16 "keymap.rkt" 17 "queue.rkt" 18 "utils.rkt" 19 "const.rkt" 20 "types.rkt" 21 "widget.rkt" 22 "clipboard.rkt") 23 24(provide 25 (protect-out window% 26 queue-window-event 27 queue-window-refresh-event 28 29 gtk_widget_realize 30 gtk_container_add 31 gtk_widget_add_events 32 gtk_widget_size_request 33 gtk_widget_set_size_request 34 gtk_widget_size_allocate 35 gtk_widget_get_preferred_size 36 gtk_widget_grab_focus 37 gtk_widget_has_focus 38 gtk_widget_get_mapped 39 gtk_widget_get_has_window 40 gtk_widget_set_can_default 41 gtk_widget_set_can_focus 42 gtk_widget_set_sensitive 43 gtk_widget_get_scale_factor 44 45 connect-focus 46 connect-key 47 connect-key-and-mouse 48 connect-enter-and-leave 49 do-button-event 50 51 (struct-out GtkRequisition) _GtkRequisition-pointer 52 (struct-out GtkAllocation) _GtkAllocation-pointer 53 54 widget-window 55 widget-allocation 56 widget-parent 57 58 avoid-preferred-size-warning 59 60 the-accelerator-group 61 gtk_window_add_accel_group 62 gtk_menu_set_accel_group 63 64 flush-display 65 gdk_display_get_default 66 67 request-flush-delay 68 cancel-flush-delay 69 win-box-valid? 70 window->win-box 71 unrealize-win-box) 72 gtk->wx 73 gtk_widget_show 74 gtk_widget_hide) 75 76;; ---------------------------------------- 77 78(define-gtk gtk_container_add (_fun _GtkWidget _GtkWidget -> _void)) 79(define-gtk gtk_container_remove (_fun _GtkWidget _GtkWidget -> _void)) 80(define-gtk gtk_widget_realize (_fun _GtkWidget -> _void)) 81(define-gtk gtk_widget_add_events (_fun _GtkWidget _int -> _void)) 82 83(define-gdk gdk_keyval_to_unicode (_fun _uint -> _uint32)) 84 85(define-gtk gtk_widget_get_display (_fun _GtkWidget -> _GdkDisplay)) 86(define-gtk gtk_widget_get_screen (_fun _GtkWidget -> _GdkScreen)) 87(define-gdk gdk_display_warp_pointer (_fun _GdkDisplay _GdkScreen _int _int -> _void)) 88 89(define-cstruct _GtkRequisition ([width _int] 90 [height _int])) 91(define-cstruct _GtkAllocation ([x _int] 92 [y _int] 93 [width _int] 94 [height _int])) 95 96(define-gtk gtk_widget_size_request (_fun _GtkWidget _GtkRequisition-pointer -> _void)) 97(define-gtk gtk_widget_size_allocate (_fun _GtkWidget _GtkAllocation-pointer -> _void)) 98(define-gtk gtk_widget_set_size_request (_fun _GtkWidget _int _int -> _void)) 99(define-gtk gtk_widget_grab_focus (_fun _GtkWidget -> _void)) 100(define-gtk gtk_widget_is_focus (_fun _GtkWidget -> _gboolean)) 101(define-gtk gtk_widget_set_sensitive (_fun _GtkWidget _gboolean -> _void)) 102(define-gtk gtk_widget_get_preferred_size (_fun _GtkWidget _GtkRequisition-pointer/null _GtkRequisition-pointer/null -> _void) 103 #:fail (lambda () #f)) 104(define-gtk gtk_widget_get_scale_factor (_fun _GtkWidget -> _int) 105 #:fail (lambda () (lambda (gtk) 1))) 106 107(define (avoid-preferred-size-warning gtk) 108 ;; If we don't ask for a widget's size in the right way, 109 ;; GTK3 may report a warning; this query avoids the 110 ;; warning. 111 (when gtk3? 112 (define req (make-GtkRequisition 0 0)) 113 (gtk_widget_get_preferred_size gtk req #f))) 114 115(define-gdk gdk_keyboard_grab (_fun _GdkWindow _gboolean _int -> _void)) 116(define-gdk gdk_keyboard_ungrab (_fun _int -> _void)) 117 118(define _GtkAccelGroup (_cpointer 'GtkAccelGroup)) 119(define-gtk gtk_accel_group_new (_fun -> _GtkAccelGroup)) 120(define-gtk gtk_window_add_accel_group (_fun _GtkWindow _GtkAccelGroup -> _void)) 121(define-gtk gtk_menu_set_accel_group (_fun _GtkWidget _GtkAccelGroup -> _void)) 122 123(define the-accelerator-group (gtk_accel_group_new)) 124 125;; Only for Gtk2 126(define-cstruct _GtkWidgetT ([obj _GtkObject] 127 [private_flags _uint16] 128 [state _byte] 129 [saved_state _byte] 130 [name _pointer] 131 [style _pointer] 132 [req _GtkRequisition] 133 [alloc _GtkAllocation] 134 [window _GdkWindow] 135 [parent _GtkWidget])) 136 137(define-gtk widget-window (_fun _GtkWidget -> _GdkWindow) 138 #:c-id gtk_widget_get_window 139 #:fail (lambda () 140 (lambda (gtk) 141 (GtkWidgetT-window (cast gtk _GtkWidget _GtkWidgetT-pointer))))) 142 143(define-gtk widget-parent (_fun _GtkWidget -> _GtkWidget) 144 #:c-id gtk_widget_get_parent 145 #:fail (lambda () 146 (lambda (gtk) 147 (GtkWidgetT-parent (cast gtk _GtkWidget _GtkWidgetT-pointer))))) 148 149(define-gtk widget-allocation (_fun _GtkWidget (o : (_ptr o _GtkAllocation)) -> _void -> o) 150 #:c-id gtk_widget_get_allocation 151 #:fail (lambda () 152 (lambda (gtk) 153 (GtkWidgetT-alloc (cast gtk _GtkWidget _GtkWidgetT-pointer))))) 154 155;; Fallbacks for old Gtk2 versions: 156(define ((get-one-flag flag [wrap values]) gtk) 157 (wrap (positive? (bitwise-and (get-gtk-object-flags gtk) 158 flag)))) 159(define ((set-one-flag! flag) gtk on?) 160 (define v (get-gtk-object-flags gtk)) 161 (set-gtk-object-flags! gtk 162 (if on? 163 (bitwise-ior v flag) 164 (bitwise-and v (bitwise-not flag))))) 165 166(define-gtk gtk_widget_has_focus (_fun _GtkWidget -> _gboolean) 167 #:fail (lambda () (get-one-flag GTK_HAS_FOCUS))) 168(define-gtk gtk_widget_get_mapped (_fun _GtkWidget -> _gboolean) 169 #:fail (lambda () (get-one-flag GTK_MAPPED))) 170(define-gtk gtk_widget_get_has_window (_fun _GtkWidget -> _gboolean) 171 #:fail (lambda () (get-one-flag GTK_NO_WINDOW not))) 172(define-gtk gtk_widget_set_can_default (_fun _GtkWidget _gboolean -> _void) 173 #:fail (lambda () (set-one-flag! GTK_CAN_DEFAULT))) 174(define-gtk gtk_widget_set_can_focus (_fun _GtkWidget _gboolean -> _void) 175 #:fail (lambda () (set-one-flag! GTK_CAN_FOCUS))) 176 177(define-gtk gtk_drag_dest_add_uri_targets (_fun _GtkWidget -> _void)) 178(define-gtk gtk_drag_dest_set (_fun _GtkWidget _int (_pointer = #f) (_int = 0) _int -> _void)) 179(define-gtk gtk_drag_dest_unset (_fun _GtkWidget -> _void)) 180 181(define-gtk gdk_event_get_scroll_deltas (_fun _GdkEventScroll-pointer 182 (dx : (_ptr o _double)) 183 (dy : (_ptr o _double)) 184 -> _void 185 -> (values dx dy)) 186 #:make-fail make-not-available) 187 188(define GTK_DEST_DEFAULT_ALL #x07) 189(define GDK_ACTION_COPY (arithmetic-shift 1 1)) 190 191(define-signal-handler connect-drag-data-received "drag-data-received" 192 (_fun _GtkWidget _pointer _int _int _GtkSelectionData _uint _uint -> _void) 193 (lambda (gtk context x y data info time) 194 (let ([wx (gtk->wx gtk)]) 195 (when wx 196 (let ([bstr (scheme_make_sized_byte_string 197 (gtk_selection_data_get_data data) 198 (gtk_selection_data_get_length data) 199 1)]) 200 (for ([m (regexp-match* #rx#"file://([^\r]*)\r\n" bstr 201 #:match-select cadr)]) 202 (queue-window-event wx 203 (lambda () 204 (let ([path 205 (string->path 206 (uri-decode 207 (bytes->string/utf-8 m)))]) 208 (send wx on-drop-file path)))))))))) 209 210;; ---------------------------------------- 211 212(define-signal-handler connect-focus-in "focus-in-event" 213 (_fun _GtkWidget _GdkEventFocus-pointer -> _gboolean) 214 (lambda (gtk event) 215 (let ([wx (gtk->wx gtk)]) 216 (when wx 217 (send wx focus-change #t) 218 (when (send wx on-focus? #t) 219 (queue-window-event wx (lambda () (send wx on-set-focus))))) 220 #f))) 221(define-signal-handler connect-focus-out "focus-out-event" 222 (_fun _GtkWidget _GdkEventFocus-pointer -> _gboolean) 223 (lambda (gtk event) 224 (let ([wx (gtk->wx gtk)]) 225 (when wx 226 (send wx focus-change #f) 227 (when (send wx on-focus? #f) 228 (queue-window-event wx (lambda () (send wx on-kill-focus))))) 229 #f))) 230(define (connect-focus gtk) 231 (connect-focus-in gtk) 232 (connect-focus-out gtk)) 233 234(define-signal-handler connect-size-allocate "size-allocate" 235 (_fun _GtkWidget _GtkAllocation-pointer -> _gboolean) 236 (lambda (gtk a) 237 (let ([wx (gtk->wx gtk)]) 238 (when wx 239 (send wx save-size 240 (->normal (GtkAllocation-x a)) 241 (->normal (GtkAllocation-y a)) 242 (->normal (GtkAllocation-width a)) 243 (->normal (GtkAllocation-height a))))) 244 #t)) 245;; ---------------------------------------- 246 247(define-signal-handler connect-key-press "key-press-event" 248 (_fun _GtkWidget _GdkEventKey-pointer -> _gboolean) 249 (lambda (gtk event) 250 (do-key-event gtk event #t #f))) 251 252(define-signal-handler connect-key-release "key-release-event" 253 (_fun _GtkWidget _GdkEventKey-pointer -> _gboolean) 254 (lambda (gtk event) 255 (do-key-event gtk event #f #f))) 256 257(define-signal-handler connect-scroll "scroll-event" 258 (_fun _GtkWidget _GdkEventScroll-pointer -> _gboolean) 259 (lambda (gtk event) 260 (let loop ([scrolling-more? #f]) 261 (do-key-event gtk event #f #t scrolling-more?) 262 (when (or ((abs scroll-accum-x) . >= . 1) 263 ((abs scroll-accum-y) . >= . 1)) 264 (loop #t))))) 265 266(define scroll-accum-x 0) 267(define scroll-accum-y 0) 268 269(define (do-key-event gtk event down? scroll? [scrolling-more? #f]) 270 (let ([wx (gtk->wx gtk)]) 271 (and 272 wx 273 (let ([im-str (if scroll? 274 'none 275 ;; Result from `filter-key-event' is one of 276 ;; - #f => drop the event 277 ;; - 'none => no replacement; handle as usual 278 ;; - a string => use as the keycode 279 (send wx filter-key-event event))]) 280 (when im-str 281 (let* ([modifiers (if scroll? 282 (GdkEventScroll-state event) 283 (GdkEventKey-state event))] 284 [bit? (lambda (m v) (positive? (bitwise-and m v)))] 285 [keyval->code (lambda (kv) 286 (or 287 (map-key-code kv) 288 (integer->char (gdk_keyval_to_unicode kv))))]) 289 (define-values (key-code wheel-steps) 290 (cond 291 [scroll? 292 (let ([dir (GdkEventScroll-direction event)]) 293 (cond 294 [(= dir GDK_SCROLL_UP) (values 'wheel-up 1.0)] 295 [(= dir GDK_SCROLL_DOWN) (values 'wheel-down 1.0)] 296 [(= dir GDK_SCROLL_LEFT) (values 'wheel-left 1.0)] 297 [(= dir GDK_SCROLL_RIGHT) (values 'wheel-right 1.0)] 298 [(= dir GDK_SCROLL_SMOOTH) 299 (define mode (send wx get-wheel-steps-mode)) 300 (define-values (dx dy) (if scrolling-more? 301 (values 0 0) 302 (gdk_event_get_scroll_deltas event))) 303 (set! scroll-accum-x (+ scroll-accum-x dx)) 304 (set! scroll-accum-y (+ scroll-accum-y dy)) 305 (case mode 306 [(one integer) 307 (define y-steps (case mode 308 [(one) 1.0] 309 [else (floor (abs scroll-accum-y))])) 310 (define x-steps (case mode 311 [(one) 1.0] 312 [else (floor (abs scroll-accum-x))])) 313 (cond 314 [(>= scroll-accum-y 1) 315 (set! scroll-accum-y (- scroll-accum-y y-steps)) 316 (values 'wheel-down y-steps)] 317 [(<= scroll-accum-y -1) 318 (set! scroll-accum-y (+ scroll-accum-y y-steps)) 319 (values 'wheel-up y-steps)] 320 [(>= scroll-accum-x 1) 321 (set! scroll-accum-x (- scroll-accum-x x-steps)) 322 (values 'wheel-right x-steps)] 323 [(<= scroll-accum-x -1) 324 (set! scroll-accum-x (+ scroll-accum-x x-steps)) 325 (values 'wheel-left x-steps)] 326 [else (values #f 0.0)])] 327 [else 328 ;; 'fraction mode 329 (cond 330 [(> scroll-accum-y 0.0) 331 (define y-steps scroll-accum-y) 332 (set! scroll-accum-y 0.0) 333 (values 'wheel-down y-steps)] 334 [(< scroll-accum-y 0.0) 335 (define y-steps (- scroll-accum-y)) 336 (set! scroll-accum-y 0.0) 337 (values 'wheel-up y-steps)] 338 [(> scroll-accum-x 0.0) 339 (define x-steps scroll-accum-x) 340 (set! scroll-accum-x 0.0) 341 (values 'wheel-right x-steps)] 342 [(< scroll-accum-x 0.0) 343 (define x-steps (- scroll-accum-x)) 344 (set! scroll-accum-x 0.0) 345 (values 'wheel-left x-steps)] 346 [else (values #f 0.0)])])] 347 [else (values #f 0.0)]))] 348 [(and (string? im-str) 349 (= 1 (string-length im-str))) 350 (values (string-ref im-str 0) 0.0)] 351 [else 352 (values (keyval->code (GdkEventKey-keyval event)) 0.0)])) 353 (define k (new key-event% 354 [key-code key-code] 355 [shift-down (bit? modifiers GDK_SHIFT_MASK)] 356 [control-down (bit? modifiers GDK_CONTROL_MASK)] 357 [meta-down (bit? modifiers GDK_MOD1_MASK)] 358 [mod3-down (bit? modifiers GDK_MOD3_MASK)] 359 [mod4-down (bit? modifiers GDK_MOD4_MASK)] 360 [mod5-down (bit? modifiers GDK_MOD5_MASK)] 361 [alt-down (bit? modifiers GDK_META_MASK)] 362 [x 0] 363 [y 0] 364 [time-stamp (if scroll? 365 (GdkEventScroll-time event) 366 (GdkEventKey-time event))] 367 [caps-down (bit? modifiers GDK_LOCK_MASK)])) 368 (unless (zero? wheel-steps) 369 (send k set-wheel-steps wheel-steps)) 370 (when (or (and (not scroll?) 371 (let-values ([(s ag sag cl) (get-alts event)] 372 [(keyval->code*) (lambda (v) 373 (and v 374 (let ([c (keyval->code v)]) 375 (and (not (equal? #\u0000 c)) 376 c))))]) 377 (let ([s (keyval->code* s)] 378 [ag (keyval->code* ag)] 379 [sag (keyval->code* sag)] 380 [cl (keyval->code* cl)]) 381 (when s (send k set-other-shift-key-code s)) 382 (when ag (send k set-other-altgr-key-code ag)) 383 (when sag (send k set-other-shift-altgr-key-code sag)) 384 (when cl (send k set-other-caps-key-code cl)) 385 (or s ag sag cl)))) 386 (not (equal? #\u0000 key-code))) 387 (unless (or scroll? down?) 388 ;; swap altenate with main 389 (send k set-key-release-code (send k get-key-code)) 390 (send k set-key-code 'release)) 391 (if (send wx handles-events? gtk) 392 (begin 393 (queue-window-event wx (lambda () (send wx dispatch-on-char k #f))) 394 #t) 395 (constrained-reply (send wx get-eventspace) 396 (lambda () (send wx dispatch-on-char k #t)) 397 #t))))))))) 398 399(define-signal-handler connect-button-press "button-press-event" 400 (_fun _GtkWidget _GdkEventButton-pointer -> _gboolean) 401 (lambda (gtk event) 402 (unless (gtk_widget_is_focus gtk) 403 (let ([wx (gtk->wx gtk)]) 404 (when wx 405 (unless (other-modal? wx) 406 (gtk_widget_grab_focus gtk))))) 407 (do-button-event gtk event #f #f))) 408 409(define-signal-handler connect-button-release "button-release-event" 410 (_fun _GtkWidget _GdkEventButton-pointer -> _gboolean) 411 (lambda (gtk event) 412 (do-button-event gtk event #f #f))) 413 414(define-signal-handler connect-pointer-motion "motion-notify-event" 415 (_fun _GtkWidget _GdkEventMotion-pointer -> _gboolean) 416 (lambda (gtk event) 417 (do-button-event gtk event #t #f))) 418 419(define-signal-handler connect-enter "enter-notify-event" 420 (_fun _GtkWidget _GdkEventCrossing-pointer -> _gboolean) 421 (lambda (gtk event) 422 (let ([wx (gtk->wx gtk)]) (when wx (send wx enter-window))) 423 (do-button-event gtk event #f #t))) 424 425(define-signal-handler connect-leave "leave-notify-event" 426 (_fun _GtkWidget _GdkEventCrossing-pointer -> _gboolean) 427 (lambda (gtk event) 428 (let ([wx (gtk->wx gtk)]) (when wx (send wx leave-window))) 429 (do-button-event gtk event #f #t))) 430 431(define (connect-enter-and-leave gtk) 432 (connect-enter gtk) 433 (connect-leave gtk)) 434 435(define (connect-key gtk) 436 (connect-key-press gtk) 437 (connect-key-release gtk)) 438 439(define (connect-key-and-mouse gtk [skip-press? #f]) 440 (connect-key gtk) 441 (connect-scroll gtk) 442 (connect-button-press gtk) 443 (unless skip-press? (connect-button-release gtk)) 444 (connect-pointer-motion gtk) 445 (connect-enter-and-leave gtk)) 446 447(define (do-button-event gtk event motion? crossing?) 448 (let ([type (if motion? 449 GDK_MOTION_NOTIFY 450 (if crossing? 451 (GdkEventCrossing-type event) 452 (GdkEventButton-type event)))]) 453 (let ([wx (gtk->wx gtk)]) 454 (when (or (= type GDK_BUTTON_PRESS) 455 (= type GDK_2BUTTON_PRESS) 456 (= type GDK_3BUTTON_PRESS)) 457 (let ([floating? (send wx in-floating?)]) 458 (if floating? 459 (gdk_keyboard_grab (widget-window gtk) #t 0) 460 (gdk_keyboard_ungrab 0)))) 461 (and 462 wx 463 (if (or (= type GDK_2BUTTON_PRESS) 464 (= type GDK_3BUTTON_PRESS) 465 (and (or (= type GDK_ENTER_NOTIFY) 466 (= type GDK_LEAVE_NOTIFY)) 467 (send wx skip-enter-leave-events))) 468 #t 469 (let* ([modifiers (if motion? 470 (GdkEventMotion-state event) 471 (if crossing? 472 (GdkEventCrossing-state event) 473 (GdkEventButton-state event)))] 474 [bit? (lambda (m v) (positive? (bitwise-and m v)))] 475 [type (cond 476 [(= type GDK_MOTION_NOTIFY) 477 'motion] 478 [(= type GDK_ENTER_NOTIFY) 479 'enter] 480 [(= type GDK_LEAVE_NOTIFY) 481 'leave] 482 [(= type GDK_BUTTON_PRESS) 483 (case (GdkEventButton-button event) 484 [(1) 'left-down] 485 [(3) 'right-down] 486 [else 'middle-down])] 487 [else 488 (case (GdkEventButton-button event) 489 [(1) 'left-up] 490 [(3) 'right-up] 491 [else 'middle-up])])] 492 [m (let-values ([(x y) 493 (send wx 494 adjust-event-position 495 (->normal 496 (->long ((if motion? 497 GdkEventMotion-x 498 (if crossing? GdkEventCrossing-x GdkEventButton-x)) 499 event))) 500 (->normal 501 (->long ((if motion? GdkEventMotion-y 502 (if crossing? GdkEventCrossing-y GdkEventButton-y)) 503 event))))]) 504 (new mouse-event% 505 [event-type type] 506 [left-down (case type 507 [(left-down) #t] 508 [(left-up) #f] 509 [else (bit? modifiers GDK_BUTTON1_MASK)])] 510 [middle-down (case type 511 [(middle-down) #t] 512 [(middle-up) #f] 513 [else (bit? modifiers GDK_BUTTON2_MASK)])] 514 [right-down (case type 515 [(right-down) #t] 516 [(right-up) #f] 517 [else (bit? modifiers GDK_BUTTON3_MASK)])] 518 [x x] 519 [y y] 520 [shift-down (bit? modifiers GDK_SHIFT_MASK)] 521 [control-down (bit? modifiers GDK_CONTROL_MASK)] 522 [meta-down (bit? modifiers GDK_META_MASK)] 523 [alt-down (bit? modifiers GDK_MOD1_MASK)] 524 [mod3-down (bit? modifiers GDK_MOD3_MASK)] 525 [mod4-down (bit? modifiers GDK_MOD4_MASK)] 526 [mod5-down (bit? modifiers GDK_MOD5_MASK)] 527 [time-stamp ((if motion? GdkEventMotion-time 528 (if crossing? GdkEventCrossing-time GdkEventButton-time)) 529 event)] 530 [caps-down (bit? modifiers GDK_LOCK_MASK)]))]) 531 (if (send wx handles-events? gtk) 532 (begin 533 (queue-window-event wx (lambda () 534 (send wx dispatch-on-event m #f))) 535 #t) 536 (constrained-reply (send wx get-eventspace) 537 (lambda () (or (send wx dispatch-on-event m #t) 538 (send wx internal-pre-on-event gtk m))) 539 #t 540 #:fail-result 541 ;; an enter event is synthesized when a button is 542 ;; enabled and the mouse is over the button, and the 543 ;; event is not dispatched via the eventspace; leave 544 ;; events are perhaps similarly synthesized, so allow 545 ;; them, too 546 (if (or (eq? type 'enter) (eq? type 'leave)) 547 #f 548 #t))))))))) 549 550;; ---------------------------------------- 551 552(define (internal-error str) 553 (log-error 554 (apply string-append 555 (format "internal error: ~a" str) 556 (append 557 (for/list ([c (continuation-mark-set->context (current-continuation-marks))]) 558 (let ([name (car c)] 559 [loc (cdr c)]) 560 (cond 561 [loc 562 (string-append 563 "\n" 564 (cond 565 [(srcloc-line loc) 566 (format "~a:~a:~a" 567 (srcloc-source loc) 568 (srcloc-line loc) 569 (srcloc-column loc))] 570 [else 571 (format "~a::~a" 572 (srcloc-source loc) 573 (srcloc-position loc))]) 574 (if name (format " ~a" name) ""))] 575 [else (format "\n ~a" name)]))) 576 '("\n"))))) 577 578(define window% 579 (class widget% 580 (init-field parent 581 gtk) 582 (init [no-show? #f] 583 [extra-gtks null] 584 [add-to-parent? #t] 585 [connect-size-allocate? #t]) 586 587 (super-new [gtk gtk] 588 [extra-gtks extra-gtks] 589 [parent parent]) 590 591 (define save-x (get-unset-pos)) 592 (define save-y (get-unset-pos)) 593 (define save-w 0) 594 (define save-h 0) 595 596 (define/public (get-unset-pos) 0) 597 598 (when connect-size-allocate? 599 (connect-size-allocate gtk)) 600 601 (when add-to-parent? 602 (gtk_container_add (send parent get-container-gtk) gtk)) 603 604 (define/public (get-gtk) gtk) 605 (define/public (get-client-gtk) gtk) 606 (define/public (get-container-gtk) (get-client-gtk)) 607 (define/public (get-window-gtk) (send parent get-window-gtk)) 608 609 (define/public (move x y) 610 (set-size x y -1 -1)) 611 612 (define/public (set-size x y w h) 613 (unless (and (or (not x) (equal? save-x x)) 614 (or (not y) (equal? save-y y)) 615 (or (= w -1) (= save-w (max w client-delta-w))) 616 (or (= h -1) (= save-h (max h client-delta-h)))) 617 (unless (not x) (set! save-x x)) 618 (unless (not y) (set! save-y y)) 619 (unless (= w -1) (set! save-w w)) 620 (unless (= h -1) (set! save-h h)) 621 (set! save-w (max save-w client-delta-w)) 622 (set! save-h (max save-h client-delta-h)) 623 (really-set-size gtk x y (or save-x 0) (or save-y 0) save-w save-h) 624 (queue-on-size))) 625 626 (define/public (save-size x y w h) 627 (set! save-w w) 628 (set! save-h h)) 629 630 (define/public (really-set-size gtk given-x given-y x y w h) 631 (send parent set-child-size gtk x y w h)) 632 633 (define/public (set-child-size child-gtk x y w h) 634 (gtk_widget_set_size_request child-gtk (->screen w) (->screen h)) 635 (gtk_widget_size_allocate child-gtk (make-GtkAllocation (->screen x) (->screen y) 636 (->screen w) (->screen h)))) 637 638 (define/public (remember-size x y w h) 639 ;; called in event-pump thread 640 (unless (and (= save-w w) 641 (= save-h h) 642 (equal? save-x x) 643 (equal? save-y y)) 644 (set! save-w w) 645 (set! save-h h) 646 (set! save-x x) 647 (set! save-y y) 648 (queue-on-size))) 649 650 (define/public (queue-on-size) (void)) 651 652 (define client-delta-w 0) 653 (define client-delta-h 0) 654 655 (define/public (adjust-client-delta dw dh) 656 (set! client-delta-w dw) 657 (set! client-delta-h dh)) 658 659 (define/public (infer-client-delta [w? #t] [h? #t] [sub-h-gtk #f] 660 #:inside [inside-gtk (get-container-gtk)]) 661 (let ([req (make-GtkRequisition 0 0)] 662 [creq (make-GtkRequisition 0 0)] 663 [hreq (make-GtkRequisition 0 0)]) 664 (when gtk3? (gtk_widget_show gtk)) 665 (gtk_widget_size_request gtk req) 666 (gtk_widget_size_request inside-gtk creq) 667 (when sub-h-gtk 668 (gtk_widget_size_request sub-h-gtk hreq)) 669 (when w? 670 (set! client-delta-w (->normal 671 (- (GtkRequisition-width req) 672 (max (GtkRequisition-width creq) 673 (GtkRequisition-width hreq)))))) 674 (when h? 675 (set! client-delta-h (->normal 676 (- (GtkRequisition-height req) 677 (GtkRequisition-height creq))))) 678 (when gtk3? (gtk_widget_hide gtk)))) 679 680 (define/public (set-auto-size [dw 0] [dh 0]) 681 (let ([req (make-GtkRequisition 0 0)]) 682 (cond 683 [gtk3? 684 (unless shown? (gtk_widget_show gtk)) 685 (gtk_widget_get_preferred_size gtk req #f) 686 (unless shown? (gtk_widget_hide gtk))] 687 [else (gtk_widget_size_request gtk req)]) 688 (set-size #f 689 #f 690 (+ (->normal (GtkRequisition-width req)) dw) 691 (+ (->normal (GtkRequisition-height req)) dh)))) 692 693 (define shown? #f) 694 (define/public (direct-show on?) 695 ;; atomic mode 696 (if on? 697 (gtk_widget_show gtk) 698 (gtk_widget_hide gtk)) 699 (set! shown? (and on? #t)) 700 (register-child-in-parent on?) 701 (when on? (reset-child-dcs))) 702 (define/public (show on?) 703 (atomically 704 (direct-show on?))) 705 (define/public (reset-child-freezes) (void)) 706 (define/public (reset-child-dcs) (void)) 707 (define/public (is-shown?) shown?) 708 (define/public (is-shown-to-root?) 709 (and shown? 710 (if parent 711 (send parent is-shown-to-root?) 712 #t))) 713 714 (unless no-show? (show #t)) 715 716 (define/public (get-x) (or save-x 0)) 717 (define/public (get-y) (or save-y 0)) 718 (define/public (get-width) save-w) 719 (define/public (get-height) save-h) 720 721 (define/public (get-parent) parent) 722 (define/public (set-parent p) 723 ;; in atomic mode 724 (reset-child-freezes) 725 (g_object_ref gtk) 726 (gtk_container_remove (send parent get-container-gtk) gtk) 727 (set! parent p) 728 (gtk_container_add (send parent get-container-gtk) gtk) 729 (set! save-x 0) 730 (set! save-y 0) 731 (g_object_unref gtk)) 732 733 (define/public (get-top-win) (send parent get-top-win)) 734 735 (define/public (get-dialog-level) (send parent get-dialog-level)) 736 737 (define/public (get-size xb yb) 738 (set-box! xb save-w) 739 (set-box! yb save-h)) 740 (define/public (get-client-size xb yb) 741 (get-size xb yb) 742 (set-box! xb (max 0 (- (unbox xb) client-delta-w))) 743 (set-box! yb (max 0 (- (unbox yb) client-delta-h)))) 744 745 (define enabled? #t) 746 (define/pubment (is-enabled-to-root?) 747 (and enabled? 748 (inner (send parent is-enabled-to-root?) 749 is-enabled-to-root?))) 750 (define/public (enable on?) 751 (set! enabled? on?) 752 (gtk_widget_set_sensitive gtk on?)) 753 (define/public (is-window-enabled?) enabled?) 754 755 (define drag-connected? #f) 756 (define/public (drag-accept-files on?) 757 (if on? 758 (begin 759 (unless drag-connected? 760 (connect-drag-data-received gtk) 761 (set! drag-connected? #t)) 762 (gtk_drag_dest_set gtk GTK_DEST_DEFAULT_ALL GDK_ACTION_COPY) 763 (gtk_drag_dest_add_uri_targets gtk)) 764 (gtk_drag_dest_unset gtk))) 765 766 (define/public (in-floating?) 767 (send parent in-floating?)) 768 769 (define/public (set-focus) 770 (define gtk (get-client-gtk)) 771 (gtk_widget_grab_focus gtk) 772 ;; Force focus to or away from a floating window: 773 (cond 774 [(and (in-floating?) 775 (is-shown-to-root?)) 776 (gdk_keyboard_grab (widget-window gtk) #t 0)] 777 [else 778 (gdk_keyboard_ungrab 0)])) 779 780 (define cursor-handle #f) 781 (define/public (set-cursor v) 782 (set! cursor-handle (and v 783 (send (send v get-driver) get-handle))) 784 (check-window-cursor this)) 785 (define/public (enter-window) 786 (set-window-cursor this #f)) 787 (define/public (leave-window) 788 (when parent 789 (send parent enter-window))) 790 (define/public (set-window-cursor in-win c) 791 (set-parent-window-cursor in-win (or c cursor-handle))) 792 (define/public (set-parent-window-cursor in-win c) 793 (when parent 794 (send parent set-window-cursor in-win c))) 795 (define/public (check-window-cursor win) 796 (when parent 797 (send parent check-window-cursor win))) 798 799 (define/public (on-set-focus) (void)) 800 (define/public (on-kill-focus) (void)) 801 802 (define/public (focus-change on?) (void)) 803 (define/public (filter-key-event e) 'none) 804 805 (define/public (on-focus? on?) #t) 806 807 (define/private (pre-event-refresh) 808 ;; Since we break the connection between the 809 ;; Gtk queue and event handling, we 810 ;; re-sync the display in case a stream of 811 ;; events (e.g., key repeat) have a corresponding 812 ;; stream of screen updates. 813 (flush-display)) 814 815 (define/public (handles-events? gtk) #f) 816 (define/public (dispatch-on-char e just-pre?) 817 (pre-event-refresh) 818 (cond 819 [(other-modal? this) #t] 820 [(call-pre-on-char this e) #t] 821 [just-pre? #f] 822 [else (when enabled? (on-char e)) #t])) 823 (define/public (dispatch-on-event e just-pre?) 824 (pre-event-refresh) 825 (cond 826 [(other-modal? this e) #t] 827 [(call-pre-on-event this e) #t] 828 [just-pre? #f] 829 [else (when enabled? (on-event e)) #t])) 830 831 (define/public (internal-pre-on-event gtk e) #f) 832 833 (define/public (call-pre-on-event w e) 834 (or (send parent call-pre-on-event w e) 835 (pre-on-event w e))) 836 (define/public (call-pre-on-char w e) 837 (or (send parent call-pre-on-char w e) 838 (pre-on-char w e))) 839 (define/public (pre-on-event w e) #f) 840 (define/public (pre-on-char w e) #f) 841 842 (define/public (on-char e) (void)) 843 (define/public (on-event e) (void)) 844 845 (define wheel-steps-mode 'one) 846 (define/public (get-wheel-steps-mode) wheel-steps-mode) 847 (define/public (set-wheel-steps-mode mode) (set! wheel-steps-mode mode)) 848 849 (define skip-enter-leave? #f) 850 (define/public skip-enter-leave-events 851 (case-lambda 852 [(skip?) (set! skip-enter-leave? skip?)] 853 [else skip-enter-leave?])) 854 855 (define/public (register-child child on?) 856 (void)) 857 (define/public (register-child-in-parent on?) 858 (when parent 859 (send parent register-child this on?))) 860 861 (define/public (paint-children) 862 (void)) 863 864 (define/public (on-drop-file path) (void)) 865 866 (define/public (get-handle) (get-gtk)) 867 (define/public (get-client-handle) (get-container-gtk)) 868 869 (define/public (popup-menu m x y) 870 (let ([gx (box x)] 871 [gy (box y)]) 872 (client-to-screen gx gy) 873 (send m popup (unbox gx) (unbox gy) 874 (lambda (thunk) (queue-window-event this thunk))))) 875 876 (define/public (center a b) (void)) 877 (define/public (refresh) (refresh-all-children)) 878 879 (define/public (refresh-all-children) (void)) 880 881 (define/public (screen-to-client x y) 882 (internal-screen-to-client x y)) 883 (define/public (internal-screen-to-client x y) 884 (let ([xb (box 0)] 885 [yb (box 0)]) 886 (internal-client-to-screen xb yb) 887 (set-box! x (- (unbox x) (unbox xb))) 888 (set-box! y (- (unbox y) (unbox yb))))) 889 (define/public (client-to-screen x y) 890 (internal-client-to-screen x y)) 891 (define/public (internal-client-to-screen x y) 892 (let-values ([(dx dy) (get-client-delta)]) 893 (send parent internal-client-to-screen x y) 894 (set-box! x (+ (unbox x) save-x dx)) 895 (set-box! y (+ (unbox y) save-y dy)))) 896 897 (define event-position-wrt-wx #f) 898 (define/public (set-event-positions-wrt wx) 899 (set! event-position-wrt-wx wx)) 900 901 (define/public (adjust-event-position x y) 902 (if event-position-wrt-wx 903 (let ([xb (box x)] 904 [yb (box y)]) 905 (internal-client-to-screen xb yb) 906 (send event-position-wrt-wx internal-screen-to-client xb yb) 907 (values (unbox xb) (unbox yb))) 908 (values x y))) 909 910 (define/public (get-client-delta) 911 (values 0 0)) 912 (define/public (get-stored-client-delta) 913 (values client-delta-w client-delta-h)) 914 915 (define/public (warp-pointer x y) 916 (define xb (box x)) 917 (define yb (box y)) 918 (client-to-screen xb yb) 919 (gdk_display_warp_pointer (gtk_widget_get_display gtk) 920 (gtk_widget_get_screen gtk) 921 (->screen (unbox xb)) 922 (->screen (unbox yb)))) 923 924 (define/public (gets-focus?) #t))) 925 926(define (queue-window-event win thunk) 927 (queue-event (send win get-eventspace) thunk)) 928(define (queue-window-refresh-event win thunk) 929 (queue-refresh-event (send win get-eventspace) thunk)) 930 931(define-gdk gdk_display_flush (_fun _GdkDisplay -> _void)) 932(define-gdk gdk_display_get_default (_fun -> _GdkDisplay)) 933(define (flush-display) 934 (try-to-sync-refresh) 935 (gdk_display_flush (gdk_display_get_default))) 936 937(define-gdk gdk_window_freeze_updates (_fun _GdkWindow -> _void)) 938(define-gdk gdk_window_thaw_updates (_fun _GdkWindow -> _void)) 939(define-gdk gdk_window_invalidate_rect (_fun _GdkWindow _pointer _gboolean -> _void)) 940(define-gdk gdk_window_ensure_native (_fun _GdkWindow -> _gboolean) 941 ;; Requires 2.18 942 #:fail (lambda () (lambda (win) #f))) 943 944(define (win-box-valid? win-box) 945 (mcar win-box)) 946(define (window->win-box win) 947 (mcons win 0)) 948(define (unrealize-win-box win-box) 949 (let ([win (mcar win-box)]) 950 (when win 951 (set-mcar! win-box #f) 952 (for ([i (in-range (mcdr win-box))]) 953 (gdk_window_thaw_updates win))))) 954 955(define (request-flush-delay win-box transparentish?) 956 (do-request-flush-delay 957 win-box 958 (lambda (win-box) 959 (let ([win (mcar win-box)]) 960 (and win 961 ;; The freeze/thaw state is actually with the window's 962 ;; implementation, so force a native implementation of the 963 ;; window to try to avoid it changing out from underneath 964 ;; us between the freeze and thaw actions. 965 ;; With Gtk3, we can't use a native window for transparent 966 ;; windows; that means we have to be extra careful that 967 ;; the underlying window doesn't change while a freeze is 968 ;; in effect; the `reset-child-freezes` helps with that. 969 (unless (or (and transparentish? gtk3?) wayland?) 970 (gdk_window_ensure_native win)) 971 (begin 972 (gdk_window_freeze_updates win) 973 (set-mcdr! win-box (add1 (mcdr win-box))) 974 #t)))) 975 (lambda (win-box) 976 (let ([win (mcar win-box)]) 977 (when win 978 (gdk_window_thaw_updates win) 979 (set-mcdr! win-box (sub1 (mcdr win-box)))))))) 980 981(define (cancel-flush-delay req) 982 (when req 983 (do-cancel-flush-delay 984 req 985 (lambda (win-box) 986 (let ([win (mcar win-box)]) 987 (when win 988 (gdk_window_thaw_updates win) 989 (set-mcdr! win-box (sub1 (mcdr win-box))))))))) 990