1#lang racket/base 2(require ffi/unsafe 3 ffi/unsafe/define 4 racket/class 5 racket/promise 6 racket/runtime-path 7 racket/draw 8 (for-syntax (only-in racket/base quote)) 9 "../../syntax.rkt" 10 "../../lock.rkt" 11 "utils.rkt" 12 "const.rkt" 13 "types.rkt" 14 "window.rkt" 15 "client-window.rkt" 16 "widget.rkt" 17 "cursor.rkt" 18 "pixbuf.rkt" 19 "resolution.rkt" 20 "queue.rkt" 21 "../common/queue.rkt") 22 23(provide 24 (protect-out frame% 25 display-origin 26 display-size 27 display-count 28 display-bitmap-resolution 29 location->window 30 get-current-mouse-state)) 31 32;; ---------------------------------------- 33 34(define GDK_GRAVITY_NORTH_WEST 1) 35(define GDK_GRAVITY_STATIC 10) 36 37(define _GList (_cpointer/null 'GList)) 38(define-glib g_list_insert (_fun _GList _pointer _int -> _GList)) 39(define-glib g_list_free (_fun _GList -> _void)) 40 41(define-gtk gtk_window_new (_fun _int -> _GtkWidget)) 42(define-gtk gtk_window_set_title (_fun _GtkWindow _string -> _void)) 43(define-gtk gtk_fixed_new (_fun -> _GtkWidget)) 44(define-gtk gtk_fixed_move (_fun _GtkWidget _GtkWidget _int _int -> _void)) 45(define-gtk gtk_window_get_size (_fun _GtkWidget (w : (_ptr o _int)) (h : (_ptr o _int)) 46 -> _void 47 -> (values w h))) 48(define-gtk gtk_window_set_decorated (_fun _GtkWidget _gboolean -> _void)) 49(define-gtk gtk_window_set_keep_above (_fun _GtkWidget _gboolean -> _void)) 50(define-gtk gtk_window_set_focus_on_map (_fun _GtkWidget _gboolean -> _void)) 51(define-gtk gtk_window_maximize (_fun _GtkWidget -> _void)) 52(define-gtk gtk_window_unmaximize (_fun _GtkWidget -> _void)) 53(define-gtk gtk_window_move (_fun _GtkWidget _int _int -> _void)) 54(define-gtk gtk_widget_set_uposition (_fun _GtkWidget _int _int -> _void) 55 #:fail (lambda () (lambda (w x y) (gtk_window_move w x y)))) 56(define-gtk gtk_window_get_position (_fun _GtkWidget (x : (_ptr o _int)) (y : (_ptr o _int)) 57 -> _void 58 -> (values x y))) 59(define-gtk gtk_window_set_gravity (_fun _GtkWindow _int -> _void)) 60(define-gtk gtk_window_set_icon_list (_fun _GtkWindow _GList -> _void)) 61(define-gtk gtk_window_fullscreen (_fun _GtkWindow -> _void)) 62(define-gtk gtk_window_unfullscreen (_fun _GtkWindow -> _void)) 63(define-gtk gtk_window_get_focus (_fun _GtkWindow -> (_or-null _GtkWidget))) 64 65(define-gtk gtk_window_resize (_fun _GtkWidget _int _int -> _void)) 66 67(define-gdk gdk_window_set_cursor (_fun _GdkWindow _pointer -> _void)) 68(define-gdk gdk_screen_get_root_window (_fun _GdkScreen -> _GdkWindow)) 69(define-gdk gdk_screen_get_monitor_scale_factor (_fun _GdkScreen _int -> _int) 70 #:fail (lambda () (lambda (s n) 1))) 71(define-gdk gdk_window_get_pointer (_fun _GdkWindow 72 (x : (_ptr o _int)) 73 (y : (_ptr o _int)) 74 (mods : (_ptr o _uint)) 75 -> _GdkWindow 76 -> (values x y mods))) 77 78(define-gtk gtk_window_iconify (_fun _GtkWindow -> _void)) 79(define-gtk gtk_window_deiconify (_fun _GtkWindow -> _void)) 80 81(define-cstruct _GdkGeometry ([min_width _int] 82 [min_height _int] 83 [max_width _int] 84 [max_height _int] 85 [base_width _int] 86 [base_height _int] 87 [width_inc _int] 88 [height_inc _int] 89 [min_aspect _double] 90 [max_aspect _double] 91 [win_gravity _int])) 92(define-gtk gtk_window_set_geometry_hints (_fun _GtkWindow _pointer _GdkGeometry-pointer _int -> _void)) 93(define-gtk gtk_widget_get_allocated_width (_fun _GtkWidget -> _int) 94 #:make-fail make-not-available) 95(define-gtk gtk_widget_get_allocated_height (_fun _GtkWidget -> _int) 96 #:make-fail make-not-available) 97 98(define-gtk gtk_layout_new (_fun (_pointer = #f) (_pointer = #f) -> _GtkWidget)) 99(define-gtk gtk_layout_put (_fun _GtkWidget _GtkWidget _int _int -> _void)) 100 101(define-signal-handler connect-delete "delete-event" 102 (_fun _GtkWidget -> _gboolean) 103 (lambda (gtk) 104 (let ([wx (gtk->wx gtk)]) 105 (when wx 106 (queue-window-event wx (lambda () 107 (unless (other-modal? wx) 108 (when (send wx on-close) 109 (send wx direct-show #f))))))))) 110 111(define-signal-handler connect-configure "configure-event" 112 (_fun _GtkWidget _GdkEventConfigure-pointer -> _gboolean) 113 (lambda (gtk a) 114 (let ([wx (gtk->wx gtk)]) 115 (when wx 116 (define-values (w h) (if gtk3? 117 (gtk_window_get_size gtk) 118 (values (GdkEventConfigure-width a) 119 (GdkEventConfigure-height a)))) 120 (send wx remember-size 121 (->normal (GdkEventConfigure-x a)) 122 (->normal (GdkEventConfigure-y a)) 123 (->normal w) 124 (->normal h)))) 125 #f)) 126 127(define-cstruct _GdkEventWindowState ([type _int] 128 [window _GtkWindow] 129 [send_event _int8] 130 [changed_mask _int] 131 [new_window_state _int])) 132 133 134(define-signal-handler connect-window-state "window-state-event" 135 (_fun _GtkWidget _GdkEventWindowState-pointer -> _gboolean) 136 (lambda (gtk evt) 137 (let ([wx (gtk->wx gtk)]) 138 (when wx 139 (send wx on-window-state 140 (GdkEventWindowState-changed_mask evt) 141 (GdkEventWindowState-new_window_state evt)))) 142 #f)) 143 144(define-runtime-path plt-16x16-file '(lib "icons/plt-icon-16x16.png")) 145(define-runtime-path plt-32x32-file '(lib "icons/plt-icon-32x32.png")) 146(define-runtime-path plt-48x48-file '(lib "icons/plt-icon-48x48.png")) 147 148(define icon-pixbufs+glist 149 (delay 150 (let ([icons (map 151 (lambda (fn) 152 (bitmap->pixbuf (make-object bitmap% fn 'png/alpha))) 153 (list plt-16x16-file 154 plt-32x32-file 155 plt-48x48-file))]) 156 (cons 157 ;; keep pixbuf pointers to avoid GC: 158 icons 159 ;; a glist: 160 (for/fold ([l #f]) ([i (in-list icons)]) 161 (g_list_insert l i -1)))))) 162 163;; used for location->window 164(define all-frames (make-weak-hasheq)) 165 166(define frame% 167 (class (client-size-mixin window%) 168 (init parent 169 label 170 x y w h 171 style) 172 (init [is-dialog? #f]) 173 174 (inherit get-gtk set-size 175 pre-on-char pre-on-event 176 get-stored-client-delta get-size 177 get-parent get-eventspace 178 adjust-client-delta 179 queue-on-size) 180 181 (define floating? (memq 'float style)) 182 183 (define gtk (as-gtk-window-allocation 184 (gtk_window_new (if floating? 185 GTK_WINDOW_POPUP 186 GTK_WINDOW_TOPLEVEL)))) 187 (when (memq 'no-caption style) 188 (gtk_window_set_decorated gtk #f)) 189 (when floating? 190 (gtk_window_set_keep_above gtk #t) 191 (gtk_window_set_focus_on_map gtk #f)) 192 (define-values (vbox-gtk layout-gtk panel-gtk) 193 (atomically 194 (let ([vbox-gtk (gtk_vbox_new #f 0)] 195 [layout-gtk (and gtk3? (gtk_layout_new))] 196 [panel-gtk (gtk_fixed_new)]) 197 (gtk_container_add gtk vbox-gtk) 198 (gtk_box_pack_end vbox-gtk (or layout-gtk panel-gtk) #t #t 0) 199 (when layout-gtk 200 (gtk_layout_put layout-gtk panel-gtk 0 0)) 201 (values vbox-gtk layout-gtk panel-gtk)))) 202 (gtk_widget_show vbox-gtk) 203 (when layout-gtk (gtk_widget_show layout-gtk)) 204 (gtk_widget_show panel-gtk) 205 (connect-enter-and-leave gtk) 206 207 ;; Enable key events on the panel to catch events 208 ;; that would otherwise go undelivered: 209 (gtk_widget_set_can_focus panel-gtk #t) 210 (gtk_widget_add_events panel-gtk (bitwise-ior GDK_KEY_PRESS_MASK 211 GDK_KEY_RELEASE_MASK)) 212 (connect-key panel-gtk) 213 214 (unless is-dialog? 215 (gtk_window_set_icon_list gtk (cdr (force icon-pixbufs+glist)))) 216 217 (define/override (get-client-gtk) panel-gtk) 218 (define/override (get-window-gtk) gtk) 219 220 (define/override (in-floating?) floating?) 221 222 (super-new [parent parent] 223 [gtk gtk] 224 [client-gtk panel-gtk] 225 [no-show? #t] 226 [add-to-parent? #f] 227 [extra-gtks (list panel-gtk)] 228 [connect-size-allocate? #f]) 229 230 (set-size x y w h) 231 232 (when (memq 'hide-menu-bar style) 233 (gtk_window_fullscreen gtk)) 234 235 (connect-delete gtk) 236 (connect-configure gtk) 237 (connect-focus gtk) 238 (connect-window-state gtk) 239 240 (define saved-title (or label "")) 241 (define is-modified? #f) 242 243 (when label 244 (gtk_window_set_title gtk label)) 245 246 ;(gtk_window_add_accel_group (widget-window gtk) the-accelerator-group) 247 248 (define/override (set-child-size child-gtk x y w h) 249 (gtk_fixed_move panel-gtk child-gtk (->screen x) (->screen y)) 250 ;; gtk3: we expect a panel in a frame to be always visible, so 251 ;; this size request should work 252 (avoid-preferred-size-warning child-gtk) 253 (gtk_widget_set_size_request child-gtk (->screen w) (->screen h))) 254 255 (define/public (on-close) #t) 256 257 (define/public (set-menu-bar mb) 258 (let ([mb-gtk (send mb get-gtk)]) 259 (gtk_box_pack_start vbox-gtk mb-gtk #f #f 0) 260 (gtk_widget_show mb-gtk)) 261 (let ([h (send mb set-top-window this)]) 262 ;; adjust client delta right away, so that we make 263 ;; better assumptions about the client size and more 264 ;; quickly converge to the right size of the frame 265 ;; based on its content 266 (adjust-client-delta 0 h)) 267 ;; Hack: calls back into the mred layer to re-compute 268 ;; sizes. By calling this early enough, the frame won't 269 ;; grow if it doesn't have to grow to accommodate the menu bar. 270 (send this resized)) 271 272 (define/public (reset-menu-height h) 273 (adjust-client-delta 0 h)) 274 275 (define saved-enforcements (vector 0 0 -1 -1)) 276 277 (define/public (enforce-size min-x min-y max-x max-y inc-x inc-y) 278 (define (to-max v) (if (= v -1) #x3FFFFF (->screen v))) 279 (set! saved-enforcements (vector min-x min-y max-x max-y)) 280 (define-values (dx dy) 281 (if wayland? 282 ;; Hints work at a layer of geometry below some offset that 283 ;; `gtk_window_get_size` works but above where allocations 284 ;; work: 285 (let-values ([(w h) (gtk_window_get_size gtk)]) 286 (values (- (gtk_widget_get_allocated_width gtk) w) 287 (- (gtk_widget_get_allocated_height gtk) h))) 288 (values 0 0))) 289 (gtk_window_set_geometry_hints gtk #f 290 (make-GdkGeometry (->screen min-x) (->screen min-y) 291 (+ dx (to-max max-x)) (+ dy (to-max max-y)) 292 0 0 293 (->screen inc-x) (->screen inc-y) 294 0.0 0.0 295 0) 296 (bitwise-ior GDK_HINT_MIN_SIZE 297 GDK_HINT_MAX_SIZE 298 GDK_HINT_RESIZE_INC))) 299 300 (define/override (get-top-win) this) 301 302 (define dc-lock (and (eq? 'windows (system-type)) (make-semaphore 1))) 303 (define/public (get-dc-lock) dc-lock) 304 305 (define/override (get-dialog-level) 0) 306 (define/public (frame-relative-dialog-status win) #f) 307 308 (define/override (get-unset-pos) #f) 309 310 (define/override (center dir wrt) 311 (let ([w-box (box 0)] 312 [h-box (box 0)] 313 [sx-box (box 0)] 314 [sy-box (box 0)] 315 [sw-box (box 0)] 316 [sh-box (box 0)]) 317 (get-size w-box h-box) 318 (let ([p (get-parent)]) 319 (if p 320 (begin 321 (send p get-size sw-box sh-box) 322 (set-box! sx-box (send p get-x)) 323 (set-box! sy-box (send p get-y))) 324 (display-size sw-box sh-box #t 0 void))) 325 (let* ([sw (unbox sw-box)] 326 [sh (unbox sh-box)] 327 [fw (unbox w-box)] 328 [fh (unbox h-box)]) 329 (set-top-position (if (or (eq? dir 'both) 330 (eq? dir 'horizontal)) 331 (+ (unbox sx-box) (quotient (- sw fw) 2)) 332 #f) 333 (if (or (eq? dir 'both) 334 (eq? dir 'vertical)) 335 (+ (unbox sy-box) (quotient (- sh fh) 2)) 336 #f))))) 337 338 (define/public (set-top-position x y) 339 (unless (and (not x) (not y)) 340 (gtk_widget_set_uposition gtk 341 (or (and x (->screen x)) -2) 342 (or (and y (->screen y)) -2)))) 343 344 (define/override (really-set-size gtk x y processed-x processed-y w h) 345 (set-top-position x y) 346 (gtk_window_resize gtk (max 1 (->screen w)) (max 1 (->screen h)))) 347 348 (define/override (show on?) 349 (let ([es (get-eventspace)]) 350 (when (and on? 351 (eventspace-shutdown? es)) 352 (error (string->symbol 353 (format "show method in ~a" 354 (if (frame-relative-dialog-status this) 355 'dialog% 356 'frame%))) 357 "eventspace has been shutdown") 358 (when saved-child 359 (if (eq? (current-thread) (eventspace-handler-thread es)) 360 (send saved-child paint-children) 361 (let ([s (make-semaphore)]) 362 (queue-callback (lambda () 363 (when saved-child 364 (send saved-child paint-children)) 365 (semaphore-post s))) 366 (sync/timeout 1 s)))))) 367 (super show on?)) 368 369 (define saved-child #f) 370 (define/override (register-child child on?) 371 (unless on? (error 'register-child-in-frame "did not expect #f")) 372 (unless (or (not saved-child) (eq? child saved-child)) 373 (error 'register-child-in-frame "expected only one child")) 374 (set! saved-child child)) 375 (define/override (register-child-in-parent on?) 376 (void)) 377 378 (define/override (refresh-all-children) 379 (when saved-child 380 (send saved-child refresh))) 381 382 (define/override (direct-show on?) 383 ;; atomic mode 384 (if on? 385 (hash-set! all-frames this #t) 386 (hash-remove! all-frames this)) 387 (super direct-show on?) 388 (when on? (gtk_window_deiconify gtk)) 389 (register-frame-shown this on?)) 390 391 (define/public (destroy) 392 ;; atomic mode 393 (direct-show #f)) 394 395 (define/override (on-client-size w h) 396 (void)) 397 398 (define/augment (is-enabled-to-root?) #t) 399 400 (define big-icon #f) 401 (define small-icon #f) 402 (define/public (set-icon bm [mask #f] [mode 'both]) 403 (let ([bm (if mask 404 (let* ([nbm (make-object bitmap% 405 (send bm get-width) 406 (send bm get-height) 407 #f 408 #t)] 409 [dc (make-object bitmap-dc% nbm)]) 410 (send dc draw-bitmap bm 0 0 411 'solid (make-object color% "black") 412 mask) 413 (send dc set-bitmap #f) 414 nbm) 415 bm)]) 416 (case mode 417 [(small) (set! small-icon bm)] 418 [(big) (set! big-icon bm)] 419 [(both) 420 (set! small-icon bm) 421 (set! big-icon bm)]) 422 (let ([small-pixbuf 423 (if small-icon 424 (bitmap->pixbuf small-icon) 425 (car (car (force icon-pixbufs+glist))))] 426 [big-pixbufs 427 (if big-icon 428 (list (bitmap->pixbuf big-icon)) 429 (cdr (car (force icon-pixbufs+glist))))]) 430 (atomically 431 (let ([l (for/fold ([l #f]) ([i (cons small-pixbuf big-pixbufs)]) 432 (g_list_insert l i -1))]) 433 (gtk_window_set_icon_list gtk l) 434 (g_list_free l)))))) 435 436 (define child-has-focus? #f) 437 (define reported-activate #f) 438 (define queued-active? #f) 439 (define/public (on-focus-child on?) 440 ;; atomic mode 441 (set! child-has-focus? on?) 442 (unless queued-active? 443 (set! queued-active? #t) 444 (queue-window-event this 445 (lambda () 446 (let ([on? child-has-focus?]) 447 (set! queued-active? #f) 448 (unless (eq? on? reported-activate) 449 (set! reported-activate on?) 450 (on-activate on?))))))) 451 452 (define treat-focus-out-as-menu-click? #f) 453 (define/public (treat-focus-out-as-menu-click) 454 (set! treat-focus-out-as-menu-click? #t)) 455 456 (define focus-here? #f) 457 (define/override (on-focus? on?) 458 (when (and (not on?) treat-focus-out-as-menu-click?) 459 (on-menu-click)) 460 (on-focus-child on?) 461 (cond 462 [on? 463 (if (ptr-equal? (gtk_window_get_focus gtk) gtk) 464 (begin 465 (set! focus-here? #t) 466 (super on-focus? on?)) 467 #f)] 468 [focus-here? 469 (set! focus-here? #f) 470 (super on-focus? on?)] 471 [else #f])) 472 473 (define/public (get-focus-window [even-if-not-active? #f]) 474 (let ([f-gtk (gtk_window_get_focus gtk)]) 475 (and f-gtk 476 (or even-if-not-active? 477 (gtk_widget_has_focus f-gtk)) 478 (gtk->wx f-gtk)))) 479 480 (define/override (call-pre-on-event w e) 481 (pre-on-event w e)) 482 (define/override (call-pre-on-char w e) 483 (pre-on-char w e)) 484 485 (define/override (internal-client-to-screen x y) 486 (gtk_window_set_gravity gtk GDK_GRAVITY_STATIC) 487 (let-values ([(dx dy) (gtk_window_get_position gtk)] 488 [(cdx cdy) (get-stored-client-delta)]) 489 (gtk_window_set_gravity gtk GDK_GRAVITY_NORTH_WEST) 490 (set-box! x (+ (unbox x) (->normal (+ dx cdx)))) 491 (set-box! y (+ (unbox y) (->normal (+ dy cdy)))))) 492 493 (define/public (on-toolbar-click) (void)) 494 (define/public (on-menu-click) (void)) 495 496 (define/public (on-menu-command c) (void)) 497 498 (def/public-unimplemented on-mdi-activate) 499 500 (define/public (on-activate on?) (void)) 501 502 (define/public (designate-root-frame) (void)) 503 504 (def/public-unimplemented system-menu) 505 506 (define/public (set-modified mod?) 507 (unless (eq? is-modified? (and mod? #t)) 508 (set! is-modified? (and mod? #t)) 509 (set-title saved-title))) 510 511 (define waiting-cursor? #f) 512 (define/public (set-wait-cursor-mode on?) 513 (set! waiting-cursor? on?) 514 (when in-window 515 (send in-window enter-window))) 516 517 (define current-cursor-handle #f) 518 (define in-window #f) 519 (define/override (set-parent-window-cursor in-win c) 520 (set! in-window in-win) 521 (let ([c (if waiting-cursor? 522 (get-watch-cursor-handle) 523 c)]) 524 (unless (eq? c current-cursor-handle) 525 (atomically 526 (set! current-cursor-handle c) 527 (gdk_window_set_cursor (widget-window (get-gtk)) (if (eq? c (get-arrow-cursor-handle)) 528 #f 529 c)))))) 530 (define/override (enter-window) (void)) 531 (define/override (leave-window) (void)) 532 533 (define/override (check-window-cursor win) 534 (when in-window 535 (send in-window enter-window))) 536 537 (define maximized? #f) 538 (define is-iconized? #f) 539 (define fullscreen? #f) 540 541 (define/public (is-maximized?) 542 maximized?) 543 (define/public (maximize on?) 544 ((if on? gtk_window_maximize gtk_window_unmaximize) gtk)) 545 546 (define/public (on-window-state changed value) 547 (when (positive? (bitwise-and changed GDK_WINDOW_STATE_MAXIMIZED)) 548 (set! maximized? (positive? (bitwise-and value GDK_WINDOW_STATE_MAXIMIZED)))) 549 (when (positive? (bitwise-and changed GDK_WINDOW_STATE_FULLSCREEN)) 550 (set! fullscreen? (positive? (bitwise-and value GDK_WINDOW_STATE_FULLSCREEN)))) 551 (when (positive? (bitwise-and changed GDK_WINDOW_STATE_ICONIFIED)) 552 (set! is-iconized? (positive? (bitwise-and value GDK_WINDOW_STATE_ICONIFIED))))) 553 554 (define/public (iconized?) 555 is-iconized?) 556 (define/public (iconize on?) 557 (if on? 558 (gtk_window_iconify gtk) 559 (gtk_window_deiconify gtk))) 560 561 (define/public (fullscreened?) 562 fullscreen?) 563 (define/public (fullscreen on?) 564 (if on? 565 (gtk_window_fullscreen gtk) 566 (gtk_window_unfullscreen gtk))) 567 568 (def/public-unimplemented get-menu-bar) 569 570 (define/public (set-title s) 571 (set! saved-title s) 572 (gtk_window_set_title gtk (if is-modified? 573 (string-append s "*") 574 s))) 575 576 (define/public (display-changed) (void)))) 577 578;; ---------------------------------------- 579 580(define-gdk gdk_screen_get_width (_fun _GdkScreen -> _int)) 581(define-gdk gdk_screen_get_height (_fun _GdkScreen -> _int)) 582 583(define-gdk gdk_screen_get_monitor_geometry (_fun _GdkScreen _int _GdkRectangle-pointer -> _void)) 584(define-gdk gdk_screen_get_n_monitors (_fun _GdkScreen -> _int)) 585 586(define (monitor-rect num fail) 587 (let ([s (gdk_screen_get_default)] 588 [r (make-GdkRectangle 0 0 0 0)]) 589 (unless (num . < . (gdk_screen_get_n_monitors s)) 590 (fail)) 591 (gdk_screen_get_monitor_geometry s num r) 592 r)) 593 594(define (display-origin x y all? num fail) 595 (let ([r (monitor-rect num fail)]) 596 (set-box! x (->normal (- (GdkRectangle-x r)))) 597 (set-box! y (->normal (- (GdkRectangle-y r)))))) 598 599(define (display-size w h all? num fail) 600 (let ([r (monitor-rect num fail)]) 601 (set-box! w (->normal (GdkRectangle-width r))) 602 (set-box! h (->normal (GdkRectangle-height r))))) 603 604(define (display-count) 605 (gdk_screen_get_n_monitors (gdk_screen_get_default))) 606 607(define (display-bitmap-resolution num fail) 608 (define (get) (* (or (get-interface-scale-factor num) 609 1.0) 610 (gdk_screen_get_monitor_scale_factor 611 (gdk_screen_get_default) 612 num))) 613 (if (zero? num) 614 (get) 615 (if (num . < . (gdk_screen_get_n_monitors (gdk_screen_get_default))) 616 (get) 617 (fail)))) 618 619(define (location->window x y) 620 (for/or ([f (in-hash-keys all-frames)]) 621 (let ([fx (send f get-x)] 622 [fw (send f get-width)]) 623 (and (<= fx x (+ fx fw)) 624 (let ([fy (send f get-y)] 625 [fh (send f get-height)]) 626 (<= fy y (+ fy fh))) 627 f)))) 628 629;; ---------------------------------------- 630 631(define (get-current-mouse-state) 632 (define-values (x y mods) (gdk_window_get_pointer 633 (gdk_screen_get_root_window 634 (gdk_screen_get_default)))) 635 (define (maybe mask sym) 636 (if (zero? (bitwise-and mods mask)) 637 null 638 (list sym))) 639 (values (make-object point% x y) 640 (append 641 (maybe GDK_BUTTON1_MASK 'left) 642 (maybe GDK_BUTTON2_MASK 'middle) 643 (maybe GDK_BUTTON3_MASK 'right) 644 (maybe GDK_SHIFT_MASK 'shift) 645 (maybe GDK_LOCK_MASK 'caps) 646 (maybe GDK_CONTROL_MASK 'control) 647 (maybe GDK_MOD1_MASK 'alt) 648 (maybe GDK_META_MASK 'meta)))) 649 650(define (tell-all-frames-signal-changed n) 651 (define frames (for/list ([f (in-hash-keys all-frames)]) f)) 652 (for ([f (in-hash-keys all-frames)]) 653 (define e (send f get-eventspace)) 654 (unless (eventspace-shutdown? e) 655 (parameterize ([current-eventspace e]) 656 (queue-callback 657 (λ () 658 (send f display-changed))))))) 659 660(define-signal-handler 661 connect-monitor-changed-signal 662 "monitors-changed" 663 (_fun _GdkScreen -> _void) 664 (λ (screen) (tell-all-frames-signal-changed 1))) 665 666(define-signal-handler 667 connect-size-changed-signal 668 "size-changed" 669 (_fun _GdkScreen -> _void) 670 (λ (screen) (tell-all-frames-signal-changed 2))) 671 672(define-signal-handler 673 connect-composited-changed-signal 674 "composited-changed" 675 (_fun _GdkScreen -> _void) 676 (λ (screen) (tell-all-frames-signal-changed 3))) 677 678(define (screen-size-signal-connect connect-signal) 679 (void (connect-signal (cast (gdk_screen_get_default) _GdkScreen _GtkWidget)))) 680(screen-size-signal-connect connect-monitor-changed-signal) 681(screen-size-signal-connect connect-size-changed-signal) 682(screen-size-signal-connect connect-composited-changed-signal) 683
