-
Notifications
You must be signed in to change notification settings - Fork 6
/
widget.rkt
86 lines (79 loc) · 2.91 KB
/
widget.rkt
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
#lang racket
(require "../../mred-plugin.rkt"
"../../misc.rkt"
"../../default-values.rkt"
"../../controller.rkt"
racket/gui/base)
;;; TODO: deleting a tab-panel with children is buggy
;;; (some children are not "active children" for delete-child)
(define tab-panel-preview%
(class tab-panel% (super-new)
;(define single-panel (new panel:single% [parent this]))
;(define/public (get-single-panel) single-panel)
(define child-panels '())
(define/public (add-child-panel p label)
(set! child-panels (append child-panels (list p)))
(send this append label)
(when (> (length child-panels) 1)
(super delete-child p))) ; super and not 'send this...' !
; other possibility: give the 'deleted style to not-first children
(define/public (active-child n)
(if (empty? child-panels)
(controller-select-mred-id (send this get-mred-id))
(let ([child-panel (list-ref child-panels n)])
(send this change-children
(λ(children) (list child-panel)))
;(send single-panel active-child child-panel)
(controller-select-mred-id (send child-panel get-mred-id))
)))
(define/override (delete-child c)
(super delete-child c)
(send this delete (list-pos child-panels c))
(set! child-panels (remq c child-panels))
(send this refresh)
)
))
(make-plugin
[type 'tab-panel]
[tooltip "Tab Panel"]
[button-group "Containers"]
[widget-class tab-panel-preview%]
[code-gen-class
; here we could now use `precode' to avoid writing this class each time:
(class tab-panel% (super-new)
;(define single-panel (new panel:single% [parent this]))
;(define/public (get-single-panel) single-panel)
(define child-panels '())
(define/public (add-child-panel p label)
(set! child-panels (append child-panels (list p)))
(send this append label)
; without this, all the panels will be shown initially
; (we only want the first child to be shown at first)
(when (> (length child-panels) 1)
(send this delete-child p)))
(define/public (active-child n)
(send this change-children
(lambda (children)
(list (list-ref child-panels n)))))
;(send single-panel active-child (list-ref child-panels n)))
;(send this active-child (list-ref child-panels n)))
)]
[parent-class container-classes]
[necessary '(parent choices)] ; necessary properties
[options '()]
( ; widget properties
[choices '()]
[callback (prop:code (λ(tp e)
(send tp active-child (send tp get-selection))))]
[style (prop:some-of '(no-border deleted) '())]
[enabled #t]
[vert-margin 0]
[horiz-margin 0]
[border 0]
[spacing 0]
[alignment (alignment-values 'center 'center)]
[min-width 0]
[min-height 0]
[stretchable-width #t]
[stretchable-height #t]
))