f42356da3f
The main advantage of GTK+ 3 is better support for HiDPI displays. If GTK+ 3 libraries are not available or if the `PLT_GTK2` environment variable is defined, GTK+ 2 is used as before.
204 lines
6.4 KiB
Racket
204 lines
6.4 KiB
Racket
#lang racket/base
|
|
(require racket/class
|
|
ffi/unsafe
|
|
"../../syntax.rkt"
|
|
"window.rkt"
|
|
"client-window.rkt"
|
|
"utils.rkt"
|
|
"panel.rkt"
|
|
"types.rkt"
|
|
"widget.rkt"
|
|
"message.rkt"
|
|
"../../lock.rkt"
|
|
"../common/event.rkt")
|
|
|
|
(provide
|
|
(protect-out tab-panel%))
|
|
|
|
(define-gtk gtk_notebook_new (_fun -> _GtkWidget))
|
|
|
|
(define-gtk gtk_notebook_append_page (_fun _GtkWidget _GtkWidget (_or-null _GtkWidget) -> _void))
|
|
(define-gtk gtk_notebook_remove_page (_fun _GtkWidget _int -> _void))
|
|
(define-gtk gtk_notebook_set_scrollable (_fun _GtkWidget _gboolean -> _void))
|
|
(define-gtk gtk_notebook_get_current_page (_fun _GtkWidget -> _int))
|
|
(define-gtk gtk_notebook_set_current_page (_fun _GtkWidget _int -> _void))
|
|
(define-gtk gtk_notebook_get_tab_label (_fun _GtkWidget _GtkWidget -> _GtkWidget))
|
|
|
|
(define-gtk gtk_container_remove (_fun _GtkWidget _GtkWidget -> _void))
|
|
|
|
(define-gtk gtk_widget_ref (_fun _GtkWidget -> _void)
|
|
#:fail (lambda () g_object_ref))
|
|
(define-gtk gtk_widget_unref (_fun _GtkWidget -> _void)
|
|
#:fail (lambda () g_object_unref))
|
|
|
|
(define-struct page (bin-gtk label-gtk))
|
|
|
|
(define-signal-handler connect-changed "switch-page"
|
|
(_fun _GtkWidget _pointer _int -> _void)
|
|
(lambda (gtk ignored i)
|
|
(let ([wx (gtk->wx gtk)])
|
|
(when wx
|
|
(send wx page-changed i)))))
|
|
|
|
(define tab-panel%
|
|
(class (client-size-mixin (panel-container-mixin (panel-mixin window%)))
|
|
(init parent
|
|
x y w h
|
|
style
|
|
labels)
|
|
|
|
(inherit set-size set-auto-size infer-client-delta get-gtk
|
|
reset-child-dcs get-height)
|
|
|
|
(define gtk (gtk_notebook_new))
|
|
;; Reparented so that it's always in the current page's bin:
|
|
(define client-gtk (gtk_fixed_new))
|
|
|
|
(gtk_notebook_set_scrollable gtk #t)
|
|
|
|
(super-new [parent parent]
|
|
[gtk gtk]
|
|
[client-gtk client-gtk]
|
|
[extra-gtks (list client-gtk)]
|
|
[no-show? (memq 'deleted style)])
|
|
|
|
; Once without tabs to set client-width delta:
|
|
(infer-client-delta #t #f)
|
|
|
|
(define empty-bin-gtk (gtk_hbox_new #f 0))
|
|
(define current-bin-gtk #f)
|
|
|
|
(define (select-bin bin-gtk)
|
|
(set! current-bin-gtk bin-gtk)
|
|
(gtk_box_pack_start bin-gtk client-gtk #t #t 0)
|
|
;; re-parenting can change the underlying window dc:
|
|
(reset-child-dcs))
|
|
|
|
(define pages
|
|
(for/list ([lbl labels])
|
|
(let ([bin-gtk (gtk_hbox_new #f 0)]
|
|
[label-gtk (gtk_label_new_with_mnemonic lbl)])
|
|
(gtk_notebook_append_page gtk bin-gtk label-gtk)
|
|
(gtk_widget_show bin-gtk)
|
|
(make-page bin-gtk label-gtk))))
|
|
|
|
(define/private (install-empty-page)
|
|
(gtk_notebook_append_page gtk empty-bin-gtk #f)
|
|
(gtk_widget_show empty-bin-gtk))
|
|
|
|
(if (null? pages)
|
|
(begin
|
|
(select-bin empty-bin-gtk)
|
|
(install-empty-page))
|
|
(begin
|
|
(select-bin (page-bin-gtk (car pages)))))
|
|
(gtk_widget_show client-gtk)
|
|
|
|
(connect-key-and-mouse gtk)
|
|
(connect-focus gtk)
|
|
|
|
; With tabs to set client-width delta:
|
|
(infer-client-delta #f #t)
|
|
|
|
(set-auto-size)
|
|
|
|
(define callback void)
|
|
(define/public (set-callback cb) (set! callback cb))
|
|
(define/private (do-callback)
|
|
(callback this (new control-event%
|
|
[event-type 'tab-panel]
|
|
[time-stamp (current-milliseconds)])))
|
|
|
|
(define/public (swap-in bin-gtk)
|
|
(gtk_widget_ref client-gtk)
|
|
(gtk_container_remove current-bin-gtk client-gtk)
|
|
(select-bin bin-gtk)
|
|
(gtk_widget_unref client-gtk))
|
|
|
|
(define callback-ok? #t)
|
|
|
|
(define/public (page-changed i)
|
|
; range check works around spurious callbacks:
|
|
(when (< -1 i (length pages))
|
|
(swap-in (page-bin-gtk (list-ref pages i)))
|
|
(when callback-ok?
|
|
(queue-window-event this (lambda () (do-callback))))))
|
|
(connect-changed gtk)
|
|
|
|
(define/override (get-client-gtk) client-gtk)
|
|
|
|
(public [append* append])
|
|
(define (append* lbl)
|
|
(atomically
|
|
(set! callback-ok? #f)
|
|
(do-append lbl)
|
|
(set! callback-ok? #t)))
|
|
|
|
(define/private (do-append lbl)
|
|
(let ([page
|
|
(let ([bin-gtk (gtk_hbox_new #f 0)]
|
|
[label-gtk (gtk_label_new_with_mnemonic lbl)])
|
|
(gtk_notebook_append_page gtk bin-gtk label-gtk)
|
|
(gtk_widget_show bin-gtk)
|
|
(make-page bin-gtk label-gtk))])
|
|
(set! pages (append pages (list page)))
|
|
(when (null? (cdr pages))
|
|
(swap-in (page-bin-gtk (car pages)))
|
|
(g_object_ref empty-bin-gtk)
|
|
(gtk_notebook_remove_page gtk 0))))
|
|
|
|
(define/private (do-delete i)
|
|
(let ([page (list-ref pages i)])
|
|
(when (ptr-equal? current-bin-gtk (page-bin-gtk page))
|
|
(let ([cnt (length pages)])
|
|
(if (= i (sub1 cnt))
|
|
(if (null? (cdr pages))
|
|
(begin
|
|
(install-empty-page)
|
|
(set! pages null)
|
|
(gtk_notebook_set_current_page gtk 1)
|
|
(swap-in empty-bin-gtk))
|
|
(gtk_notebook_set_current_page gtk (sub1 i)))
|
|
(gtk_notebook_set_current_page gtk (add1 i)))))
|
|
(gtk_notebook_remove_page gtk i)
|
|
(set! pages (remq page pages))))
|
|
|
|
(define/public (delete i)
|
|
(atomically
|
|
(set! callback-ok? #f)
|
|
(do-delete i)
|
|
(set! callback-ok? #t)))
|
|
|
|
(define/public (set choices)
|
|
(atomically
|
|
(set! callback-ok? #f)
|
|
(for ([page (in-list pages)])
|
|
(do-delete 0))
|
|
(for ([lbl (in-list choices)])
|
|
(append* lbl))
|
|
(set! callback-ok? #t)))
|
|
|
|
(define/public (set-label i str)
|
|
(gtk_label_set_text_with_mnemonic (page-label-gtk (list-ref pages i))
|
|
(mnemonic-string str)))
|
|
|
|
(define/public (number) (length pages))
|
|
(define/public (button-focus n)
|
|
(if (= n -1)
|
|
(get-selection)
|
|
(direct-set-selection n)))
|
|
|
|
(define/override (gets-focus?) #t)
|
|
(define/override (set-focus)
|
|
(gtk_widget_grab_focus gtk))
|
|
|
|
(define/private (direct-set-selection i)
|
|
(gtk_notebook_set_current_page gtk i))
|
|
(define/public (set-selection i)
|
|
(atomically
|
|
(set! callback-ok? #f)
|
|
(direct-set-selection i)
|
|
(set! callback-ok? #t)))
|
|
(define/public (get-selection)
|
|
(gtk_notebook_get_current_page gtk))))
|