762 lines
32 KiB
Racket
762 lines
32 KiB
Racket
(module wxtop racket/base
|
|
(require racket/class
|
|
racket/list
|
|
(prefix-in wx: "kernel.rkt")
|
|
(prefix-in wx: "wxme/editor-canvas.rkt")
|
|
(prefix-in wx: "wxme/editor-snip.rkt")
|
|
"lock.rkt"
|
|
"helper.rkt"
|
|
"const.rkt"
|
|
"check.rkt"
|
|
"wx.rkt"
|
|
"wxwindow.rkt"
|
|
"wxcontainer.rkt")
|
|
|
|
(provide (protect-out active-main-frame
|
|
set-root-menu-wx-frame!
|
|
add-active-frame-callback!)
|
|
get-display-size
|
|
get-display-left-top-inset
|
|
get-display-count
|
|
get-display-backing-scale
|
|
(protect-out make-top-container%
|
|
make-top-level-window-glue%
|
|
wx-frame%
|
|
wx-dialog%))
|
|
|
|
;; Weak boxed:
|
|
(define active-main-frame (make-weak-box #f))
|
|
|
|
(define active-frame-callbacks null)
|
|
(define (add-active-frame-callback! cb)
|
|
(set! active-frame-callbacks (cons cb active-frame-callbacks)))
|
|
|
|
(define root-menu-wx-frame #f)
|
|
(define (set-root-menu-wx-frame! f)
|
|
(set! root-menu-wx-frame f))
|
|
|
|
(define get-display-size
|
|
(lambda ([full-screen? #f] #:monitor [monitor 0])
|
|
(unless (exact-nonnegative-integer? monitor)
|
|
(raise-argument-error 'get-display-size "exact-nonnegative-integer?" monitor))
|
|
(let/ec esc
|
|
(let ([xb (box 0)]
|
|
[yb (box 0)])
|
|
(wx:display-size xb yb full-screen? monitor
|
|
(lambda () (esc #f #f)))
|
|
(values (unbox xb) (unbox yb))))))
|
|
|
|
(define get-display-left-top-inset
|
|
(lambda ([advisory? #f] #:monitor [monitor 0])
|
|
(unless (exact-nonnegative-integer? monitor)
|
|
(raise-argument-error 'get-display-left-top-inset "exact-nonnegative-integer?" monitor))
|
|
(let/ec esc
|
|
(let ([xb (box 0)]
|
|
[yb (box 0)])
|
|
(wx:display-origin xb yb advisory? monitor (lambda () (esc #f #f)))
|
|
(values (unbox xb) (unbox yb))))))
|
|
|
|
(define get-display-count
|
|
(lambda ()
|
|
(wx:display-count)))
|
|
|
|
(define get-display-backing-scale
|
|
(lambda (#:monitor [monitor 0])
|
|
(unless (exact-nonnegative-integer? monitor)
|
|
(raise-argument-error 'get-display-backing-scale "exact-nonnegative-integer?" monitor))
|
|
(wx:display-bitmap-resolution monitor (lambda () #f))))
|
|
|
|
(define-values (left-margin top-margin init-top-x init-top-y)
|
|
(let-values ([(x y) (get-display-left-top-inset #f)]
|
|
[(x2 y2) (get-display-left-top-inset #t)])
|
|
(values (- x2 x)
|
|
(- y2 y)
|
|
(+ 1 (- x2 x))
|
|
(+ 1 (- y2 y)))))
|
|
|
|
(define top-x init-top-x)
|
|
(define top-y init-top-y)
|
|
|
|
;; make-top-container%: adds the necessary functionality to wx:frame% and
|
|
;; wx:dialog%.
|
|
;; input: base%: the base class from which to descend the new class.
|
|
;; Intended to be either wx:frame% or wx:dialog%, but can
|
|
;; be anything which contains all methods in the inherit section
|
|
;; below.
|
|
;; returns: a new class, descended from base%, which possesses the added
|
|
;; capabilities necessary to serve as the frame/dialog which
|
|
;; contains container classes.
|
|
(define (make-top-container% base% dlg?)
|
|
(class (wx-make-container% (wx-make-window% base% #t))
|
|
(init parent)
|
|
(init-rest args)
|
|
(inherit get-x get-y get-width get-height set-size
|
|
get-client-size is-shown? on-close enforce-size
|
|
get-eventspace get-focus-window)
|
|
;; have we had any redraw requests while the window has been
|
|
;; hidden?
|
|
(define pending-redraws? #t)
|
|
|
|
(define perform-updates? #t)
|
|
(define seq-count 0)
|
|
|
|
(define ignore-redraw-request? #f)
|
|
|
|
(define already-trying? #f)
|
|
(define was-bad? #f) ; hack around min-frame-size limitations
|
|
(define tried-sizes #hash())
|
|
|
|
;; pointer to panel in the frame for use in on-size
|
|
(define panel #f)
|
|
|
|
(define use-default-position? (and (not (list-ref args 2))
|
|
(not (list-ref args 1))))
|
|
|
|
(define enabled? #t)
|
|
(define focus #f)
|
|
|
|
(define border-buttons null)
|
|
|
|
(define parent-for-center parent)
|
|
|
|
(define show-ht (make-hasheq))
|
|
(define fake-show-ht (make-hasheq))
|
|
|
|
(override*
|
|
[enable
|
|
(lambda (b)
|
|
(set! enabled? (and b #t))
|
|
(super enable b))])
|
|
|
|
(public*
|
|
|
|
[is-enabled?
|
|
(lambda () enabled?)]
|
|
|
|
[set-focus-window
|
|
(lambda (w)
|
|
(unless (eq? 'macosx (system-type))
|
|
(set! border-buttons (filter weak-box-value border-buttons))
|
|
(if (not w)
|
|
;; Non-border button losing focus?
|
|
(when (and (focus . is-a? . wx:button%)
|
|
(not (memq focus (map weak-box-value border-buttons))))
|
|
(send focus defaulting #f))
|
|
;; Something gaining focus... adjust border buttons
|
|
(begin
|
|
(for-each (lambda (bb)
|
|
(let ([b (weak-box-value bb)])
|
|
(when b
|
|
(send b defaulting (or (not (w . is-a? . wx:button%))
|
|
(eq? b w))))))
|
|
border-buttons)
|
|
(when (w . is-a? . wx:button%)
|
|
(send w defaulting #t))))
|
|
(set! focus w)))]
|
|
|
|
[get-edit-target-window
|
|
(lambda () (get-focus-window #t))]
|
|
[get-focus-object
|
|
(lambda ()
|
|
(window->focus-object (get-focus-window)))]
|
|
[get-edit-target-object
|
|
(lambda ()
|
|
(window->focus-object (get-focus-window #t)))]
|
|
|
|
[window->focus-object
|
|
(lambda (w)
|
|
(and w
|
|
(if (is-a? w wx:editor-canvas%)
|
|
(let loop ([m (send w get-editor)]
|
|
[prev w])
|
|
(if m
|
|
(let ([snip (send m get-focus-snip)])
|
|
(if (and snip (is-a? snip wx:editor-snip%))
|
|
(loop (send snip get-editor) m)
|
|
m))
|
|
w))
|
|
focus)))]
|
|
|
|
[add-border-button
|
|
(lambda (b)
|
|
(set! border-buttons (filter weak-box-value border-buttons))
|
|
(set! border-buttons (cons (make-weak-box b) border-buttons)))]
|
|
|
|
;; add-child: update panel pointer.
|
|
;; input: new-panel: panel in frame (descendant of
|
|
;; panel%)
|
|
;; returns: nothing
|
|
;; effects: sets panel to new-panel
|
|
;; if new-panel is not a descendant of
|
|
;; panel%, calls error; panel not updated.
|
|
[add-child
|
|
(lambda (new-panel)
|
|
(set! panel new-panel)
|
|
(set! pending-redraws? #t)
|
|
(let-values ([(client-w client-h)
|
|
(get-two-int-values (lambda (a b) (get-client-size a b)))])
|
|
(send panel set-size 0 0 client-w client-h))
|
|
(self-redraw-request))]
|
|
|
|
[area-parent (lambda () #f)]
|
|
|
|
[get-top-panel
|
|
(lambda ()
|
|
panel)]
|
|
|
|
[delay-updates
|
|
(case-lambda
|
|
[() (not perform-updates?)]
|
|
[(f)
|
|
(set! perform-updates? (not f))
|
|
(when perform-updates?
|
|
(when pending-redraws?
|
|
(force-redraw))
|
|
(when (positive? (hash-count fake-show-ht))
|
|
(let ([t fake-show-ht])
|
|
(set! fake-show-ht (make-hasheq))
|
|
(hash-for-each
|
|
t
|
|
(lambda (win v?)
|
|
(send win really-show #t)))))
|
|
(when (positive? (hash-count show-ht))
|
|
(let ([t show-ht])
|
|
(set! show-ht (make-hasheq))
|
|
(hash-for-each
|
|
t
|
|
(lambda (win v?)
|
|
(send win show v?))))))])]
|
|
[begin-container-sequence
|
|
(lambda ()
|
|
(when (zero? seq-count)
|
|
(delay-updates #t))
|
|
(set! seq-count (add1 seq-count)))]
|
|
[end-container-sequence
|
|
(lambda ()
|
|
(set! seq-count (sub1 seq-count))
|
|
(when (zero? seq-count)
|
|
(delay-updates #f)))]
|
|
|
|
[forget-child
|
|
(lambda (child)
|
|
(unless (hash-ref show-ht child #t)
|
|
(send child show #f))
|
|
(hash-remove! show-ht child))]
|
|
|
|
[show-child
|
|
(lambda (child show?)
|
|
(if perform-updates?
|
|
(send child show show?)
|
|
(hash-set! show-ht child show?)))]
|
|
|
|
[show-control
|
|
(lambda (child on?)
|
|
(if (or perform-updates?
|
|
(not on?)
|
|
(child . is-a? . wx-frame%)
|
|
(child . is-a? . wx-dialog%))
|
|
(begin
|
|
(hash-remove! fake-show-ht child)
|
|
(send child really-show on?))
|
|
(begin
|
|
(hash-set! fake-show-ht child #t)
|
|
(send child fake-show on?))))]
|
|
|
|
;; force-redraw: receives a message from to redraw the
|
|
;; entire frame.
|
|
;; input: none
|
|
;; returns: nothing
|
|
;; effects: redraws the frame at its current size (changing size
|
|
;; as necessary).
|
|
[child-redraw-request
|
|
;; since there's only one panel, we assume that `from' is the
|
|
;; panel and the request should be granted
|
|
(lambda (from)
|
|
(unless ignore-redraw-request?
|
|
(self-redraw-request)))]
|
|
[self-redraw-request
|
|
(lambda ()
|
|
(if (and (is-shown?) perform-updates?)
|
|
(force-redraw)
|
|
(set! pending-redraws? #t)))]
|
|
[force-redraw
|
|
(lambda ()
|
|
(if panel
|
|
(dynamic-wind
|
|
(lambda () (set! ignore-redraw-request? #t))
|
|
(lambda () (resized))
|
|
(lambda () (set! ignore-redraw-request? #f)))
|
|
|
|
(set! pending-redraws? #f)))]
|
|
|
|
[correct-size
|
|
(lambda (frame-w frame-h)
|
|
(if (not panel)
|
|
(values frame-w frame-h)
|
|
(let-values ([(f-client-w f-client-h) (get-two-int-values
|
|
(lambda (a b) (get-client-size a b)))])
|
|
(let* ([panel-info (send panel get-info)]
|
|
|
|
;; difference between panel's full size &
|
|
;; frame's full size
|
|
[delta-w (max 0 (- (get-width) f-client-w))]
|
|
[delta-h (max 0 (- (get-height) f-client-h))]
|
|
|
|
;; minimum frame size:
|
|
[min-w (+ delta-w (child-info-x-min panel-info))]
|
|
[min-h (+ delta-h (child-info-y-min panel-info))]
|
|
|
|
;; correct size for frame
|
|
[new-w
|
|
(cond
|
|
[(< frame-w min-w) min-w]
|
|
[(and (> frame-w min-w) (not (child-info-x-stretch panel-info))) min-w]
|
|
[else frame-w])]
|
|
[new-h
|
|
(cond
|
|
[(< frame-h min-h) min-h]
|
|
[(and (> frame-h min-h) (not (child-info-y-stretch panel-info))) min-h]
|
|
[else frame-h])])
|
|
(values (max new-w 1) (max new-h 1)
|
|
(max min-w 1) (max min-h 1)
|
|
(child-info-x-stretch panel-info) (child-info-y-stretch panel-info))))))]
|
|
|
|
[set-panel-size
|
|
(lambda ()
|
|
(when panel
|
|
(let-values ([(f-client-w f-client-h) (get-two-int-values
|
|
(lambda (a b) (get-client-size a b)))]
|
|
[(panel-info) (send panel get-info)]
|
|
[(sel) (lambda (nsize psize stretch?)
|
|
(if stretch?
|
|
(max nsize psize)
|
|
psize))])
|
|
(send panel set-size 0 0
|
|
(sel f-client-w (child-info-x-min panel-info)
|
|
(child-info-x-stretch panel-info))
|
|
(sel f-client-h (child-info-y-min panel-info)
|
|
(child-info-y-stretch panel-info)))
|
|
(set! pending-redraws? #f)
|
|
(send panel on-container-resize))))]
|
|
|
|
|
|
[resized
|
|
(entry-point
|
|
(lambda ()
|
|
(unless already-trying?
|
|
(let ([new-width (get-width)]
|
|
[new-height (get-height)])
|
|
(let-values ([(correct-w correct-h min-w min-h sx? sy?) (correct-size new-width new-height)])
|
|
(cond
|
|
[(and (= new-width correct-w) (= new-height correct-h))
|
|
;; Good size; do panel
|
|
(set! was-bad? #f)
|
|
(set! tried-sizes #hash())
|
|
(enforce-size min-w min-h
|
|
(if sx? -1 min-w) (if sy? -1 min-h)
|
|
1 1)
|
|
(set-panel-size)]
|
|
[(and (hash-ref tried-sizes (cons correct-w correct-h) #f)
|
|
was-bad?)
|
|
;; We give up; do panel
|
|
(set-panel-size)]
|
|
[else
|
|
;; Too large/small; try to fix it, but give up after a while
|
|
(set! was-bad? #t)
|
|
(set! tried-sizes (hash-set tried-sizes (cons correct-w correct-h) #t))
|
|
(set! already-trying? #t)
|
|
(enforce-size -1 -1 -1 -1 1 1)
|
|
(set-size #f #f correct-w correct-h)
|
|
(enforce-size min-w min-h
|
|
(if sx? -1 min-w) (if sy? -1 min-h)
|
|
1 1)
|
|
(set! already-trying? #f)
|
|
(resized)]))))))])
|
|
|
|
(public*
|
|
[call-show
|
|
(lambda (on? do-show)
|
|
(when on?
|
|
(position-for-initial-show))
|
|
(as-exit ; as-exit because there's an implicit wx:yield for dialogs
|
|
do-show))])
|
|
|
|
(override*
|
|
;; show: add capability to set perform-updates
|
|
;; input: now : boolean
|
|
;; returns: nothing
|
|
;; effects: if we're showing for the first time, unblock updates
|
|
;; and force an update. If we're hiding, block updates.
|
|
;; pass now to superclass's show.
|
|
[show
|
|
(lambda (on?)
|
|
(call-show
|
|
on?
|
|
(lambda () (super show on?))))]
|
|
|
|
[on-visible
|
|
(lambda ()
|
|
(send panel queue-visible)
|
|
(super on-visible))]
|
|
[on-active
|
|
(lambda ()
|
|
(send panel queue-active)
|
|
(super on-active))]
|
|
|
|
[move (lambda (x y) (set! use-default-position? #f) (super move x y))]
|
|
[center (lambda (dir)
|
|
(when pending-redraws? (force-redraw))
|
|
(set! use-default-position? #f)
|
|
(super center dir parent-for-center))] ; 2nd argument is for Mac OS X
|
|
|
|
;; on-size: ensures that size of frame matches size of content
|
|
;; input: new-width/new-height: new size of frame
|
|
;; returns: nothing
|
|
;; effects: if new size is smaller than allowed size of
|
|
;; contents, frame resized to smallest possible size.
|
|
;; If frame is larger than contents and contents
|
|
;; aren't stretchable, frame resized to size of
|
|
;; contents. Each direction is handled
|
|
;; independently.
|
|
[queue-on-size
|
|
(lambda ()
|
|
(unless (and already-trying? (not (eq? 'unix (system-type))))
|
|
(parameterize ([wx:current-eventspace (get-eventspace)])
|
|
(wx:queue-callback (lambda () (resized)) wx:middle-queue-key))))])
|
|
|
|
(public*
|
|
[position-for-initial-show
|
|
(lambda ()
|
|
(when pending-redraws?
|
|
(force-redraw))
|
|
(when use-default-position?
|
|
(set! use-default-position? #f)
|
|
(if dlg?
|
|
(center 'both)
|
|
(let*-values ([(w) (get-width)]
|
|
[(h) (get-height)]
|
|
[(sw sh) (get-display-size)]
|
|
[(x x-reset?) (if (< (+ top-x w) (+ sw left-margin))
|
|
(values top-x #f)
|
|
(values (max init-top-x (- sw w 10)) #t))]
|
|
[(y y-reset?) (if (< (+ top-y h) (+ sh top-margin))
|
|
(values top-y #f)
|
|
(values (max init-top-y (- sh h 20)) #t))])
|
|
(move x y)
|
|
(set! top-x (if x-reset? init-top-x (+ top-x 10)))
|
|
(set! top-y (if y-reset? init-top-y (+ top-y 20)))))))]
|
|
[handle-traverse-key
|
|
(lambda (e)
|
|
(and panel
|
|
(let ([code (send e get-key-code)])
|
|
(case code
|
|
[(#\return)
|
|
(let ([o (get-focus-window)])
|
|
(if (and o (send o handles-key-code code #f #f))
|
|
#f
|
|
(let ([objs (container->children panel #f #f)])
|
|
(or (ormap
|
|
(lambda (x)
|
|
(and (is-a? x wx:button%)
|
|
(send x has-border?)
|
|
(let ([v (make-object wx:control-event% 'button)])
|
|
(do-command x v)
|
|
#t)))
|
|
objs)
|
|
(not (is-a? o wx:editor-canvas%))))))]
|
|
[(escape #\.)
|
|
(and (is-a? this wx:dialog%)
|
|
(or (eq? code 'escape)
|
|
(and (memq (system-type) '(macos macosx))
|
|
(send e get-meta-down)))
|
|
(let ([o (get-focus-window)])
|
|
(if (and o (send o handles-key-code code #f (send e get-meta-down)))
|
|
#f
|
|
(begin
|
|
(when (on-close)
|
|
(show #f))
|
|
#t))))]
|
|
[(#\space)
|
|
(let ([o (get-focus-window)])
|
|
(cond
|
|
[(is-a? o wx:button%)
|
|
(do-command o (make-object wx:control-event% 'button))
|
|
#t]
|
|
[(is-a? o wx:check-box%)
|
|
(send o set-value (not (send o get-value)))
|
|
(do-command o (make-object wx:control-event% 'check-box))
|
|
#t]
|
|
[(is-a? o wx:radio-box%)
|
|
(let ([s (send o button-focus -1)])
|
|
(unless (negative? s)
|
|
(send o set-selection s)
|
|
(do-command o (make-object wx:control-event% 'radio-box))))
|
|
#t]
|
|
[(is-a? o wx-tab-group<%>)
|
|
(let ([s (send o button-focus -1)])
|
|
(unless (negative? s)
|
|
(send o set-selection s)
|
|
(do-command (wx->mred o) (make-object wx:control-event% 'tab-panel))))
|
|
#t]
|
|
[else #f]))]
|
|
[(#\tab left up down right)
|
|
(let ([o (get-focus-window)])
|
|
(if (and o (send o handles-key-code code #f #f))
|
|
#f
|
|
(let* ([shift? (send e get-shift-down)]
|
|
[forward? (or (and (eq? code #\tab) (not shift?))
|
|
(memq code '(right down)))]
|
|
[normal-move
|
|
(lambda ()
|
|
(let* ([o (if (or (is-a? o wx:canvas%)
|
|
(is-a? o wx:item%)
|
|
(is-a? o wx:tab-panel%))
|
|
(if (is-a? o wx-group-box<%>)
|
|
#f
|
|
o)
|
|
#f)]
|
|
[candidates
|
|
(map object->position (container->children panel o #t))]
|
|
[dests (filter-overlapping candidates)]
|
|
[pos (if o (object->position o) (list 'x 0 0 1 1))]
|
|
[o (traverse (cadr pos) (caddr pos) (cadddr pos) (list-ref pos 4)
|
|
(case code
|
|
[(#\tab) (if shift? 'prev 'next)]
|
|
[else code])
|
|
dests)])
|
|
(when o
|
|
(if (or (is-a? o wx:radio-box%)
|
|
(is-a? o wx-tab-group<%>))
|
|
(send o button-focus (max 0 (send o button-focus -1)))
|
|
(begin
|
|
(send o set-focus)
|
|
(if (and (is-a? o wx-text-editor-canvas<%>)
|
|
(send o is-single-line?))
|
|
(let ([e (send o get-editor)])
|
|
(as-exit
|
|
(lambda ()
|
|
(send e set-position 0 (send e last-position) #f #t 'local))))
|
|
;; Not a text field; a canvas?
|
|
(when (or (is-a? o wx:canvas%)
|
|
(is-a? o wx:editor-canvas%))
|
|
(as-exit (lambda () (send o on-tab-in))))))))))])
|
|
(if (and (not (eqv? code #\tab))
|
|
(or (is-a? o wx:radio-box%)
|
|
(is-a? o wx:tab-panel%)))
|
|
(let ([n (send o number)]
|
|
[s (send o button-focus -1)]
|
|
[v-move? (memq code '(up down))]
|
|
[h-move? (memq code '(left right))]
|
|
[v? (and (is-a? o wx:radio-box%)
|
|
(send o vertical?))])
|
|
(cond
|
|
[(or (negative? s)
|
|
(and v? h-move?)
|
|
(and (not v?) v-move?))
|
|
(normal-move)]
|
|
[(and forward? (< s (sub1 n)))
|
|
(send o button-focus (add1 s))]
|
|
[(and (not forward?) (positive? s))
|
|
(send o button-focus (sub1 s))]
|
|
[else (normal-move)]))
|
|
(normal-move))
|
|
#t)))]
|
|
[else (if (and (wx:shortcut-visible-in-label?)
|
|
(char? code)
|
|
(or (char-alphabetic? code)
|
|
(char-numeric? code))
|
|
(not (send e get-shift-down))
|
|
(not (send e get-control-down))
|
|
(not (send e get-alt-down)))
|
|
(let ([o (get-focus-window)]
|
|
[meta? (send e get-meta-down)])
|
|
(if (and o (send o handles-key-code code #t meta?))
|
|
#f
|
|
;; Move selection/hit control based on & shortcuts
|
|
(let* ([objs (container->children panel #f #t)]
|
|
[re (key-regexp code)])
|
|
(ormap
|
|
(lambda (o)
|
|
(let* ([win (wx->proxy o)]
|
|
[l (send win get-label)])
|
|
(cond
|
|
[(and (string? l)
|
|
(regexp-match re l))
|
|
(send o set-focus)
|
|
(send o char-to)
|
|
#t]
|
|
[(is-a? o wx:radio-box%)
|
|
(let ([n (send o number)])
|
|
(let loop ([i 0])
|
|
(if (= i n)
|
|
#f
|
|
(let ([l (send win get-item-label i)])
|
|
(if (and (string? l)
|
|
(regexp-match re l))
|
|
(begin
|
|
(send o button-focus i)
|
|
(send o char-to-button i)
|
|
#t)
|
|
(loop (add1 i)))))))]
|
|
[else #f])))
|
|
objs))))
|
|
#f)]))))])
|
|
|
|
(apply super-make-object parent args)))
|
|
|
|
(define (make-top-level-window-glue% style-pos %) ; implies make-window-glue%
|
|
(class (make-window-glue% %)
|
|
(init mred proxy)
|
|
(init-rest args)
|
|
(inherit is-shown? get-mred queue-visible get-eventspace)
|
|
(define act-date/seconds 0)
|
|
(define act-date/milliseconds 0)
|
|
(define act-on? #f)
|
|
(define activate-refresh-wins null)
|
|
(define floating-window?
|
|
(and ((length args) . >= . style-pos)
|
|
(memq 'float (list-ref args style-pos))))
|
|
(public*
|
|
[on-exit (entry-point
|
|
(lambda ()
|
|
(and (is-shown?)
|
|
(let ([mred (get-mred)])
|
|
(and (and mred (as-exit (lambda () (send mred can-exit?))))
|
|
(as-exit (lambda () (send mred on-exit))))))))])
|
|
(override*
|
|
[on-close (entry-point
|
|
(lambda ()
|
|
(let ([mred (get-mred)])
|
|
(if mred
|
|
(if (as-exit (lambda () (send mred can-close?)))
|
|
(begin
|
|
(as-exit (lambda () (send mred on-close)))
|
|
(queue-visible)
|
|
#t)
|
|
#f)
|
|
#t))))]
|
|
[on-activate (entry-point
|
|
(lambda (on?)
|
|
(set! act-on? on?)
|
|
(when on?
|
|
(set! act-date/seconds (current-seconds))
|
|
(set! act-date/milliseconds (current-milliseconds))
|
|
(when (and (wx:main-eventspace? (get-eventspace))
|
|
(not (eq? this root-menu-wx-frame))
|
|
(not floating-window?))
|
|
(set! active-main-frame (make-weak-box this))
|
|
(let ([cbs (reverse active-frame-callbacks)])
|
|
(set! active-frame-callbacks null)
|
|
(for ([cb (in-list cbs)]) (cb)))))
|
|
;; Send refresh to subwindows that need it
|
|
(set! activate-refresh-wins (filter weak-box-value activate-refresh-wins))
|
|
(for-each (lambda (b)
|
|
(let ([win (weak-box-value b)])
|
|
(when win
|
|
(send win refresh))))
|
|
activate-refresh-wins)
|
|
;; Windows needs trampoline:
|
|
(queue-window-callback
|
|
this
|
|
(lambda () (send (get-mred) on-activate on?)))
|
|
(as-exit
|
|
(lambda ()
|
|
(super on-activate on?)))))]
|
|
[display-changed
|
|
(λ ()
|
|
(send (get-mred) display-changed))])
|
|
(public*
|
|
[is-act-on? (lambda () act-on?)]
|
|
[add-activate-update (lambda (win) (set! activate-refresh-wins
|
|
(cons (make-weak-box win)
|
|
activate-refresh-wins)))]
|
|
[get-act-date/seconds (lambda () act-date/seconds)]
|
|
[get-act-date/milliseconds (lambda () act-date/milliseconds)])
|
|
(apply super-make-object mred proxy args)))
|
|
|
|
(define function-keys #hasheq((f1 . #t)
|
|
(f2 . #t)
|
|
(f3 . #t)
|
|
(f4 . #t)
|
|
(f5 . #t)
|
|
(f6 . #t)
|
|
(f7 . #t)
|
|
(f8 . #t)
|
|
(f9 . #t)
|
|
(f10 . #t)
|
|
(f11 . #t)
|
|
(f12 . #t)
|
|
(f13 . #t)
|
|
(f14 . #t)
|
|
(f15 . #t)
|
|
(f16 . #t)
|
|
(f17 . #t)
|
|
(f18 . #t)
|
|
(f19 . #t)
|
|
(f20 . #t)
|
|
(f21 . #t)
|
|
(f22 . #t)
|
|
(f23 . #t)
|
|
(f24 . #t)))
|
|
|
|
(define wx-frame%
|
|
(make-top-level-window-glue%
|
|
6
|
|
(class (make-top-container% wx:frame% #f)
|
|
(init-rest args)
|
|
(define-values (menu-bar is-mdi-parent?)
|
|
(values #f #f))
|
|
(public*
|
|
[get-the-menu-bar (lambda () menu-bar)]
|
|
[get-mdi-parent (lambda () is-mdi-parent?)]
|
|
[set-mdi-parent (lambda (x) (and (set! is-mdi-parent? x) #t))])
|
|
(override*
|
|
[set-menu-bar
|
|
(lambda (mb)
|
|
(when mb (set! menu-bar mb))
|
|
(super set-menu-bar mb))]
|
|
[on-menu-command
|
|
(entry-point
|
|
(lambda (id)
|
|
(let ([wx (wx:id-to-menu-item id)])
|
|
(when wx
|
|
(do-command (wx->mred wx) (make-object wx:control-event% 'menu))))))]
|
|
[on-menu-click
|
|
(entry-point
|
|
(lambda ()
|
|
;; Windows: no trampoline needed
|
|
(and menu-bar (send menu-bar on-demand))))]
|
|
[on-toolbar-click
|
|
(entry-point
|
|
(lambda ()
|
|
(as-exit (lambda () (send (wx->mred this) on-toolbar-button-click)))))]
|
|
[on-mdi-activate
|
|
(entry-point
|
|
(lambda (on?)
|
|
(let ([mr (wx->mred this)])
|
|
(queue-window-callback
|
|
this
|
|
(lambda () (send mr on-mdi-activate on?))))))])
|
|
(public*
|
|
[handle-menu-key
|
|
(lambda (event)
|
|
(and menu-bar
|
|
(send menu-bar all-enabled?)
|
|
;; It can't be a menu event without a
|
|
;; control, meta, alt key, or function key
|
|
(or (send event get-control-down)
|
|
(send event get-meta-down)
|
|
(send event get-alt-down)
|
|
(hash-ref function-keys (send event get-key-code) #f))
|
|
(begin
|
|
(send menu-bar on-demand)
|
|
(send menu-bar handle-key event))))])
|
|
(apply super-make-object args))))
|
|
|
|
(define wx-dialog%
|
|
(make-top-level-window-glue%
|
|
6
|
|
(class (make-top-container% wx:dialog% #t)
|
|
(init-rest args)
|
|
(apply super-make-object args)))))
|