suzanne.soy/gui
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

gtk: change clipboard access to keep racket in charge

Browse Source 
instead of letting the ... _wait_...() function drive an
 event loop;
 hopefully Closes PR 11534

original commit: 08eff2111791326007ddb817a16b7dd9d6638aa9
This commit is contained in:
Matthew Flatt 2010-12-13 10:24:58 -07:00
commit c3be46ef63
279 changed files with 26540 additions and 4387 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

30
collects/framework/gui-utils.rkt
View File

@ -294,34 +294,38 @@
(provide/doc
(proc-doc
gui-utils:trim-string
(->d ([str string?][size (and/c number? positive?)])
(->i ([str string?]
[size (and/c number? positive?)])
()
[_ (and/c string?
(λ (str)
((string-length str) . <= . size)))])
[res (size)
(and/c string?
(λ (str)
((string-length str) . <= . size)))])
@{Constructs a string whose size is less
than @scheme[size] by trimming the @scheme[str]
and inserting an ellispses into it.})
(proc-doc
gui-utils:quote-literal-label
(->d ([str string?])
(->i ([str string?])
()
[_ (and/c string?
(lambda (str)
((string-length str) . <= . 200)))])
[res (str)
(and/c string?
(lambda (str)
((string-length str) . <= . 200)))])
@{Constructs a string whose ampersand characters are
escaped; the label is also trimmed to <= 200
characters.})
(proc-doc
gui-utils:format-literal-label
(->d ([str string?])
(->i ([str string?])
()
#:rest rest (listof any/c)
[_ (and/c string?
(lambda (str)
((string-length str) . <= . 200)))])
#:rest [rest (listof any/c)]
[res (str)
(and/c string?
(lambda (str)
((string-length str) . <= . 200)))])
@{Formats a string whose ampersand characters are
mk-escaped; the label is also trimmed to <= 200
mk-characters.})

1554
collects/framework/main.rkt
View File

File diff suppressed because it is too large Load Diff

110
collects/framework/preferences.rkt
View File

@ -29,7 +29,7 @@ the state transitions / contracts are:
(require scribble/srcdoc scheme/class scheme/gui/base
scheme/contract scheme/file)
(require/doc scheme/base scribble/manual)
(require/doc scheme/base scribble/manual (for-label racket/serialize))
(provide exn:struct:unknown-preference)
@ -132,31 +132,58 @@ the state transitions / contracts are:
;; set : symbol any -> void
;; updates the preference
;; exported
(define (multi-set ps values)
(for-each
(λ (p value)
(cond
[(pref-default-set? p)
(let ([default (hash-ref defaults p)])
(unless ((default-checker default) value)
(error 'preferences:set
"tried to set preference ~e to ~e but it does not meet test from preferences:set-default"
p value))
(check-callbacks p value)
(hash-set! preferences p value))]
[(not (pref-default-set? p))
(raise-unknown-preference-error
'preferences:set "tried to set the preference ~e to ~e, but no default is set"
p
value)]))
ps values)
((preferences:low-level-put-preferences)
(map add-pref-prefix ps)
(map (λ (p value) (marshall-pref p value))
ps
values))
(void))
(dynamic-wind
(λ ()
(call-pref-save-callbacks #t))
(λ ()
(for-each
(λ (p value)
(cond
[(pref-default-set? p)
(let ([default (hash-ref defaults p)])
(unless ((default-checker default) value)
(error 'preferences:set
"tried to set preference ~e to ~e but it does not meet test from `preferences:set-default'"
p value))
(check-callbacks p value)
(hash-set! preferences p value))]
[(not (pref-default-set? p))
(raise-unknown-preference-error
'preferences:set "tried to set the preference ~e to ~e, but no default is set"
p
value)]))
ps values)
((preferences:low-level-put-preferences)
(map add-pref-prefix ps)
(map (λ (p value) (marshall-pref p value))
ps
values))
(void))
(λ ()
(call-pref-save-callbacks #f))))
(define pref-save-callbacks '())
(define (preferences:register-save-callback f)
(define key (gensym))
(set! pref-save-callbacks (cons (list key f) pref-save-callbacks))
key)
(define (preferences:unregister-save-callback k)
(set! pref-save-callbacks
(let loop ([callbacks pref-save-callbacks])
(cond
[(null? callbacks) '()]
[else
(let ([cb (car callbacks)])
(if (eq? (list-ref cb 0) k)
(cdr callbacks)
(cons cb (loop (cdr callbacks)))))]))))
(define (call-pref-save-callbacks b)
(for ([cb (in-list pref-save-callbacks)])
((list-ref cb 1) b)))
(define (raise-unknown-preference-error sym fmt . args)
(raise (exn:make-unknown-preference
@ -244,7 +271,7 @@ the state transitions / contracts are:
(pref-can-init? p))
(let ([default-okay? (checker default-value)])
(unless default-okay?
(error 'set-default "~s: checker (~s) returns ~s for ~s, expected #t~n"
(error 'set-default "~s: checker (~s) returns ~s for ~s, expected #t\n"
p checker default-okay? default-value)))
(unless (= (length aliases) (length rewrite-aliases))
@ -378,7 +405,7 @@ the state transitions / contracts are:
#:rewrite-aliases (listof (-> any/c any)))
void?)
((symbol value test)
((aliases '()) (rewrite-aliases (map (lambda (x) (values)) aliases))))
((aliases '()) (rewrite-aliases (map (lambda (x) values) aliases))))
@{This function must be called every time your application starts up, before
any call to @scheme[preferences:get] or @scheme[preferences:set]
(for any given preference).
@ -407,13 +434,13 @@ the state transitions / contracts are:
preferences:set-un/marshall
(symbol? (any/c . -> . printable/c) (printable/c . -> . any/c) . -> . void?)
(symbol marshall unmarshall)
@{@scheme[preference:set-un/marshall] is used to specify marshalling and
@{@scheme[preferences:set-un/marshall] is used to specify marshalling and
unmarshalling functions for the preference
@scheme[symbol]. @scheme[marshall] will be called when the users saves their
preferences to turn the preference value for @scheme[symbol] into a
printable value. @scheme[unmarshall] will be called when the user's
preferences are read from the file to transform the printable value
into its internal representation. If @scheme[preference:set-un/marshall]
into its internal representation. If @scheme[preferences:set-un/marshall]
is never called for a particular preference, the values of that
preference are assumed to be printable.
@ -427,8 +454,11 @@ the state transitions / contracts are:
happen when the preferences file becomes corrupted, or is edited
by hand.
@scheme[preference:set-un/marshall] must be called before calling
@scheme[preferences:get],@scheme[preferences:set].})
@scheme[preferences:set-un/marshall] must be called before calling
@scheme[preferences:get],@scheme[preferences:set].
See also @racket[serialize] and @racket[deserialize].
})
(proc-doc/names
preferences:restore-defaults
@ -437,6 +467,24 @@ the state transitions / contracts are:
@{@scheme[(preferences:restore-defaults)] restores the users' configuration
to the default preferences.})
(proc-doc/names
preferences:register-save-callback
(-> (-> boolean? any) symbol?)
(callback)
@{Registers @racket[callback] to run twice for each call to @racket[preferences:set]---once
before the preferences file is written, with @racket[#t], and once after it is written, with
@racket[#f]. Registration returns a key for use with @racket[preferences:unregister-save-callback].
Caveats:
@itemize{@item{The callback occurs on whichever thread happened to call @racket[preferences:set].}
@item{Pre- and post-write notifications are not necessarily paired; unregistration
may cancel the post-write notification before it occurs.}}})
(proc-doc/names
preferences:unregister-save-callback
(-> symbol? void?)
(key)
@{Unregisters the save callback associated with @racket[key].})
(proc-doc/names
exn:make-unknown-preference
(string? continuation-mark-set? . -> . exn:unknown-preference?)

62
collects/framework/private/bday.rkt
View File

@ -1,32 +1,34 @@
#lang s-exp framework/private/decode
XY9BD
sIgEEWv
8pfMgqRV
E3Whn
qXtT
GOjg
AE08
fYWp
62Nu
897D
PMxjx
heAwtc
7G3Lzfs
CN4 d0m
4K0G giGp
R+8w JgC4
MA0w rvkk
XCTR 5GkC
56T Peux
e8Yo PtsJ
E5X7 jWeY
E74T 1gWf
ryiR 4OjH
y/tK Waem
1XMZ aIU9
ttXK LuXV
1hU2 x7WO
f75G vdLLj
9Xuc CD6A
\\\\ A==
TY+9Ds
IwDIT3P
MWN9hCJA
hIwAA
+CGN
rGFR
UkRW
lA4u
1JaF
K6ne
/zz1n
R0w/v
3gis73R
j6s8Zto
jxn oU0
k2Cl yEjX
OwFR cmBh
mBVA Dwmg
i6lD RKO0
gzOj Pk1l
+/Je XNDZ
Zr6m iThT
OwM6 glKb
toML NyTJ
sPz3 05XJ
jZd4 kaCE
iot+ UbDD
ZhUb Cp/f
yLxa YX1Y
8vnh zCug
WvD5 +7J/C
+wj/ \wI=;;

6
collects/framework/private/color-model.rkt
View File

@ -192,7 +192,7 @@
(,(xyz-z xyz-white))))])
(apply values (car (transpose sigmas)))))
;; (printf "should be equal to xyz-white: ~n~a~n"
;; (printf "should be equal to xyz-white: \n~a\n"
;; (matrix-multiply pre-matrix `((,sigma-r) (,sigma-g) (,sigma-b))))
(define rgb->xyz-matrix
@ -203,13 +203,13 @@
(define xyz->rgb-matrix
(matrix-invert rgb->xyz-matrix))
;;(printf "should be identity: ~n~a~n" (matrix-multiply rgb->xyz-matrix xyz->rgb-matrix))
;;(printf "should be identity: \n~a\n" (matrix-multiply rgb->xyz-matrix xyz->rgb-matrix))
(define (rgb->xyz r g b)
(apply make-xyz (car (transpose (matrix-multiply rgb->xyz-matrix (transpose `((,r ,g ,b))))))))
;;(print-struct #t)
;; (printf "should be xyz-white: ~n~a~n" (rgb->xyz 255 255 255))
;; (printf "should be xyz-white: \n~a\n" (rgb->xyz 255 255 255))
(define (xyz->rgb x y z)
(car (transpose (matrix-multiply xyz->rgb-matrix (transpose `((,x ,y ,z)))))))

40
collects/framework/private/color.rkt
View File

@ -286,7 +286,7 @@ added get-regions
(enable-suspend #t)))])
(unless (eq? 'eof type)
(enable-suspend #f)
#; (printf "~a at ~a to ~a~n" lexeme (+ in-start-pos (sub1 new-token-start))
#; (printf "~a at ~a to ~a\n" lexeme (+ in-start-pos (sub1 new-token-start))
(+ in-start-pos (sub1 new-token-end)))
(let ((len (- new-token-end new-token-start)))
(set-lexer-state-current-pos! ls (+ len (lexer-state-current-pos ls)))
@ -418,11 +418,11 @@ added get-regions
(define/private (colorer-driver)
(unless (andmap lexer-state-up-to-date? lexer-states)
#;(printf "revision ~a~n" (get-revision-number))
#;(printf "revision ~a\n" (get-revision-number))
(unless (and tok-cor (= rev (get-revision-number)))
(when tok-cor
(coroutine-kill tok-cor))
#;(printf "new coroutine~n")
#;(printf "new coroutine\n")
(set! tok-cor
(coroutine
(λ (enable-suspend)
@ -450,19 +450,19 @@ added get-regions
(format "exception in colorer thread: ~s" exn)
exn))
(set! tok-cor #f))))
#;(printf "begin lexing~n")
#;(printf "begin lexing\n")
(when (coroutine-run 10 tok-cor)
(for-each (lambda (ls)
(set-lexer-state-up-to-date?! ls #t))
lexer-states)))
#;(printf "end lexing~n")
#;(printf "begin coloring~n")
#;(printf "end lexing\n")
#;(printf "begin coloring\n")
;; This edit sequence needs to happen even when colors is null
;; for the paren highlighter.
(begin-edit-sequence #f #f)
(color)
(end-edit-sequence)
#;(printf "end coloring~n")))
#;(printf "end coloring\n")))
(define/private (colorer-callback)
(cond
@ -643,7 +643,7 @@ added get-regions
;; possible.
(define/private match-parens
(lambda ([just-clear? #f])
;;(printf "(match-parens ~a)~n" just-clear?)
;;(printf "(match-parens ~a)\n" just-clear?)
(when (and (not in-match-parens?)
;; Trying to match open parens while the
;; background thread is going slows it down.
@ -918,21 +918,21 @@ added get-regions
(let* ((x null)
(f (λ (a b c) (set! x (cons (list a b c) x)))))
(send (lexer-state-tokens ls) for-each f)
(printf "tokens: ~e~n" (reverse x))
(printf "tokens: ~.s\n" (reverse x))
(set! x null)
(send (lexer-state-invalid-tokens ls) for-each f)
(printf "invalid-tokens: ~e~n" (reverse x))
(printf "start-pos: ~a current-pos: ~a invalid-tokens-start ~a~n"
(printf "invalid-tokens: ~.s\n" (reverse x))
(printf "start-pos: ~a current-pos: ~a invalid-tokens-start ~a\n"
(lexer-state-start-pos ls)
(lexer-state-current-pos ls)
(lexer-state-invalid-tokens-start ls))
(printf "parens: ~e~n" (car (send (lexer-state-parens ls) test)))))
(printf "parens: ~.s\n" (car (send (lexer-state-parens ls) test)))))
lexer-states))
;; ------------------------- Callbacks to Override ----------------------
(define/override (lock x)
;;(printf "(lock ~a)~n" x)
;;(printf "(lock ~a)\n" x)
(super lock x)
(when (and restart-callback (not x))
(set! restart-callback #f)
@ -940,25 +940,25 @@ added get-regions
(define/override (on-focus on?)
;;(printf "(on-focus ~a)~n" on?)
;;(printf "(on-focus ~a)\n" on?)
(super on-focus on?)
(match-parens (not on?)))
(define/augment (after-edit-sequence)
;;(printf "(after-edit-sequence)~n")
;;(printf "(after-edit-sequence)\n")
(when (has-focus?)
(match-parens))
(inner (void) after-edit-sequence))
(define/augment (after-set-position)
;;(printf "(after-set-position)~n")
;;(printf "(after-set-position)\n")
(unless (local-edit-sequence?)
(when (has-focus?)
(match-parens)))
(inner (void) after-set-position))
(define/augment (after-change-style a b)
;;(printf "(after-change-style)~n")
;;(printf "(after-change-style)\n")
(unless (get-styles-fixed)
(unless (local-edit-sequence?)
(when (has-focus?)
@ -966,19 +966,19 @@ added get-regions
(inner (void) after-change-style a b))
(define/augment (on-set-size-constraint)
;;(printf "(on-set-size-constraint)~n")
;;(printf "(on-set-size-constraint)\n")
(unless (local-edit-sequence?)
(when (has-focus?)
(match-parens)))
(inner (void) on-set-size-constraint))
(define/augment (after-insert edit-start-pos change-length)
;;(printf "(after-insert ~a ~a)~n" edit-start-pos change-length)
;;(printf "(after-insert ~a ~a)\n" edit-start-pos change-length)
(do-insert/delete edit-start-pos change-length)
(inner (void) after-insert edit-start-pos change-length))
(define/augment (after-delete edit-start-pos change-length)
;;(printf "(after-delete ~a ~a)~n" edit-start-pos change-length)
;;(printf "(after-delete ~a ~a)\n" edit-start-pos change-length)
(do-insert/delete edit-start-pos (- change-length))
(inner (void) after-delete edit-start-pos change-length))

6
collects/framework/private/decode.rkt
View File

@ -1,6 +1,6 @@
#lang scheme/base
(require (for-syntax scheme/base file/gunzip net/base64))
(provide (except-out (all-from-out scheme/base) #%module-begin)
#lang racket/base
(require (for-syntax racket/base file/gunzip net/base64))
(provide (except-out (all-from-out racket/base) #%module-begin)
(rename-out [module-begin #%module-begin]))
(define-syntax (module-begin stx)

4
collects/framework/private/editor.rkt
View File

@ -242,10 +242,10 @@
(unless (and (procedure? t)
(= 0 (procedure-arity t)))
(error 'editor:basic::run-after-edit-sequence
"expected procedure of arity zero, got: ~s~n" t))
"expected procedure of arity zero, got: ~s\n" t))
(unless (or (symbol? sym) (not sym))
(error 'editor:basic::run-after-edit-sequence
"expected second argument to be a symbol or #f, got: ~s~n"
"expected second argument to be a symbol or #f, got: ~s\n"
sym))
(if (refresh-delayed?)
(if in-local-edit-sequence?

67
collects/framework/private/encode.rkt
View File

@ -1,43 +1,34 @@
#lang scheme/base
(require scheme/cmdline scheme/string scheme/match scheme/pretty
file/gzip file/gunzip net/base64)
#lang racket/base
(require racket/cmdline racket/string file/gzip file/gunzip net/base64)
(define (encode-exprs exprs)
(define in
(open-input-string
(string-join (map (lambda (x) (format "~s" x)) exprs) " ")))
(define out (open-output-bytes))
(deflate in out)
(base64-encode (get-output-bytes out)))
(define do-lang? #f)
(define (encode-module)
(define mod (parameterize ([read-accept-reader #t]) (read)))
(when (eof-object? mod) (error 'encode-module "missing module"))
(match mod
[(list 'module m 'scheme/base (list '#%module-begin exprs ...))
(write-bytes #"#lang s-exp framework/private/decode\n")
(write-bytes (regexp-replace* #rx"\r\n" (encode-exprs exprs) #"\n"))]
[else (error 'encode-module "cannot parse module, must use scheme/base")]))
(define (encode/decode-text who lang-from lang-to convert1 convert2)
(when do-lang?
(let ([l (cadr (or (regexp-match #rx"^ *#lang +(.*[^ ]) *$" (read-line))
(error who "missing #lang line")))])
(if (equal? l lang-from)
(printf "#lang ~a\n" lang-to)
(error who "bad #lang: expected ~s, got ~s" lang-from l))))
(define O (open-output-bytes))
(convert1 (current-input-port) O)
(convert2 (open-input-bytes (get-output-bytes O)) (current-output-port))
(flush-output))
(define (decode-module)
(define mod (parameterize ([read-accept-reader #t]) (read)))
(when (eof-object? mod) (error 'encode-module "missing module"))
(match mod
[(list 'module m 'framework/private/decode
(list '#%module-begin exprs ...))
(write-bytes #"#lang scheme/base\n")
(let* ([data (format "~a" exprs)]
[data (substring data 1 (sub1 (string-length data)))]
[data (string->bytes/utf-8 data)]
[in (open-input-bytes (base64-decode data))]
[out (open-output-string)]
[out (begin (inflate in out) (get-output-string out))]
[exprs (read (open-input-string (string-append "(" out ")")))])
(for ([expr (in-list exprs)])
(pretty-print expr)))]
[else (error 'decode-module "cannot parse module, must use scheme/base")]))
(define (encode-text)
(encode/decode-text
'encode-text "racket/base" "s-exp framework/private/decode"
deflate base64-encode-stream))
(command-line #:once-any
["-e" "encode" (encode-module) (exit)]
["-d" "decode" (decode-module) (exit)])
(define (decode-text)
(encode/decode-text
'decode-text "s-exp framework/private/decode" "racket/base"
base64-decode-stream inflate))
(command-line
#:once-each
["-l" "translate lang line" (set! do-lang? #t)]
#:once-any
["-e" "encode" (encode-text) (exit)]
["-d" "decode" (decode-text) (exit)])
(printf "Use `-h' for help\n")

101
collects/framework/private/frame.rkt
View File

@ -44,7 +44,8 @@
items))
(let* ([file-menu (find-menu (string-constant file-menu))]
[edit-menu (find-menu (string-constant edit-menu))]
[windows-menu (find-menu (string-constant windows-menu))]
[windows-menu (or (find-menu (string-constant windows-menu))
(find-menu (string-constant tabs-menu)))]
[help-menu (find-menu (string-constant help-menu))]
[other-items
(remq* (list file-menu edit-menu windows-menu help-menu) items)]
@ -212,10 +213,11 @@
(set-icon icon (send icon get-loaded-mask) 'both))))
(let ([mb (make-object (get-menu-bar%) this)])
(when (or (eq? (system-type) 'macos)
(eq? (system-type) 'macosx))
(make-object menu:can-restore-underscore-menu% (string-constant windows-menu-label)
mb)))
(make-object menu:can-restore-underscore-menu%
(case (system-type)
[(macosx) (string-constant windows-menu-label)]
[else (string-constant tabs-menu-label)])
mb))
(reorder-menus this)
@ -560,6 +562,7 @@
(λ (l)
(if (memq outer-info-panel l)
(begin (unregister-collecting-blit gc-canvas)
(unregister-pref-save-callback)
(list rest-panel))
l)))]
[else
@ -569,6 +572,7 @@
l
(begin
(register-gc-blit)
(register-pref-save-callback)
(list rest-panel outer-info-panel)))))]))
[define close-panel-callback
@ -580,6 +584,7 @@
(define/augment (on-close)
(unregister-collecting-blit gc-canvas)
(unregister-pref-save-callback)
(close-panel-callback)
(memory-cleanup)
(inner (void) on-close))
@ -637,6 +642,12 @@
[(<= n 99) (format "0~a" n)]
[else (number->string n)]))
(define pref-save-canvas #f)
(when checkout-or-nightly?
(set! pref-save-canvas (new pref-save-canvas% [parent (get-info-panel)])))
[define lock-canvas (make-object lock-canvas% (get-info-panel))]
; only for checkouts and nightly build users
(when show-memory-text?
(let* ([panel (new horizontal-panel%
@ -657,7 +668,6 @@
(set! memory-canvases (remq ec memory-canvases))))
(send panel stretchable-width #f)))
[define lock-canvas (make-object lock-canvas% (get-info-panel))]
[define gc-canvas (make-object bday-click-canvas% (get-info-panel) '(border))]
(define/private (register-gc-blit)
(let ([onb (icon:get-gc-on-bitmap)]
@ -670,6 +680,25 @@
(send onb get-height)
onb offb))))
(define pref-save-callback-registration #f)
(inherit get-eventspace)
(define/private (register-pref-save-callback)
(when pref-save-canvas
(set! pref-save-callback-registration
(preferences:register-save-callback
(λ (start?)
(cond
[(eq? (current-thread) (eventspace-handler-thread (get-eventspace)))
(send pref-save-canvas set-on? start?)]
[else
(queue-callback
(λ ()
(send pref-save-canvas set-on? start?)))]))))))
(define/private (unregister-pref-save-callback)
(when pref-save-callback-registration
(preferences:unregister-save-callback pref-save-callback-registration)))
(register-pref-save-callback)
(unless (preferences:get 'framework:show-status-line)
(send super-root change-children
(λ (l)
@ -732,7 +761,7 @@
(let-values ([(cw _4) (get-client-size)]
[(tw _1 _2 _3) (send dc get-text-extent str normal-control-font)])
(when (< cw tw)
(min-client-width (inexact->exact (floor tw)))))))
(min-client-width (inexact->exact (ceiling tw)))))))
(define/override (on-paint)
(let ([dc (get-dc)])
(send dc set-font normal-control-font)
@ -1693,15 +1722,22 @@
(define/augment (after-delete x y)
(update-prefs)
(inner (void) after-delete x y))
(define timer #f)
(define/private (update-prefs)
(preferences:set pref-sym
(let loop ([snip (find-first-snip)])
(cond
[(not snip) '()]
[(is-a? snip string-snip%)
(cons (send snip get-text 0 (send snip get-count))
(loop (send snip next)))]
[else (cons snip (loop (send snip next)))]))))
(unless timer
(set! timer (new timer%
[notify-callback
(λ ()
(preferences:set pref-sym
(let loop ([snip (find-first-snip)])
(cond
[(not snip) '()]
[(is-a? snip string-snip%)
(cons (send snip get-text 0 (send snip get-count))
(loop (send snip next)))]
[else (cons snip (loop (send snip next)))]))))])))
(send timer stop)
(send timer start 150 #t))
(define/override (get-keymaps)
(editor:add-after-user-keymap search/replace-keymap (super get-keymaps)))
(super-new)
@ -1807,7 +1843,7 @@
[bt (box 0)]
[bb (box 0)])
(send text get-visible-line-range bt bb #f)
(unless (<= (unbox bt) search-result-line (unbox bb))
(unless (< (unbox bt) search-result-line (unbox bb))
(let* ([half (sub1 (quotient (- (unbox bb) (unbox bt)) 2))]
[last-pos (send text position-line (send text last-position))]
[top-pos (send text line-start-position
@ -2408,14 +2444,16 @@
(define/override (get-editor%) (text:searching-mixin (super get-editor%)))
(super-new)))
(define memory-canvases '())
(define show-memory-text?
(define checkout-or-nightly?
(or (with-handlers ([exn:fail:filesystem? (λ (x) #f)])
(directory-exists? (collection-path "repo-time-stamp")))
(with-handlers ([exn:fail:filesystem? (λ (x) #f)])
(let ([fw (collection-path "framework")])
(directory-exists? (build-path fw 'up 'up ".git"))))))
(define memory-canvases '())
(define show-memory-text? checkout-or-nightly?)
(define bday-click-canvas%
(class canvas%
(define/override (on-event evt)
@ -2427,6 +2465,33 @@
[else (super on-event evt)]))
(super-new)))
(define pref-save-canvas%
(class canvas%
(define on? #f)
(define indicator "P")
(define/override (on-paint)
(cond
[on?
(let-values ([(cw ch) (get-client-size)])
(send (get-dc) draw-text indicator
(- (/ cw 2) (/ indicator-width 2))
(- (/ ch 2) (/ indicator-height 2))))]))
(define/public (set-on? new-on?)
(set! on? new-on?)
(send (get-dc) erase)
(on-paint)
(flush))
(inherit get-dc flush get-client-size min-width)
(super-new [stretchable-width #f]
[style '(transparent)])
(send (get-dc) set-font small-control-font)
(define-values (indicator-width indicator-height)
(let-values ([(tw th _1 _2) (send (get-dc) get-text-extent indicator)])
(values tw th)))
(min-width (+ (inexact->exact (ceiling indicator-width)) 4))))
(define basic% (register-group-mixin (basic-mixin frame%)))
(define size-pref% (size-pref-mixin basic%))
(define info% (info-mixin basic%))

4
collects/framework/private/gen-standard-menus.rkt
View File

@ -125,7 +125,7 @@
(write-docs))
(define (write-docs)
(printf "writing to ~a~n" docs-menus.ss-filename)
(printf "writing to ~a\n" docs-menus.ss-filename)
(call-with-output-file docs-menus.ss-filename
(λ (port)
(define (pop-out sexp)
@ -203,7 +203,7 @@
#:exists 'truncate))
(define (write-standard-menus.rkt)
(printf "writing to ~a~n" standard-menus.rkt-filename)
(printf "writing to ~a\n" standard-menus.rkt-filename)
(call-with-output-file standard-menus.rkt-filename
(λ (port)

60
collects/framework/private/group.rkt
View File

@ -30,6 +30,11 @@
(f menu)
(old menu)))))
(define windows-menu-label
(case (system-type)
[(macosx) (string-constant windows-menu-label)]
[else (string-constant tabs-menu-label)]))
(define %
(class object%
@ -47,8 +52,10 @@
(and menu-bar
(let ([menus (send menu-bar get-items)])
(ormap (λ (x)
(if (string=? (string-constant windows-menu)
(send x get-plain-label))
(if (or (string=? (string-constant windows-menu)
(send x get-plain-label))
(string=? (string-constant tabs-menu)
(send x get-plain-label)))
x
#f))
menus)))))
@ -105,33 +112,34 @@
[parent menu]
[callback (λ (x y)
(let ([frame (send (send menu get-parent) get-frame)])
(send frame maximize (not (send frame is-maximized?)))))]))
(instantiate menu:can-restore-menu-item% ()
(label (string-constant bring-frame-to-front...))
(parent menu)
(callback (λ (x y) (choose-a-frame (send (send menu get-parent) get-frame))))
(shortcut #\j))
(instantiate menu:can-restore-menu-item% ()
(label (string-constant most-recent-window))
(parent menu)
(callback (λ (x y) (most-recent-window-to-front)))
(shortcut #\'))
(make-object separator-menu-item% menu)
(send frame maximize (not (send frame is-maximized?)))))])
(instantiate menu:can-restore-menu-item% ()
(label (string-constant bring-frame-to-front...))
(parent menu)
(callback (λ (x y) (choose-a-frame (send (send menu get-parent) get-frame))))
(shortcut #\j))
(instantiate menu:can-restore-menu-item% ()
(label (string-constant most-recent-window))
(parent menu)
(callback (λ (x y) (most-recent-window-to-front)))
(shortcut #\'))
(make-object separator-menu-item% menu))
(extra-windows-menus-proc menu)
(for-each
(λ (frame)
(let ([frame (frame-frame frame)])
(make-object menu-item%
(regexp-replace*
#rx"&"
(gui-utils:trim-string (get-name frame) 200)
"&&")
menu
(λ (_1 _2)
(send frame show #t)))))
sorted/visible-frames))
(when (eq? (system-type) 'macosx)
(for-each
(λ (frame)
(let ([frame (frame-frame frame)])
(make-object menu-item%
(regexp-replace*
#rx"&"
(gui-utils:trim-string (get-name frame) 200)
"&&")
menu
(λ (_1 _2)
(send frame show #t)))))
sorted/visible-frames)))
windows-menus)))
;; most-recent-window-to-front : -> void?

48
collects/framework/private/handler.rkt
View File

@ -181,23 +181,43 @@
(let ([recently-opened-files
(preferences:get
'framework:recently-opened-files/pos)])
(for ([item (send menu get-items)]) (send item delete))
(for ([recent-list-item recently-opened-files])
(let ([filename (car recent-list-item)])
(unless (menu-items-still-same? recently-opened-files menu)
(for ([item (send menu get-items)]) (send item delete))
(for ([recent-list-item recently-opened-files])
(new menu-item%
[parent menu]
[label (gui-utils:trim-string
(regexp-replace* #rx"&" (path->string filename) "\\&\\&")
200)]
[callback (λ (x y) (open-recent-list-item recent-list-item))])))
(new separator-menu-item% [parent menu])
(new menu-item%
[parent menu]
[label (string-constant show-recent-items-window-menu-item)]
[callback (λ (x y) (show-recent-items-window))])
[parent menu]
[label (recent-list-item->menu-label recent-list-item)]
[callback (λ (x y) (open-recent-list-item recent-list-item))]))
(new separator-menu-item% [parent menu])
(new menu-item%
[parent menu]
[label (string-constant show-recent-items-window-menu-item)]
[callback (λ (x y) (show-recent-items-window))]))
(void)))
(define (recent-list-item->menu-label recent-list-item)
(let ([filename (car recent-list-item)])
(gui-utils:trim-string
(regexp-replace* #rx"&" (path->string filename) "\\&\\&")
200)))
;; this function must mimic what happens in install-recent-items
;; it returns #t if all of the labels of menus are the same, or approximation to
;; the menus actually being different
(define (menu-items-still-same? recently-opened-files menu)
(let ([current-items
(map (λ (x) (and (is-a? x labelled-menu-item<%>) (send x get-label)))
(send menu get-items))]
;; the new-items variable shoudl match up to what install-recent-items actually does when it creates the menu
[new-items
(append
(for/list ([recent-list-item recently-opened-files])
(recent-list-item->menu-label recent-list-item))
(list #f
(string-constant show-recent-items-window-menu-item)))])
(equal? current-items new-items)))
;; open-recent-list-item : recent-list-item -> void
(define (open-recent-list-item recent-list-item)
(let* ([filename (car recent-list-item)]

31
collects/framework/private/keymap.rkt
View File

@ -7,6 +7,7 @@
mzlib/match
"../preferences.ss"
mrlib/tex-table
(only-in srfi/13 string-prefix? string-prefix-length)
"sig.ss")
(import mred^
@ -984,17 +985,32 @@
[TeX-compress
(let* ([biggest (apply max (map (λ (x) (string-length (car x))) tex-shortcut-table))])
(define (meet s t)
(substring s 0 (string-prefix-length s t 0)))
(λ (text event)
(let ([pos (send text get-start-position)])
(when (= pos (send text get-end-position))
(let ([slash (send text find-string "\\" 'backward pos (max 0 (- pos biggest 1)))])
(when slash
(let ([to-replace (assoc (send text get-text slash pos) tex-shortcut-table)])
(when to-replace
(send text begin-edit-sequence)
(send text delete (- slash 1) pos)
(send text insert (cadr to-replace))
(send text end-edit-sequence)))))))))]
(define entered (send text get-text slash pos))
(define completions
(filter (λ (shortcut) (string-prefix? entered (first shortcut)))
tex-shortcut-table))
(unless (empty? completions)
(define-values (replacement partial?)
(let ([complete-match
(findf (λ (shortcut) (equal? entered (first shortcut)))
completions)])
(if complete-match
(values (second complete-match) #f)
(if (= 1 (length completions))
(values (second (first completions)) #f)
(let ([tex-names (map first completions)])
(values (foldl meet (first tex-names) (rest tex-names)) #t))))))
(send text begin-edit-sequence)
(send text delete (if partial? slash (- slash 1)) pos)
(send text insert replacement)
(send text end-edit-sequence))))))))]
[greek-letters "αβγδεζηθι κλμνξοπρςστυφχψω"]
[Greek-letters "ΑΒΓΔΕΖΗΘΙ ΚΛΜΝΞΟΠΡ ΣΤΥΦΧΨΩ"]) ;; don't have a capital ς, just comes out as \u03A2 (or junk)
@ -1214,7 +1230,8 @@
(map "del" "delete-key")
(map-meta "d" "kill-word")
(map-meta "del" "backward-kill-word")
(map-meta "del" "kill-word")
(map-meta "backspace" "backward-kill-word")
(map-meta "c" "capitalize-word")
(map-meta "u" "upcase-word")
(map-meta "l" "downcase-word")

11
collects/framework/private/main.rkt
View File

@ -76,7 +76,7 @@
'("local")
(λ (x) (and (list? x) (andmap string? x))))
(preferences:set-default 'framework:square-bracket:letrec
(let ([fors '("for" "for/list" "for/hash" "for/and" "for/or" "for/first" "for/last")])
(let ([fors '("for" "for/fold" "for/list" "for/hash" "for/and" "for/or" "for/first" "for/last")])
(append fors
(map (λ (x) (regexp-replace #rx"for" x "for*"))
fors)
@ -208,7 +208,10 @@
(let ([hash-table (make-hasheq)])
(for-each (λ (x)
(hash-set! hash-table x 'define))
'(struct local))
'(struct
local
define-type))
(for-each (λ (x)
(hash-set! hash-table x 'begin))
'(case-lambda
@ -261,9 +264,11 @@
parameterize
call-with-input-file call-with-input-file* with-input-from-file
with-input-from-port call-with-output-file
with-output-to-file with-output-to-port
with-output-to-file with-output-to-port
for-all
type-case
))
(preferences:set-default
'framework:tabify

25
collects/framework/private/panel.rkt
View File

@ -44,7 +44,7 @@
[(left top) 0]
[(right bottom) (- total-size item-size)]
[else (error 'place-children
"alignment spec is unknown ~a~n" spec)])))])
"alignment spec is unknown ~a\n" spec)])))])
(map (λ (l)
(let*-values ([(min-width min-height h-stretch? v-stretch?)
(apply values l)]
@ -182,9 +182,15 @@
(define dragable-mixin
(mixin (window<%> area-container<%>) (dragable<%>)
(init parent)
(define/public (get-vertical?)
(error 'get-vertical "abstract method"))
(init-field vertical?)
(define/public-final (get-vertical?) vertical?)
(define/public-final (set-orientation h?)
(define v? (not h?))
(unless (eq? vertical? v?)
(set! vertical? v?)
(container-flow-modified)))
(define/private (min-extent child)
(let-values ([(w h) (send child get-graphical-min-size)])
(if (get-vertical?)
@ -413,18 +419,15 @@
(stretchable-height #f)
(min-height 10)))
(define vertical-dragable-mixin
(mixin (dragable<%>) (vertical-dragable<%>)
(define/override (get-vertical?) #t)
(super-instantiate ())))
(super-new [vertical? #t])))
(define horizontal-dragable-mixin
(mixin (dragable<%>) (vertical-dragable<%>)
(define/override (get-vertical?) #f)
(super-instantiate ())))
(super-new [vertical? #f])))
(define vertical-dragable% (vertical-dragable-mixin (dragable-mixin vertical-panel%)))
(define vertical-dragable% (vertical-dragable-mixin (dragable-mixin panel%)))
(define horizontal-dragable% (horizontal-dragable-mixin (dragable-mixin horizontal-panel%)))
(define horizontal-dragable% (horizontal-dragable-mixin (dragable-mixin panel%)))

46
collects/framework/private/preferences.rkt
View File

@ -206,13 +206,14 @@ the state transitions / contracts are:
(define (make-preferences-dialog)
(letrec ([stashed-prefs (preferences:get-prefs-snapshot)]
[cancelled? #t]
[cancelled? #f]
[frame-stashed-prefs%
(class frame:basic%
(inherit close)
(define/override (on-subwindow-char receiver event)
(cond
[(eq? 'escape (send event get-key-code))
(set! cancelled? #t)
(close)]
[else
(super on-subwindow-char receiver event)]))
@ -222,7 +223,7 @@ the state transitions / contracts are:
(define/override (show on?)
(when on?
;; reset the flag and save new prefs when the window becomes visible
(set! cancelled? #t)
(set! cancelled? #f)
(set! stashed-prefs (preferences:get-prefs-snapshot)))
(super show on?))
(super-new))]
@ -280,9 +281,10 @@ the state transitions / contracts are:
(for-each
(λ (f) (f))
on-close-dialog-callbacks)
(set! cancelled? #f)
(send frame close)))]
[cancel-callback (λ () (send frame close))])
[cancel-callback (λ ()
(set! cancelled? #t)
(send frame close))])
(new button%
[label (string-constant revert-to-defaults)]
[callback
@ -293,7 +295,9 @@ the state transitions / contracts are:
(gui-utils:ok/cancel-buttons
bottom-panel
ok-callback
(λ (a b) (cancel-callback)))
(λ (a b) (cancel-callback))
(string-constant ok)
(string-constant undo-changes))
(make-object grow-box-spacer-pane% bottom-panel)
(send* bottom-panel
(stretchable-height #f)
@ -454,8 +458,10 @@ the state transitions / contracts are:
'framework:autosaving-on?
(string-constant auto-save-files)
values values)
(make-check editor-panel 'framework:backup-files? (string-constant backup-files) values values)
(make-check editor-panel 'framework:backup-files? (string-constant backup-files) values values)
(make-check editor-panel 'framework:show-status-line (string-constant show-status-line) values values)
;; does this not belong here?
;; (make-check editor-panel 'drracket:show-line-numbers (string-constant show-line-numbers)
(make-check editor-panel 'framework:col-offsets (string-constant count-columns-from-one) values values)
(make-check editor-panel
'framework:display-line-numbers
@ -528,18 +534,7 @@ the state transitions / contracts are:
(cond
[(string? default) string?]
[(number? default) number?]
[else (error 'internal-error.set-default "unrecognized default: ~a~n" default)]))
(preferences:add-callback
name
(λ (p new-value)
(write-resource
font-section
font-entry
(if (and (string? new-value)
(string=? font-default-string new-value))
""
new-value)
font-file))))))])
[else (error 'internal-error.set-default "unrecognized default: ~a\n" default)])))))])
(for-each (set-default build-font-entry font-default-string string?)
font-families)
@ -577,14 +572,7 @@ the state transitions / contracts are:
[message (make-object message%
(let ([b (box "")])
(if (and (get-resource
font-section
(build-font-entry name)
b)
(not (string=? (unbox b)
"")))
(unbox b)
font-default-string))
font-default-string)
horiz)]
[button
(make-object button%
@ -641,11 +629,7 @@ the state transitions / contracts are:
[size-panel (make-object horizontal-panel% main '(border))]
[initial-font-size
(let ([b (box 0)])
(if (get-resource font-section
font-size-entry
b)
(unbox b)
font-default-size))]
font-default-size)]
[size-slider
(make-object slider%
(string-constant font-size-slider-label)

80
collects/framework/private/scheme.rkt
View File

@ -10,7 +10,8 @@
"collapsed-snipclass-helpers.ss"
"sig.ss"
"../gui-utils.ss"
"../preferences.ss")
"../preferences.ss"
scheme/match)
(import mred^
[prefix preferences: framework:preferences^]
@ -43,13 +44,16 @@
(let* ([end (or in-end (send text last-position))]
[port (open-input-text-editor text start end)])
(with-handlers ([exn:fail:read:eof? (λ (x) #f)]
[exn:fail:read? (λ (x) #f)])
[exn:fail:read? (λ (x) #t)])
(let ([first (read port)])
(and (not (eof-object? first))
(let loop ()
(let ([s (read port)])
(or (eof-object? s)
(loop))))))))))
(cond
[(eof-object? first) #f]
[else
(let loop ()
(let ([s (read port)])
(cond
[(eof-object? s) #t]
[else (loop)])))]))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;;
@ -200,7 +204,8 @@
(let ([up-sexp (send text find-up-sexp click-pos)])
(when up-sexp
(let ([fwd (send text get-forward-sexp up-sexp)])
(make-collapse-item text up-sexp fwd menu))))]))))
(when fwd
(make-collapse-item text up-sexp fwd menu)))))]))))
;; make-expand-item : (instanceof text%) (instanceof sexp-snip<%>) (instanceof menu%) -> void
(define (make-expand-item text snip menu)
@ -316,10 +321,10 @@
(define (short-sym->style-name sym)
(hash-ref sn-hash sym
(λ ()
(let ([s (format "framework:syntax-color:scheme:~a"
(xlate-sym-style sym))])
(hash-set! sn-hash sym s)
s))))
(let ([s (format "framework:syntax-color:scheme:~a"
(xlate-sym-style sym))])
(hash-set! sn-hash sym s)
s))))
(define (add-coloring-preferences-panel)
(color-prefs:add-to-preferences-panel
@ -373,7 +378,8 @@
introduce-let-ans
move-sexp-out
kill-enclosing-parens))
kill-enclosing-parens
toggle-round-square-parens))
(define init-wordbreak-map
(λ (map)
@ -1051,16 +1057,43 @@
(let ([begin-outer (find-up-sexp begin-inner)])
(cond
[begin-outer
(let ([end-outer (get-forward-sexp begin-outer)])
(cond
[(and end-outer (> (- end-outer begin-outer) 2))
(delete (- end-outer 1) end-outer)
(delete begin-outer (+ begin-outer 1))
(tabify-selection begin-outer (- end-outer 2))]
[else (bell)]))]
(let ([end-outer (get-forward-sexp begin-outer)])
(cond
[(and end-outer (> (- end-outer begin-outer) 2))
(delete (- end-outer 1) end-outer)
(delete begin-outer (+ begin-outer 1))
(tabify-selection begin-outer (- end-outer 2))]
[else (bell)]))]
[else (bell)]))
(end-edit-sequence))
;; change the parens following the cursor from () to [] or vice versa
(define/public (toggle-round-square-parens start-pos)
(begin-edit-sequence)
(let* ([sexp-begin (skip-whitespace start-pos 'forward #f)]
[sexp-end (get-forward-sexp sexp-begin)])
(cond [(and sexp-end
(< (+ 1 sexp-begin) sexp-end))
;; positions known to exist: start-pos <= x < sexp-end
(match* ((get-character sexp-begin) (get-character (- sexp-end 1)))
[(#\( #\)) (replace-char-at-posn sexp-begin "[")
(replace-char-at-posn (- sexp-end 1) "]")]
[(#\[ #\]) (replace-char-at-posn sexp-begin "(")
(replace-char-at-posn (- sexp-end 1) ")")]
[(_ _) (bell)])]
[else (bell)]))
(end-edit-sequence))
;; replace-char-at-posn: natural-number string ->
;; replace the char at the given posn with the given string.
;;
;; this abstraction exists because the duplicated code in toggle-round-square-parens was
;; just a little too much for comfort
(define (replace-char-at-posn posn str)
;; insertions are performed before deletions in order to preserve the location of the cursor
(insert str (+ posn 1) (+ posn 1))
(delete posn (+ posn 1)))
(inherit get-fixed-style)
(define/public (mark-matching-parenthesis pos)
(let ([open-parens (map car (scheme-paren:get-paren-pairs))]
@ -1187,7 +1220,7 @@
(define/override (put-file text sup directory default-name)
(parameterize ([finder:default-extension "rkt"]
[finder:default-filters '(["Racket Sources" "*.rkt;*.ss;*.scm"]
[finder:default-filters '(["Racket Sources" "*.rkt;*.scrbl;*.ss;*.scm"]
["Any" "*.*"])])
;; don't call the surrogate's super, since it sets the default extension
(sup directory default-name)))
@ -1255,6 +1288,8 @@
(λ (e p) (send e move-sexp-out p)))
(add-pos-function "kill-enclosing-parens"
(lambda (e p) (send e kill-enclosing-parens p)))
(add-pos-function "toggle-round-square-parens"
(lambda (e p) (send e toggle-round-square-parens p)))
(let ([add-edit-function
(λ (name call-method)
@ -1381,7 +1416,8 @@
(send keymap map-function "c:c;c:b" "remove-parens-forward")
(send keymap map-function "c:c;c:l" "introduce-let-ans")
(send keymap map-function "c:c;c:o" "move-sexp-out")
(send keymap map-function "c:c;c:e" "kill-enclosing-parens")))
(send keymap map-function "c:c;c:e" "kill-enclosing-parens")
(send keymap map-function "c:c;c:[" "toggle-round-square-parens")))
(define keymap (make-object keymap:aug-keymap%))
(setup-keymap keymap)

2
collects/framework/private/sig.rkt
View File

@ -163,6 +163,7 @@
(define-signature text-class^
(basic<%>
first-line<%>
line-numbers<%>
foreground-color<%>
hide-caret/selection<%>
nbsp->space<%>
@ -199,6 +200,7 @@
basic-mixin
first-line-mixin
line-numbers-mixin
foreground-color-mixin
hide-caret/selection-mixin
nbsp->space-mixin

392
collects/framework/private/text.rkt
View File

@ -11,12 +11,13 @@ WARNING: printf is rebound in the body of the unit to always
scheme/class
scheme/match
scheme/path
"sig.ss"
"../gui-utils.ss"
"../preferences.ss"
"sig.rkt"
"../gui-utils.rkt"
"../preferences.rkt"
mred/mred-sig
mrlib/interactive-value-port
setup/dirs
racket/list
(prefix-in srfi1: srfi/1))
(require setup/xref
scribble/xref
@ -144,98 +145,45 @@ WARNING: printf is rebound in the body of the unit to always
(send (get-style-list) find-named-style "Standard"))
(define/private (invalidate-rectangles rectangles)
(let ([b1 (box 0)]
[b2 (box 0)]
[b3 (box 0)]
[b4 (box 0)]
[canvases (get-canvases)])
(let-values ([(min-left max-right)
(cond
[(null? canvases)
(let ([admin (get-admin)])
(if admin
(begin
(send admin get-view b1 b2 b3 b4)
(let* ([this-left (unbox b1)]
[this-width (unbox b3)]
[this-right (+ this-left this-width)])
(values this-left
this-right)))
(values #f #f)))]
[else
(let loop ([left #f]
[right #f]
[canvases canvases])
(cond
[(null? canvases)
(values left right)]
[else
(let-values ([(this-left this-right)
(send (car canvases)
call-as-primary-owner
(λ ()
(send (get-admin) get-view b1 b2 b3 b4)
(let* ([this-left (unbox b1)]
[this-width (unbox b3)]
[this-right (+ this-left this-width)])
(values this-left
this-right))))])
(if (and left right)
(loop (min this-left left)
(max this-right right)
(cdr canvases))
(loop this-left
this-right
(cdr canvases))))]))])])
(when (and min-left max-right)
(let loop ([left #f]
[top #f]
[right #f]
[bottom #f]
[rectangles rectangles]
[refresh? #f])
(cond
[(null? rectangles)
(when left
(let ([width (- right left)]
[height (- bottom top)])
(when refresh?
(for-each (λ (canvas) (send canvas refresh))
canvases))
(when (and (> width 0)
(> height 0))
(invalidate-bitmap-cache left top width height))))]
[else (let* ([r (car rectangles)]
[adjust (λ (w f)
(+ w (f (case (rectangle-style r)
[(dot hollow-ellipse) 8]
[else 0]))))]
[this-left (if (number? (rectangle-left r))
(adjust (rectangle-left r) -)
min-left)]
[this-right (if (number? (rectangle-right r))
(adjust (rectangle-right r) +)
max-right)]
[this-top (adjust (rectangle-top r) -)]
[this-bottom (adjust (rectangle-bottom r) +)])
(if (and left top right bottom)
(loop (min this-left left)
(min this-top top)
(max this-right right)
(max this-bottom bottom)
(cdr rectangles)
(or refresh?
(not (number? (rectangle-left r)))
(not (number? (rectangle-right r)))))
(loop this-left
this-top
this-right
this-bottom
(cdr rectangles)
(or refresh?
(not (number? (rectangle-left r)))
(not (number? (rectangle-right r)))))))]))))))
(let loop ([left #f]
[top #f]
[right #f]
[bottom #f]
[rectangles rectangles])
(cond
[(null? rectangles)
(when left
(let ([width (if (number? right) (- right left) 'display-end)]
[height (if (number? bottom) (- bottom top) 'display-end)])
(when (and (or (symbol? width) (> width 0))
(or (symbol? height) (> height 0)))
(invalidate-bitmap-cache left top width height))))]
[else (let* ([r (car rectangles)]
[adjust (λ (w f)
(+ w (f (case (rectangle-style r)
[(dot hollow-ellipse) 8]
[else 0]))))]
[this-left (if (number? (rectangle-left r))
(adjust (rectangle-left r) -)
0.0)]
[this-right (if (number? (rectangle-right r))
(adjust (rectangle-right r) +)
'display-end)]
[this-top (adjust (rectangle-top r) -)]
[this-bottom (adjust (rectangle-bottom r) +)])
(if (and left top right bottom)
(loop (min this-left left)
(min this-top top)
(if (and (number? this-right) (number? right))
(max this-right right)
'display-end)
(max this-bottom bottom)
(cdr rectangles))
(loop this-left
this-top
this-right
this-bottom
(cdr rectangles))))])))
(define/private (recompute-range-rectangles)
(let* ([b1 (box 0)]
@ -3749,3 +3697,257 @@ designates the character that triggers autocompletion
(define backup-autosave% (editor:backup-autosave-mixin clever-file-format%))
(define searching% (searching-mixin backup-autosave%))
(define info% (info-mixin (editor:info-mixin searching%)))
;; ============================================================
;; line number text%
(define line-numbers<%>
(interface ()
show-line-numbers!
showing-line-numbers?
set-line-numbers-color))
;; draws line numbers on the left hand side of a text% object
(define line-numbers-mixin
(mixin ((class->interface text%)) (line-numbers<%>)
(super-new)
(inherit get-visible-line-range
get-visible-position-range
last-line
line-location
line-paragraph
line-start-position
line-end-position)
(init-field [line-numbers-color "black"])
(init-field [show-line-numbers? #t])
;; whether the numbers are aligned on the left or right
;; only two values should be 'left or 'right
(init-field [alignment 'right])
(define (number-space)
(number->string (max (* 10 (add1 (last-line))) 100)))
;; add an extra 0 so it looks nice
(define (number-space+1) (string-append (number-space) "0"))
(define cached-snips (list))
(define need-to-recalculate-snips #f)
;; call this method with #t or #f to turn on/off line numbers
(define/public (show-line-numbers! what)
(set! show-line-numbers? what))
(define/public (showing-line-numbers?)
show-line-numbers?)
(define/public (set-line-numbers-color color)
(set! line-numbers-color color))
(define (get-style-font)
(let* ([style-list (send this get-style-list)]
[std (or (send style-list find-named-style "Standard")
#t
#;
(send style-list basic-style))])
(send std get-font)))
;; a <= b <= c
(define (between low what high)
(and (>= what low)
(<= what high)))
(define-struct saved-dc-state (pen font foreground-color))
(define (save-dc-state dc)
(saved-dc-state (send dc get-pen)
(send dc get-font)
(send dc get-text-foreground)))
(define (restore-dc-state dc dc-state)
(send dc set-pen (saved-dc-state-pen dc-state))
(send dc set-font (saved-dc-state-font dc-state))
(send dc set-text-foreground (saved-dc-state-foreground-color dc-state)))
;; set the dc stuff to values we want
(define (setup-dc dc)
(send dc set-pen "black" 1 'solid)
(send dc set-font (get-style-font))
(send dc set-text-foreground (make-object color% line-numbers-color)))
(define (lighter-color color)
(define (integer number)
(inexact->exact (round number)))
;; hue 0-360
;; saturation 0-1
;; lightness 0-1
;; returns rgb as float values with ranges 0-1
(define (hsl->rgb hue saturation lightness)
(define (helper x a b)
(define x* (cond
[(< x 0) (+ x 1)]
[(> x 1) (- x 1)]
[else x]))
(cond
[(< (* x 6) 1) (+ b (* 6 (- a b) x))]
[(< (* x 6) 3) a]
[(< (* x 6) 4) (+ b (* (- a b) (- 4 (* 6 x))))]
[else b]))
(define h (/ hue 360))
(define a (if (< lightness 0.5)
(+ lightness (* lightness saturation))
(- (+ lightness saturation) (* lightness saturation))))
(define b (- (* lightness 2) a))
(define red (helper (+ h (/ 1.0 3)) a b))
(define green (helper h a b))
(define blue (helper (- h (/ 1.0 3)) a b))
(values red green blue))
;; red 0-255
;; green 0-255
;; blue 0-255
(define (rgb->hsl red green blue)
(define-values (a b c d)
(if (> red green)
(if (> red blue)
(if (> green blue)
(values red (- green blue) blue 0)
(values red (- green blue) green 0))
(values blue (- red green) green 4))
(if (> red blue)
(values green (- blue red) blue 2)
(if (> green blue)
(values green (- blue red) red 2)
(values blue (- red green) red 4)))))
(define hue (if (= a c) 0
(let ([x (* 60 (+ d (/ b (- a c))))])
(if (< x 0) (+ x 360) x))))
(define saturation (cond
[(= a c) 0]
[(< (+ a c) 1) (/ (- a c) (+ a c))]
[else (/ (- a c) (- 2 a c))]))
(define lightness (/ (+ a c) 2))
(values hue saturation lightness))
(define-values (hue saturation lightness)
(rgb->hsl (send color red)
(send color green)
(send color blue)))
(define-values (red green blue)
(hsl->rgb hue saturation (+ 0.5 lightness)))
(make-object color% (min 255 (integer (* 255 red)))
(min 255 (integer (* 255 green)))
(min 255 (integer (* 255 blue)))))
(define (draw-numbers dc top bottom dx dy start-line end-line)
(define (draw-text . args)
(send/apply dc draw-text args))
(define right-space (text-width dc (number-space)))
(define single-space (text-width dc "0"))
(define last-paragraph #f)
(for ([line (in-range start-line end-line)])
(define y (line-location line))
(when (between top y bottom)
(define view (number->string (add1 (line-paragraph line))))
(define final-x
(+ dx
(case alignment
[(left) 0]
[(right) (- right-space (text-width dc view) single-space)]
[else 0])))
(define final-y (+ dy y))
(if (and last-paragraph (= last-paragraph (line-paragraph line)))
(begin
(send dc set-text-foreground (lighter-color (send dc get-text-foreground)))
(draw-text view final-x final-y)
(send dc set-text-foreground (make-object color% line-numbers-color)))
(draw-text view final-x final-y)))
(set! last-paragraph (line-paragraph line))))
;; draw the line between the line numbers and the actual text
(define (draw-separator dc top bottom dx dy x)
(send dc draw-line (+ dx x) (+ dy top) (+ dx x) (+ dy bottom)))
;; `line-numbers-space' will get mutated in the `on-paint' method
(define line-numbers-space 0)
(define/override (find-position x y . args)
;; adjust x position to account for line numbers
(if show-line-numbers?
(super find-position (- x line-numbers-space) y . args)
(super find-position x y . args)))
(define (draw-line-numbers dc left top right bottom dx dy)
(define saved-dc (save-dc-state dc))
(setup-dc dc)
(define start-line (box 0))
(define end-line (box 0))
(get-visible-line-range start-line end-line #f)
;; draw it!
(draw-numbers dc top bottom dx dy (unbox start-line) (add1 (unbox end-line)))
(draw-separator dc top bottom dx dy (text-width dc (number-space)))
(restore-dc-state dc saved-dc))
(define (text-width dc stuff)
(define-values (font-width font-height baseline space)
(send dc get-text-extent stuff))
font-width)
(define (text-height dc stuff)
(define-values (font-width height baseline space)
(send dc get-text-extent stuff))
height)
(define old-origin-x 0)
(define old-origin-y 0)
(define old-clipping #f)
(define/override (on-paint before? dc left top right bottom dx dy draw-caret)
(when show-line-numbers?
(if before?
(let ()
;; FIXME: Moving the origin and setting the clipping rectangle
;; will probably go away when 'margin's are added to editors
;;
;; save old origin and push it to the right a little bit
;; TODO: maybe allow the line numbers to be drawn on the right hand side
;; of the editor?
(define-values (x y) (send dc get-origin))
(set! old-origin-x x)
(set! old-origin-y y)
(set! old-clipping (send dc get-clipping-region))
(define saved-dc (save-dc-state dc))
(setup-dc dc)
(define-values (font-width font-height baseline space)
(send dc get-text-extent (number-space)))
(restore-dc-state dc saved-dc)
(define clipped (make-object region% dc))
(define all (make-object region% dc))
(define copy (make-object region% dc))
(send all set-rectangle
(+ dx left) (+ dy top)
(- right left) (- bottom top))
(if old-clipping
(send copy union old-clipping)
(send copy union all))
(send clipped set-rectangle
0 (+ dy top)
(text-width dc (number-space+1))
(- bottom top))
#;
(define (print-region name region)
(define-values (a b c d) (send region get-bounding-box))
(printf "~a: ~a, ~a, ~a, ~a\n" name a b c d))
(send copy subtract clipped)
(send dc set-clipping-region copy)
(send dc set-origin (+ x (text-width dc (number-space+1))) y)
(set! line-numbers-space (text-width dc (number-space+1)))
)
(begin
;; rest the origin and draw the line numbers
(send dc set-origin old-origin-x old-origin-y)
(send dc set-clipping-region old-clipping)
(draw-line-numbers dc left top right bottom dx dy))))
(super on-paint before? dc left top right bottom dx dy draw-caret))
))

45
collects/framework/splash.rkt
View File

@ -14,7 +14,7 @@
shutdown-splash
close-splash
add-splash-icon
set-splash-progress-bar?
set-splash-progress-bar?!
set-splash-char-observer
set-splash-event-callback
get-splash-event-callback
@ -72,8 +72,8 @@
(splash-paint-callback dc)]
[else
(splash-paint-callback dc
(send gauge get-value)
(send gauge get-range)
(send (get-gauge) get-value)
(send (get-gauge) get-range)
(get-splash-width)
(get-splash-height))])
(for-each (λ (icon)
@ -86,9 +86,9 @@
(send (icon-bm icon) get-loaded-mask)))
icons))
(define (set-splash-progress-bar? b?)
(define (set-splash-progress-bar?! b?)
(send gauge-panel change-children
(λ (l) (if b? (list gauge) '()))))
(λ (l) (if b? (list (get-gauge)) '()))))
(define (splash-paint-callback dc)
(if splash-bitmap
@ -107,10 +107,11 @@
(set! icons (cons (make-icon bm x y) icons))
(refresh-splash))
(define (start-splash splash-draw-spec _splash-title width-default)
(define (start-splash splash-draw-spec _splash-title width-default #:allow-funny? [allow-funny? #f])
(unless allow-funny? (set! funny? #f))
(set! splash-title _splash-title)
(set! splash-max-width (max 1 (splash-get-preference (get-splash-width-preference-name) width-default)))
(send gauge set-range splash-max-width)
(send (get-gauge) set-range splash-max-width)
(send splash-tlw set-label splash-title)
(let/ec k
(define (no-splash)
@ -123,12 +124,12 @@
[(or (path? splash-draw-spec)
(string? splash-draw-spec))
(unless (file-exists? splash-draw-spec)
(fprintf (current-error-port) "WARNING: bitmap path ~s not found~n" splash-draw-spec)
(fprintf (current-error-port) "WARNING: bitmap path ~s not found\n" splash-draw-spec)
(no-splash))
(set! splash-bitmap (make-object bitmap% splash-draw-spec))
(unless (send splash-bitmap ok?)
(fprintf (current-error-port) "WARNING: bad bitmap ~s~n" splash-draw-spec)
(fprintf (current-error-port) "WARNING: bad bitmap ~s\n" splash-draw-spec)
(no-splash))
(send splash-canvas min-width (send splash-bitmap get-width))
@ -156,6 +157,7 @@
(refresh-splash)
(send splash-tlw center 'both)
(thread (λ () (send splash-tlw show #t)))
(sync (system-idle-evt)) ; try to wait for dialog to be shown
(flush-display) (yield) (sleep)
(flush-display) (yield) (sleep)))
@ -188,8 +190,8 @@
(define (splash-load-handler old-load f expected)
(set! splash-current-width (+ splash-current-width 1))
(when (<= splash-current-width splash-max-width)
(send gauge set-value splash-current-width)
(when (or (not (member gauge (send gauge-panel get-children)))
(send (get-gauge) set-value splash-current-width)
(when (or (not (member (get-gauge) (send gauge-panel get-children)))
;; when the gauge is not visible, we'll redraw the canvas
(refresh-splash-on-gauge-change? splash-current-width splash-max-width))
(refresh-splash)))
@ -218,7 +220,9 @@
(equal? (getenv "PLTDRDEBUG") "trace"))
(printf "PLTDRCM/PLTDRDEBUG: reinstalling CM trace handler after setting splash load handler\n")
(manager-trace-handler
(λ (x) (display "2: ") (display x) (newline))))))
(λ (x)
(when (regexp-match #rx"compiling" x)
(display "2: ") (display x) (newline)))))))
(define funny-gauge%
(class canvas%
@ -226,7 +230,7 @@
(field
[funny-value 0]
[funny-bitmap
(make-object bitmap% (build-path (collection-path "icons") "touch.bmp"))]
(make-object bitmap% (collection-file-path "touch.bmp" "icons"))]
[max-value 1])
(define/public (get-range) max-value)
@ -284,7 +288,7 @@
(define/augment (on-close)
(when quit-on-close?
(exit)))
(super-new)))
(super-new [style '(close-button)])))
(define splash-canvas%
(class canvas%
@ -303,10 +307,15 @@
(define panel (make-object vertical-pane% splash-tlw))
(define splash-canvas (new splash-canvas% [parent panel] [style '(no-autoclear)]))
(define gauge-panel (make-object horizontal-pane% panel))
(define gauge
(if funny?
(make-object funny-gauge% gauge-panel)
(make-object gauge% #f splash-max-width gauge-panel '(horizontal))))
(define get-gauge
(let ([gauge #f])
(λ ()
(unless gauge
(set! gauge
(if funny?
(make-object funny-gauge% gauge-panel)
(make-object gauge% #f splash-max-width gauge-panel '(horizontal)))))
gauge)))
(send panel stretchable-width #f)
(send panel stretchable-height #f)
(send gauge-panel set-alignment 'center 'top)

5
collects/framework/test.rkt
View File

@ -363,7 +363,7 @@
(loop (- n 1))))])))]
[(number? state)
(unless (send rb is-enabled? state)
(error 'test:set-radio-box! "item ~a is not enabled~n" state))
(error 'test:set-radio-box! "item ~a is not enabled\n" state))
(send rb set-selection state)]
[else (error 'test:set-radio-box!
"expected a string or a number as second arg, got: ~e (other arg: ~e)"
@ -466,7 +466,8 @@
'noalt 'nocontrol 'nometa 'noshift))
(define valid-key-symbols
(list 'start 'cancel 'clear 'shift 'control 'menu 'pause 'capital
(list 'escape ;; just trying this for the heck of it -- JBC, 2010-08-13
'start 'cancel 'clear 'shift 'control 'menu 'pause 'capital
'prior 'next 'end 'home 'left 'up 'right 'down 'select 'print
'execute 'snapshot 'insert 'help 'numpad0 'numpad1 'numpad2
'numpad3 'numpad4 'numpad5 'numpad6 'numpad7 'numpad8 'numpad9

14
collects/mred/mred-sig.rkt
View File

@ -1,4 +1,3 @@
#lang scheme/signature
add-color<%>
@ -38,8 +37,6 @@ control<%>
current-eventspace
current-eventspace-has-menu-root?
current-eventspace-has-standard-menus?
current-ps-afm-file-paths
current-ps-cmap-file-paths
current-ps-setup
current-text-keymap-initializer
cursor%
@ -91,7 +88,8 @@ get-font-from-user
get-page-setup-from-user
get-panel-background
get-ps-setup-from-user
get-resource
get-highlight-background-color
get-highlight-text-color
get-text-from-user
get-the-editor-data-class-list
get-the-snip-class-list
@ -117,9 +115,13 @@ label->plain-label
labelled-menu-item<%>
list-box%
list-control<%>
make-bitmap
make-eventspace
make-gl-bitmap
make-gui-empty-namespace
make-gui-namespace
make-monochrome-bitmap
make-screen-bitmap
map-command-as-meta-key
menu%
menu-bar%
@ -141,6 +143,7 @@ open-output-text-editor
pane%
panel%
pasteboard%
pdf-dc%
pen%
pen-list%
play-sound
@ -153,6 +156,7 @@ put-file
queue-callback
radio-box%
readable-snip<%>
read-bitmap
read-editor-global-footer
read-editor-global-header
read-editor-version
@ -160,7 +164,6 @@ region%
register-collecting-blit
scroll-event%
selectable-menu-item<%>
send-event
send-message-to-window
separator-menu-item%
sleep/yield
@ -203,5 +206,4 @@ window<%>
write-editor-global-footer
write-editor-global-header
write-editor-version
write-resource
yield

82
collects/mred/mred.rkt
View File

@ -4,6 +4,7 @@
namespace-anchor->empty-namespace
make-base-empty-namespace)
scheme/class
racket/draw
mzlib/etc
(prefix wx: "private/kernel.ss")
(prefix wx: "private/wxme/style.ss")
@ -38,24 +39,10 @@
"private/gdi.ss"
"private/snipfile.ss"
"private/repl.ss"
"private/afm.ss"
"private/helper.ss"
"private/dynamic.ss"
"private/check.ss")
;; Initialize AFM/PS:
(wx:set-ps-procs
afm-draw-text
afm-get-text-extent
afm-expand-name
afm-glyph-exists?
afm-record-font
afm-fonts-string)
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(wx:set-dialogs get-file put-file get-ps-setup-from-user message-box)
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; These functions are re-implemented in scheme/gui/base
;; and racket/gui/base to attach those names, instead of
@ -115,34 +102,23 @@
add-pasteboard-keymap-functions
begin-busy-cursor
bell
bitmap%
brush%
brush-list%
editor-data%
editor-data-class%
editor-data-class-list<%>
check-for-break
clipboard<%>
clipboard-client%
color%
color-database<%>
control-event%
current-eventspace
current-ps-setup
cursor%
dc<%>
dc-path%
get-display-depth
end-busy-cursor
event%
event-dispatch-handler
eventspace?
find-graphical-system-path
flush-display
font%
font-list%
font-name-directory<%>
get-resource
get-highlight-background-color
get-highlight-text-color
get-the-editor-data-class-list
get-the-snip-class-list
image-snip%
@ -162,14 +138,9 @@
editor-wordbreak-map%
mouse-event%
mult-color<%>
pen%
pen-list%
point%
ps-setup%
read-editor-global-footer
read-editor-global-header
read-editor-version
region%
scroll-event%
snip%
snip-admin%
@ -187,24 +158,32 @@
write-editor-global-footer
write-editor-global-header
write-editor-version
write-resource
queue-callback
yield
eventspace-shutdown?
get-panel-background
send-event
gl-context<%>
gl-config%)
(define the-color-database (wx:get-the-color-database))
(define the-font-name-directory (wx:get-the-font-name-directory))
the-style-list
the-editor-wordbreak-map
make-screen-bitmap
make-gl-bitmap)
(define the-clipboard (wx:get-the-clipboard))
(define the-x-selection-clipboard (wx:get-the-x-selection))
(define the-font-list (wx:get-the-font-list))
(define the-pen-list (wx:get-the-pen-list))
(define the-brush-list (wx:get-the-brush-list))
(define the-style-list wx:the-style-list)
(define the-editor-wordbreak-map wx:the-editor-wordbreak-map)
(define (find-graphical-system-path what)
(unless (memq what '(init-file x-display))
(raise-type-error 'find-graphical-system-path "'init-file or 'x-display" what))
(or (wx:find-graphical-system-path what)
(case what
[(init-file)
(build-path (find-system-path 'init-dir)
(case (system-type)
[(windows) "gracketrc.rktl"]
[else ".gracketrc"]))]
[else #f])))
(provide (all-from racket/draw))
(provide button%
canvas%
@ -276,29 +255,19 @@
get-display-left-top-inset
get-color-from-user
get-font-from-user
append-editor-operation-menu-items
append-editor-operation-menu-items
append-editor-font-menu-items
get-top-level-focus-window
get-top-level-edit-target-window
register-collecting-blit
unregister-collecting-blit
bitmap-dc%
post-script-dc%
printer-dc%
current-text-keymap-initializer
sleep/yield
get-window-text-extent
get-family-builtin-face
send-message-to-window
the-clipboard
the-x-selection-clipboard
the-editor-wordbreak-map
the-brush-list
the-color-database
the-font-name-directory
the-pen-list
the-font-list
the-style-list
normal-control-font
small-control-font
tiny-control-font
@ -321,9 +290,8 @@
make-gui-namespace
make-gui-empty-namespace
file-creator-and-type
current-ps-afm-file-paths
current-ps-cmap-file-paths
hide-cursor-until-moved
system-position-ok-before-cancel?
label-string?
key-code-symbol?))
key-code-symbol?
find-graphical-system-path))

54
collects/mred/private/app.rkt
View File

@ -1,6 +1,6 @@
(module app mzscheme
(require mzlib/class
(prefix wx: "kernel.ss")
(module app racket/base
(require racket/class
(prefix-in wx: "kernel.ss")
"lock.ss"
"helper.ss"
"wx.ss"
@ -42,14 +42,15 @@
(dynamic-wind
void
(lambda ()
(send af on-exit)
(as-exit (lambda ()
(send af on-exit)))
(unless (null? (wx:get-top-level-windows))
(wx:cancel-quit)))
(lambda ()
(set! running-quit? #f)))))))))))])
(wx:application-quit-handler (make-app-handler f f)))
(define (set-handler! who proc param arity result-filter)
(define (set-handler! who proc param arity result-filter post-set)
(when proc
(unless (and (procedure? proc)
(procedure-arity-includes? proc arity))
@ -58,13 +59,14 @@
proc)))
(let ([e (wx:current-eventspace)])
(when (wx:main-eventspace? e)
(param (make-app-handler
(param (make-app-handler
(lambda args
(parameterize ([wx:current-eventspace e])
(wx:queue-callback
(lambda () (result-filter (apply proc args)))
wx:middle-queue-key)))
proc)))))
proc))
(post-set))))
(define application-preferences-handler
(case-lambda
@ -74,7 +76,8 @@
(set-handler! 'application-preferences-handler proc
wx:application-pref-handler
0
values)]))
values
void)]))
(define application-about-handler
(case-lambda
@ -85,7 +88,8 @@
(set-handler! 'application-about-handler proc
wx:application-about-handler
0
values)]))
values
void)]))
(define application-quit-handler
(case-lambda
@ -96,18 +100,33 @@
(set-handler! 'application-quit-handler proc
wx:application-quit-handler
0
(lambda (v) (unless v (wx:cancel-quit)) v))]))
(lambda (v) (unless v (wx:cancel-quit)) v)
void)]))
(define saved-files null)
(define default-application-file-handler
(entry-point
(lambda (f)
(let ([af (weak-box-value active-main-frame)])
(when af
(queue-window-callback
af
(entry-point
(lambda () (when (send af accept-drag?)
(send af on-drop-file f))))))))))
(if af
(queue-window-callback
af
(entry-point
(lambda () (if (send af accept-drag?)
(send af on-drop-file f)
(set! saved-files (cons f saved-files))))))
(set! saved-files (cons f saved-files)))))))
(define (requeue-saved-files)
(as-entry
(lambda ()
(for-each (lambda (f)
(wx:queue-callback (lambda ()
((wx:application-file-handler) f))
wx:middle-queue-key))
(reverse saved-files))
(set! saved-files null))))
(define (install-defh)
(wx:application-file-handler (make-app-handler
@ -128,7 +147,8 @@
(set-handler! 'application-file-handler proc
wx:application-file-handler
1
values))]))
values
requeue-saved-files))]))
(define (current-eventspace-has-standard-menus?)

2
collects/mred/private/check.rkt
View File

@ -107,7 +107,7 @@
(define check-margin-integer (check-bounded-integer 0 1000 #f))
(define check-gauge-integer (check-bounded-integer 1 10000 #f))
(define check-gauge-integer (check-bounded-integer 1 1000000 #f))
(define (check-wheel-step cwho wheel-step)
(when (and wheel-step

10
collects/mred/private/const.rkt
View File

@ -60,11 +60,11 @@
(define black-color (make-object wx:color% 0 0 0))
(define disabled-color (make-object wx:color% 150 150 150))
(define trans-pen (send (wx:get-the-pen-list) find-or-create-pen "white" 0 'transparent))
(define light-pen (send (wx:get-the-pen-list) find-or-create-pen (scale-color bg-color #e1.35) 0 'solid))
(define border-pen (send (wx:get-the-pen-list) find-or-create-pen (scale-color bg-color #e0.85) 0 'solid))
(define dark-pen (send (wx:get-the-pen-list) find-or-create-pen (scale-color bg-color #e0.6) 0 'solid))
(define dark-brush (send (wx:get-the-brush-list) find-or-create-brush (scale-color bg-color #e0.8) 'solid))
(define trans-pen (send wx:the-pen-list find-or-create-pen "white" 0 'transparent))
(define light-pen (send wx:the-pen-list find-or-create-pen (scale-color bg-color #e1.35) 0 'solid))
(define border-pen (send wx:the-pen-list find-or-create-pen (scale-color bg-color #e0.85) 0 'solid))
(define dark-pen (send wx:the-pen-list find-or-create-pen (scale-color bg-color #e0.6) 0 'solid))
(define dark-brush (send wx:the-brush-list find-or-create-brush (scale-color bg-color #e0.8) 'solid))
(define wx-tab-group<%> (interface ()))
(define wx-group-box<%> (interface ()))

2
collects/mred/private/dynamic.rkt
View File

@ -6,6 +6,4 @@
(provide kernel-initialized)
(dynamic-require ''#%mred-kernel #f)
(define kernel-initialized 'done)

46
collects/mred/private/filedialog.rkt
View File

@ -17,17 +17,6 @@
put-file
get-directory)
(define (files->list s)
(let ([s (open-input-bytes s)])
(let loop ()
(let ([n (read s)])
(if (eof-object? n)
null
(begin
(read-byte s) ; drop space
(cons (read-bytes n s)
(loop))))))))
(define (mk-file-selector who put? multi? dir?)
(lambda (message parent directory filename extension style filters)
;; Calls from C++ have wrong kind of window:
@ -52,7 +41,7 @@
(raise-type-error who "list of 2-string lists" filters))
(let* ([std? (memq 'common style)]
[style (if std? (remq 'common style) style)])
(if (or std? (eq? (system-type) 'unix))
(if std?
(send (new path-dialog%
[put? put?]
[dir? dir?]
@ -66,23 +55,22 @@
[dir? #f]
[else filters])])
run)
(let ([s (wx:file-selector
message directory filename extension
;; file types:
(apply string-append
(map (lambda (s) (format "~a|~a|" (car s) (cadr s)))
filters))
;; style:
(cons (cond [dir? 'dir]
[put? 'put]
[multi? 'multi]
[else 'get])
style)
;; parent:
(and parent (mred->wx parent)))])
(if (and multi? s)
(map bytes->path (files->list (path->bytes s)))
s))))))
(wx:file-selector
message directory filename extension
;; file types:
filters
#;
(apply string-append
(map (lambda (s) (format "~a|~a|" (car s) (cadr s)))
filters))
;; style:
(cons (cond [dir? 'dir]
[put? 'put]
[multi? 'multi]
[else 'get])
style)
;; parent:
(and parent (mred->wx parent)))))))
(define default-filters '(("Any" "*.*")))

10
collects/mred/private/fontdialog.rkt
View File

@ -39,7 +39,7 @@
(let ([s (send (send edit get-style-list) find-named-style "Standard")])
(send s set-delta (font->delta f))))))]
[p (make-object horizontal-pane% f)]
[face (make-object list-box% #f (get-face-list) p refresh-sample)]
[face (make-object list-box% #f (wx:get-face-list) p refresh-sample)]
[p2 (make-object vertical-pane% p)]
[p3 (instantiate horizontal-pane% (p2) [stretchable-width #f])]
[style (let ([pnl (instantiate group-box-panel% ("Style" p3) [stretchable-height #f] [stretchable-width #f])])
@ -52,7 +52,9 @@
[sip (make-object check-box% "Size in Pixels" p4 refresh-sample)]
[sym (make-object check-box% "Map as Symbol" p4 refresh-sample)]
[size (make-object slider% "Size:" 4 127 p2 refresh-sample 12)]
[sample (make-object text-field% "Sample" f void "The quick brown fox jumped over the lazy dog" '(multiple))]
[sample (make-object text-field% "Sample" f void
"The quick brown fox jumped over the lazy dog\n(\u3bb (x) x)\n"
'(multiple))]
[edit (send sample get-editor)]
[done (lambda (ok) (lambda (b e) (set! ok? ok) (send f show #f)))]
[get-font (lambda () (let ([face (send face get-string-selection)])
@ -71,7 +73,7 @@
[(3) 'unsmoothed])
(send sip get-value)))))]
[bp (instantiate horizontal-pane% (f) [stretchable-height #f])]
[ms-button (if (eq? (system-type) 'windows)
[ms-button (if (eq? (wx:font-from-user-platform-mode) 'dialog)
(begin0
(make-object button% "Use System Dialog..." bp
(lambda (b e)
@ -96,7 +98,7 @@
(lambda (font)
(let* ([facen (if font
(send font get-face)
(get-family-builtin-face 'default))]
(wx:get-family-builtin-face 'default))]
[f (and facen (send face find-string facen))])
(and f (>= f 0) (send face set-selection f)))
(when font

182
collects/mred/private/gdi.rkt
View File

@ -6,22 +6,20 @@
"lock.ss"
"check.ss"
"wx.ss"
"te.rkt"
"mrtop.ss"
"mrcanvas.ss")
"mrcanvas.ss"
"syntax.rkt")
(provide register-collecting-blit
unregister-collecting-blit
bitmap-dc%
post-script-dc%
printer-dc%
get-window-text-extent
get-family-builtin-face
normal-control-font
small-control-font
tiny-control-font
view-control-font
menu-control-font
get-face-list)
menu-control-font)
(define register-collecting-blit
(case-lambda
@ -31,6 +29,16 @@
[(canvas x y w h on off on-x on-y off-x) (register-collecting-blit canvas x y w h on off on-x on-y off-x 0)]
[(canvas x y w h on off on-x on-y off-x off-y)
(check-instance 'register-collecting-blit canvas% 'canvas% #f canvas)
((check-bounded-integer -10000 10000 #f) 'register-collecting-blit x)
((check-bounded-integer -10000 10000 #f) 'register-collecting-blit y)
((check-bounded-integer 0 10000 #f) 'register-collecting-blit w)
((check-bounded-integer 0 10000 #f) 'register-collecting-blit h)
(check-instance 'register-collecting-blit wx:bitmap% 'bitmap% #f on)
(check-instance 'register-collecting-blit wx:bitmap% 'bitmap% #f off)
((check-bounded-integer -10000 10000 #f) 'register-collecting-blit on-x)
((check-bounded-integer -10000 10000 #f) 'register-collecting-blit on-y)
((check-bounded-integer -10000 10000 #f) 'register-collecting-blit off-x)
((check-bounded-integer -10000 10000 #f) 'register-collecting-blit off-y)
(wx:register-collecting-blit (mred->wx canvas) x y w h on off on-x on-y off-x off-y)]))
(define unregister-collecting-blit
@ -38,14 +46,6 @@
(check-instance 'unregister-collecting-blit canvas% 'canvas% #f canvas)
(wx:unregister-collecting-blit (mred->wx canvas))))
(define bitmap-dc%
(class100 wx:bitmap-dc% ([bitmap #f])
(inherit set-bitmap)
(sequence
(super-init)
(when bitmap
(set-bitmap bitmap)))))
(define-syntax check-page-active
(syntax-rules ()
[(_ check-page-status (id . args) ...) (begin (check-one-page-active check-page-status id args) ...)]))
@ -155,20 +155,6 @@
(super-new)))
(define post-script-dc%
(class (doc+page-check-mixin wx:post-script-dc% 'post-script-dc%)
(init [interactive #t][parent #f][use-paper-bbox #f][as-eps #t])
(check-top-level-parent/false '(constructor post-script-dc) parent)
(define is-eps? (and as-eps #t))
(define/override (multiple-pages-ok?) (not is-eps?))
(as-entry
(lambda ()
(let ([p (and parent (mred->wx parent))])
(as-exit (lambda () (super-make-object interactive p use-paper-bbox as-eps))))))))
(define printer-dc%
(class100 (doc+page-check-mixin wx:printer-dc% 'printer-dc%) ([parent #f])
(sequence
@ -179,119 +165,14 @@
(as-exit (lambda () (super-init p)))))))))
(define get-window-text-extent
(let ([bm #f][dc #f])
(case-lambda
[(string font) (get-window-text-extent string font #f)]
[(string font combine?)
(check-string 'get-window-text-extent string)
(check-instance 'get-window-text-extent wx:font% 'font% #f font)
(unless bm
(set! bm (make-object wx:bitmap% 2 2))
(set! dc (make-object wx:bitmap-dc%))
(send dc set-bitmap bm))
(unless (send bm ok?)
(error 'get-window-text-extent "couldn't allocate sizing bitmap"))
(let-values ([(w h d a) (send dc get-text-extent string font combine?)])
(values (inexact->exact w) (inexact->exact h)))])))
(define ugly?
(lambda (a)
(and (positive? (string-length a))
(not (or (char-alphabetic? (string-ref a 0))
(char-numeric? (string-ref a 0))
(char=? #\- (string-ref a 0)))))))
(define compare-face-names
(lambda (a b)
(let ([a-sp? (char=? #\space (string-ref a 0))]
[b-sp? (char=? #\space (string-ref b 0))]
[a-ugly? (ugly? a)]
[b-ugly? (ugly? b)])
(cond [(eq? a-sp? b-sp?)
(cond
[(eq? a-ugly? b-ugly?)
(string-locale-ci<? a b)]
[else b-ugly?])]
[else a-sp?]))))
(define get-face-list
(case-lambda
[() (get-face-list 'all)]
[(a) (sort (wx:get-face-list a) compare-face-names)]))
(define x-has-xft? 'unknown)
(define mswin-system #f)
(define mswin-default #f)
(define (look-for-font name)
(if (ormap (lambda (n) (string-ci=? name n)) (wx:get-face-list))
name
"MS San Serif"))
(define (get-family-builtin-face family)
(unless (memq family '(default decorative roman script swiss modern system symbol))
(raise-type-error 'get-family-builtin-face "family symbol" family))
(case (system-type)
[(unix)
;; Detect Xft by looking for a font with a space in front of its name:
(when (eq? x-has-xft? 'unknown)
(set! x-has-xft? (ormap (lambda (s) (regexp-match #rx"^ " s)) (wx:get-face-list))))
(if x-has-xft?
(case family
[(system) " Sans"]
[(default) " Sans"]
[(roman) " Serif"]
[(decorative) " Nimbus Sans L"]
[(modern) " Monospace"]
[(swiss) " Nimbus Sans L"]
[(script) " URW Chancery L"]
[(symbol) " Standard Symbols L,Nimbus Sans L"])
(case family
[(system) "-b&h-lucida"]
[(default) "-b&h-lucida"]
[(roman) "-adobe-times"]
[(decorative) "-adobe-helvetica"]
[(modern) "-adobe-courier"]
[(swiss) "-b&h-lucida"]
[(script) "-itc-zapfchancery"]
[(symbol) "-adobe-symbol"]))]
[(windows)
(case family
[(system)
(unless mswin-system
(set! mswin-system (look-for-font "Tahoma")))
mswin-system]
[(default)
(unless mswin-default
(set! mswin-default (look-for-font "Microsoft Sans Serif")))
mswin-default]
[(default) "MS Sans Serif"]
[(roman) "Times New Roman"]
[(decorative) "Arial"]
[(modern) "Courier New"]
[(swiss) "Arial"]
[(script) "Arial"]
[(symbol) "Symbol"])]
[(macos)
(case family
[(system) "systemfont"]
[(default) "applicationfont"]
[(roman) "Times"]
[(decorative) "Geneva"]
[(modern) "Monaco"]
[(swiss) "Helvetica"]
[(script) "Zaph Chancery"]
[(symbol) "Symbol"])]
[(macosx)
(case family
[(system) "systemfont"]
[(default) "applicationfont"]
[(roman) "Times"]
[(decorative) "Arial"]
[(modern) "Courier New"]
[(swiss) "Helvetica"]
[(script) "Apple Chancery"]
[(symbol) "Symbol"])]))
[(string font)
(get-window-text-extent string font #f)]
[(string font combine?)
(check-string 'get-window-text-extent string)
(check-instance 'get-window-text-extent wx:font% 'font% #f font)
(let-values ([(w h d a) (get-window-text-extent* string font combine?)])
(values (inexact->exact (ceiling w)) (inexact->exact (ceiling h))))]))
(define small-delta (case (system-type)
[(windows) 0]
@ -301,12 +182,23 @@
[(windows) 1]
[else 2]))
(define normal-control-font (make-object wx:font% (wx:get-control-font-size) 'system))
(define small-control-font (make-object wx:font% (- (wx:get-control-font-size) small-delta) 'system))
(define tiny-control-font (make-object wx:font% (- (wx:get-control-font-size) tiny-delta small-delta) 'system))
(define normal-control-font (make-object wx:font% (wx:get-control-font-size)
(wx:get-control-font-face) 'system
'normal 'normal #f 'default
(wx:get-control-font-size-in-pixels?)))
(define small-control-font (make-object wx:font% (- (wx:get-control-font-size) small-delta)
(wx:get-control-font-face) 'system
'normal 'normal #f 'default
(wx:get-control-font-size-in-pixels?)))
(define tiny-control-font (make-object wx:font% (- (wx:get-control-font-size) tiny-delta small-delta)
(wx:get-control-font-face) 'system
'normal 'normal #f 'default
(wx:get-control-font-size-in-pixels?)))
(define view-control-font (if (eq? 'macosx (system-type))
(make-object wx:font% (- (wx:get-control-font-size) 1) 'system)
(make-object wx:font% (- (wx:get-control-font-size) 1)
(wx:get-control-font-face) 'system)
normal-control-font))
(define menu-control-font (if (eq? 'macosx (system-type))
(make-object wx:font% (+ (wx:get-control-font-size) 1) 'system)
(make-object wx:font% (+ (wx:get-control-font-size) 1)
(wx:get-control-font-face) 'system)
normal-control-font)))

797
collects/mred/private/kernel.rkt
View File

@ -1,759 +1,44 @@
#lang racket/base
(require "wx/platform.rkt"
"wx/common/event.rkt"
"wx/common/timer.rkt"
"wx/common/queue.rkt"
"wx/common/clipboard.rkt"
"wx/common/cursor.rkt"
"wx/common/procs.rkt"
"wx/common/handlers.rkt"
racket/class
racket/draw)
;; The parts of kernel.ss are generated by xctocc.
;; kernel.ss is generated by a target in <builddir>/mred/wxs/Makefile.
(define (key-symbol-to-integer k)
(error 'key-symbol-to-integer "not yet implemented"))
(module kernel mzscheme
(require (all-except mzlib/class object%))
(provide (all-from-out "wx/platform.rkt")
clipboard<%>
(all-from-out "wx/common/event.rkt"
"wx/common/timer.rkt"
"wx/common/clipboard.rkt"
"wx/common/cursor.rkt"
"wx/common/procs.rkt")
(all-from-out racket/draw)
;; Pull pieces out of #%mred-kernel dynamically, so that
;; the library compiles with setup-plt in mzscheme.
(define kernel:initialize-primitive-object
(dynamic-require ''#%mred-kernel 'initialize-primitive-object))
(define kernel:primitive-class-find-method
(dynamic-require ''#%mred-kernel 'primitive-class-find-method))
(define kernel:primitive-class-prepare-struct-type!
(dynamic-require ''#%mred-kernel 'primitive-class-prepare-struct-type!))
(define-syntax define-constant
(lambda (stx)
(syntax-case stx ()
[(_ name)
(with-syntax ([kernel:name (datum->syntax-object
(syntax name)
(string->symbol
(format
"kernel:~a"
(syntax-e (syntax name))))
#f)])
(syntax
(begin
(define kernel:name (dynamic-require ''#%mred-kernel 'name))
(provide (protect (rename kernel:name name))))))])))
(define-syntax define-function
(lambda (stx)
(syntax-case stx ()
[(_ name)
(syntax (define-constant name))])))
(define-syntax define-functions
(lambda (stx)
(syntax-case stx ()
[(_ name ...)
(syntax (begin (define-function name) ...))])))
(define-syntax define-a-class
(let ([defined null])
(lambda (stx)
(syntax-case stx ()
[(_ name print-name super (intf ...) args id ...)
(let ([nm (syntax-e (syntax name))]
[sn (syntax-e (syntax super))]
[ids (map syntax-e (syntax->list (syntax (id ...))))])
;; find superclass
(let ([sup (assoc sn defined)])
(unless (or sup (not sn))
(raise-syntax-error
'class
"class not yet defined"
stx
(syntax super)))
;; add this class to the list:
(set! defined (cons (cons nm (append (if sup
(cdr sup)
null)
ids))
defined))
(let-values ([(old new)
(let loop ([l ids][o null][n null])
(cond
[(null? l) (values o n)]
[(memq (car l) (cdr sup))
(loop (cdr l) (cons (car l) o) n)]
[else
(loop (cdr l) o (cons (car l) n))]))])
(with-syntax ([(old ...) (datum->syntax-object #f old #f)]
[(new ...) (datum->syntax-object #f new #f)])
(syntax
(define name (let ([c (dynamic-require ''#%mred-kernel 'name)])
(make-primitive-class
(lambda (class prop:object preparer dispatcher prop:unwrap unwrapper more-props)
(kernel:primitive-class-prepare-struct-type!
c prop:object class preparer dispatcher prop:unwrap unwrapper more-props))
kernel:initialize-primitive-object
'print-name super (list intf ...) 'args
'(old ...)
'(new ...)
(list
(kernel:primitive-class-find-method c 'old)
...)
(list
(kernel:primitive-class-find-method c 'new)
...)))))))))]))))
(define-syntax define-class
(lambda (stx)
(syntax-case stx ()
[(_ name super args id ...)
(syntax
(begin
(define-a-class name name super args id ...)
(provide (protect name))))])))
(define-syntax define-private-class
(lambda (stx)
(syntax-case stx ()
[(_ name intf super args id ...)
(syntax
(begin
(define-a-class name intf super args id ...)
(define intf (class->interface name))
(provide (protect intf))))])))
(define-class object% #f () #f)
(define-class window% object% () #f
on-drop-file
pre-on-event
pre-on-char
on-size
on-set-focus
on-kill-focus
get-handle
is-enabled-to-root?
is-shown-to-root?
set-phantom-size
get-y
get-x
get-width
get-height
popup-menu
center
get-text-extent
get-parent
refresh
screen-to-client
client-to-screen
drag-accept-files
enable
get-position
get-client-size
get-size
fit
is-shown?
show
set-cursor
move
set-size
set-focus
gets-focus?
centre)
(define-class item% window% () #f
set-label
get-label
command)
(define-class message% item% () #f
get-font
set-label
on-drop-file
pre-on-event
pre-on-char
on-size
on-set-focus
on-kill-focus)
(define-class bitmap% object% () #f
get-argb-pixels
get-gl-config
set-gl-config
set-loaded-mask
get-loaded-mask
save-file
load-file
is-color?
ok?
get-width
get-height
get-depth)
(define-class button% item% () #f
set-border
set-label
on-drop-file
pre-on-event
pre-on-char
on-size
on-set-focus
on-kill-focus)
(define-class choice% item% () #f
set-selection
get-selection
number
clear
append
on-drop-file
pre-on-event
pre-on-char
on-size
on-set-focus
on-kill-focus)
(define-function set-combo-box-font)
(define-class check-box% item% () #f
set-label
set-value
get-value
on-drop-file
pre-on-event
pre-on-char
on-size
on-set-focus
on-kill-focus)
(define-class canvas% window% () #f
on-drop-file
pre-on-event
pre-on-char
on-size
on-set-focus
on-kill-focus
get-canvas-background
set-canvas-background
set-background-to-gray
on-scroll
set-scroll-page
set-scroll-range
set-scroll-pos
get-scroll-page
get-scroll-range
get-scroll-pos
scroll
warp-pointer
view-start
set-resize-corner
show-scrollbars
set-scrollbars
get-virtual-size
get-dc
on-char
on-event
on-paint)
(define-private-class dc% dc<%> object% () #f
cache-font-metrics-key
get-alpha
set-alpha
glyph-exists?
end-page
end-doc
start-page
start-doc
ok?
get-gl-context
get-size
get-text-foreground
get-text-background
get-pen
get-font
get-brush
get-text-mode
get-background
get-origin
get-scale
set-origin
set-scale
set-text-mode
try-color
draw-bitmap
draw-bitmap-section
get-char-width
get-char-height
get-text-extent
get-smoothing
set-smoothing
set-text-foreground
set-text-background
set-brush
set-pen
set-font
set-background
get-clipping-region
set-clipping-region
set-clipping-rect
draw-polygon
draw-lines
draw-path
draw-ellipse
draw-arc
draw-text
draw-spline
draw-rounded-rectangle
draw-rectangle
draw-point
draw-line
clear)
(define-function draw-tab)
(define-function draw-tab-base)
(define-class bitmap-dc% dc% () ()
get-bitmap
set-bitmap
draw-bitmap-section-smooth
set-argb-pixels
get-argb-pixels
set-pixel
get-pixel)
(define-class post-script-dc% dc% () ([interactive #t] [parent #f] [use-paper-bbox #f] [eps #t]))
(define-class printer-dc% dc% () ([parent #f]))
(define-private-class gl-context% gl-context<%> object% () #f
call-as-current
swap-buffers
ok?)
(define-class gl-config% object% () #f
get-double-buffered
set-double-buffered
get-stereo
set-stereo
get-stencil-size
set-stencil-size
get-accum-size
set-accum-size
get-depth-size
set-depth-size
get-multisample-size
set-multisample-size)
(define-class event% object% () ([time-stamp 0])
get-time-stamp
set-time-stamp)
(define-class control-event% event% () (event-type [time-stamp 0])
get-event-type
set-event-type)
(define-class popup-event% control-event% () #f
get-menu-id
set-menu-id)
(define-class scroll-event% event% () ([event-type thumb] [direction vertical] [position 0] [time-stamp 0])
get-event-type
set-event-type
get-direction
set-direction
get-position
set-position)
(define-class key-event% event% () ([key-code #\nul] [shift-down #f] [control-down #f] [meta-down #f] [alt-down #f] [x 0] [y 0] [time-stamp 0] [caps-down #f])
set-other-caps-key-code
get-other-caps-key-code
set-other-shift-altgr-key-code
get-other-shift-altgr-key-code
set-other-altgr-key-code
get-other-altgr-key-code
set-other-shift-key-code
get-other-shift-key-code
get-key-code
set-key-code
get-key-release-code
set-key-release-code
get-shift-down
set-shift-down
get-control-down
set-control-down
get-meta-down
set-meta-down
get-alt-down
set-alt-down
get-caps-down
set-caps-down
get-x
set-x
get-y
set-y)
(define-function key-symbol-to-integer)
(define-class mouse-event% event% () (event-type [left-down #f] [middle-down #f] [right-down #f] [x 0] [y 0] [shift-down #f] [control-down #f] [meta-down #f] [alt-down #f] [time-stamp 0] [caps-down #f])
moving?
leaving?
entering?
dragging?
button-up?
button-down?
button-changed?
get-event-type
set-event-type
get-left-down
set-left-down
get-middle-down
set-middle-down
get-right-down
set-right-down
get-shift-down
set-shift-down
get-control-down
set-control-down
get-meta-down
set-meta-down
get-alt-down
set-alt-down
get-caps-down
set-caps-down
get-x
set-x
get-y
set-y)
(define-class frame% window% () #f
on-drop-file
pre-on-event
pre-on-char
on-size
on-set-focus
on-kill-focus
on-toolbar-click
on-menu-click
on-menu-command
on-mdi-activate
enforce-size
on-close
on-activate
designate-root-frame
system-menu
set-modified
create-status-line
is-maximized?
maximize
status-line-exists?
iconized?
set-status-text
get-menu-bar
set-menu-bar
set-icon
iconize
set-title)
(define-class gauge% item% () #f
get-value
set-value
get-range
set-range
on-drop-file
pre-on-event
pre-on-char
on-size
on-set-focus
on-kill-focus)
(define-class font% object% () #f
screen-glyph-exists?
get-font-id
get-size-in-pixels
get-underlined
get-smoothing
get-weight
get-point-size
get-style
get-face
get-family)
(define-class font-list% object% () #f
find-or-create-font)
(define-class color% object% () #f
blue
green
red
set
ok?
copy-from)
(define-private-class color-database% color-database<%> object% () #f
find-color)
(define-class point% object% () #f
get-x
set-x
get-y
set-y)
(define-class brush% object% () #f
set-style
get-style
set-stipple
get-stipple
set-color
get-color)
(define-class brush-list% object% () #f
find-or-create-brush)
(define-class pen% object% () #f
set-style
get-style
set-stipple
get-stipple
set-color
get-color
set-join
get-join
set-cap
get-cap
set-width
get-width)
(define-class pen-list% object% () #f
find-or-create-pen)
(define-class cursor% object% () #f
ok?)
(define-class region% object% () (dc)
in-region?
is-empty?
get-bounding-box
xor
subtract
intersect
union
set-path
set-arc
set-polygon
set-ellipse
set-rounded-rectangle
set-rectangle
get-dc)
(define-class dc-path% object% () #f
get-bounding-box
append
reverse
rotate
scale
translate
lines
ellipse
rounded-rectangle
rectangle
curve-to
arc
line-to
move-to
open?
close
reset)
(define-private-class font-name-directory% font-name-directory<%> object% () #f
find-family-default-font-id
find-or-create-font-id
get-family
get-face-name
get-font-id
set-post-script-name
set-screen-name
get-post-script-name
get-screen-name)
(define-function get-control-font-size)
(define-function get-the-font-name-directory)
(define-function get-the-font-list)
(define-function get-the-pen-list)
(define-function get-the-brush-list)
(define-function get-the-color-database)
(define-function cancel-quit)
(define-function fill-private-color)
(define-function flush-display)
(define-function yield)
(define-function write-resource)
(define-function get-resource)
(define-function label->plain-label)
(define-function display-origin)
(define-function display-size)
(define-function bell)
(define-function hide-cursor)
(define-function end-busy-cursor)
(define-function is-busy?)
(define-function begin-busy-cursor)
(define-function get-display-depth)
(define-function is-color-display?)
(define-function file-selector)
(define-class list-box% item% () #f
get-label-font
set-string
set-first-visible-item
set
get-selections
get-first-item
number-of-visible-items
number
get-selection
set-data
get-data
selected?
set-selection
select
delete
clear
append
on-drop-file
pre-on-event
pre-on-char
on-size
on-set-focus
on-kill-focus)
(define-class menu% object% () #f
select
get-font
set-width
set-title
set-label
set-help-string
number
enable
check
checked?
append-separator
delete-by-position
delete
append)
(define-class menu-bar% object% () #f
set-label-top
number
enable-top
delete
append)
(define-class menu-item% object% () #f
id)
(define-function id-to-menu-item)
(define-class timer% object% () ()
stop
start
notify
interval)
(define-private-class clipboard% clipboard<%> object% () #f
same-clipboard-client?
get-clipboard-bitmap
set-clipboard-bitmap
get-clipboard-data
get-clipboard-string
set-clipboard-string
set-clipboard-client)
(define-function get-the-x-selection)
(define-function get-the-clipboard)
(define-class clipboard-client% object% () ()
same-eventspace?
get-types
add-type
get-data
on-replaced)
(define-class ps-setup% object% () ()
copy-from
set-margin
set-editor-margin
set-level-2
set-paper-name
set-translation
set-scaling
set-orientation
set-mode
set-preview-command
set-file
set-command
get-margin
get-editor-margin
get-level-2
get-paper-name
get-translation
get-scaling
get-orientation
get-mode
get-preview-command
get-file
get-command)
(define-function show-print-setup)
(define-function can-show-print-setup?)
(define-class panel% window% () #f
get-label-position
set-label-position
on-char
on-event
on-paint
on-drop-file
pre-on-event
pre-on-char
on-size
on-set-focus
on-kill-focus
set-item-cursor
get-item-cursor)
(define-class dialog% window% () #f
system-menu
set-title
on-drop-file
pre-on-event
pre-on-char
on-size
on-set-focus
on-kill-focus
enforce-size
on-close
on-activate)
(define-class radio-box% item% () #f
button-focus
enable
set-selection
number
get-selection
on-drop-file
pre-on-event
pre-on-char
on-size
on-set-focus
on-kill-focus)
(define-class slider% item% () #f
set-value
get-value
on-drop-file
pre-on-event
pre-on-char
on-size
on-set-focus
on-kill-focus)
(define-class tab-group% item% () #f
button-focus
set
set-label
delete
append
enable
set-selection
number
get-selection
on-drop-file
pre-on-event
pre-on-char
on-size
on-set-focus
on-kill-focus)
(define-class group-box% item% () #f
on-drop-file
pre-on-event
pre-on-char
on-size
on-set-focus
on-kill-focus)
;; Functions defined in wxscheme.cxx
(define-functions
special-control-key
special-option-key
application-file-handler
application-quit-handler
application-about-handler
application-pref-handler
get-color-from-user
get-font-from-user
get-face-list
get-panel-background
play-sound
make-eventspace
current-eventspace
event-dispatch-handler
eventspace?
current-ps-setup
queue-callback
middle-queue-key
check-for-break
find-graphical-system-path
get-top-level-windows
register-collecting-blit
unregister-collecting-blit
shortcut-visible-in-label?
eventspace-shutdown?
in-atomic-region
set-menu-tester
location->window
set-dialogs
set-executer
send-event
file-creator-and-type
set-ps-procs
main-eventspace?
eventspace-handler-thread
begin-refresh-sequence
end-refresh-sequence
run-printout
get-double-click-time)
)
;; end
eventspace?
current-eventspace
queue-event
yield
make-eventspace
event-dispatch-handler
eventspace-shutdown?
main-eventspace?
eventspace-handler-thread
queue-callback
middle-queue-key
get-top-level-windows
begin-busy-cursor
is-busy?
end-busy-cursor
key-symbol-to-integer
application-file-handler
application-quit-handler
application-about-handler
application-pref-handler)

186
collects/mred/private/lock.rkt
View File

@ -1,131 +1,69 @@
(module lock mzscheme
(require (prefix wx: "kernel.ss"))
(provide (protect as-entry
as-exit
entry-point
mk-param))
#lang racket/base
(require (for-syntax racket/base)
ffi/unsafe/atomic)
;; ;;;;;;;;;;;;; Thread Safety ;;;;;;;;;;;;;;;;;;;;
;; When the user creates an object or calls a method, or when the
;; system invokes a callback, many steps may be required to initialize
;; or reset fields to maintain invariants. To ensure that other
;; threads do not call methods during a time when invariants do not
;; hold, we force all of the following code to be executed in a single
;; threaded manner, and we temporarily disable breaks. This accompiled
;; with a single monitor: all entry points into the code use
;; `entry-point' or `as-entry', and all points with this code that
;; call back out to user code uses `as-exit'.
(provide (protect-out as-entry ;; alias for call-as-atomic
as-exit ;; alias for call-as-nonatomic
atomically ;; assumes no exceptions!
entry-point ;; converts a proc body to use as-entry
mk-param)) ;; parameter pattern --- out of place here
;; If an exception is raised within an `enter'ed area, control is
;; moved back outside by the exception handler, and then the exception
;; is re-raised. The user can't tell that the exception was caught an
;; re-raised. But without the catch-and-reraise, the user's exception
;; handler might try to use GUI elements from a different thread,
;; leading to deadlock.
;; We need atomic mode for a couple of reasons:
;;
;; * We may need to bracket some (trusted) operations so that the
;; queue thread doesn't poll for events during the operation.
;; The `atomically' form is ok for that if no exceptions will
;; be raised. Otherwise, use the more heavyweight `as-entry'.
;;
;; * The scheme/gui classes have internal-consistency requirements.
;; When the user creates an object or calls a method, or when the
;; system invokes a callback, many steps may be required to
;; initialize or reset fields to maintain invariants. To ensure that
;; other threads do not call methods during a time when invariants
;; do not hold, we force all of the following code to be executed in
;; a single threaded manner, and we temporarily disable breaks.
;; The `as-entry' form or `entry-point' wrapper is normally used for
;; that case.
;;
;; If an exception is raised within an `enter'ed area, control is
;; moved back outside by the exception handler, and then the exception
;; is re-raised. The user can't tell that the exception was caught an
;; re-raised. But without the catch-and-reraise, the user's exception
;; handler might try to use GUI elements from a different thread, or
;; other such things, leading to deadlock.
(define monitor-sema (make-semaphore 1))
(define monitor-owner #f)
(define as-entry call-as-atomic)
;; An exception may be constructed while we're entered:
(define entered-err-string-handler
(lambda (s n)
(as-exit
(lambda ()
((error-value->string-handler) s n)))))
(define as-exit call-as-nonatomic)
(define old-paramz #f)
(define old-break-paramz #f)
(define-syntax entry-point
(lambda (stx)
(syntax-case stx (lambda #%plain-lambda case-lambda)
[(_ (lambda args body1 body ...))
(syntax (lambda args (as-entry (lambda () body1 body ...))))]
[(_ (#%plain-lambda args body1 body ...))
(syntax (#%plain-lambda args (as-entry (lambda () body1 body ...))))]
[(_ (case-lambda [vars body1 body ...] ...))
(syntax (case-lambda
[vars (as-entry (lambda () body1 body ...))]
...))])))
(define exited-key (gensym 'as-exit))
(define lock-tag (make-continuation-prompt-tag 'lock))
(define-syntax-rule (atomically expr ...)
(begin
(start-atomic)
(begin0 (let () expr ...)
(end-atomic))))
(define (as-entry f)
(cond
[(eq? monitor-owner (current-thread))
(f)]
[else
(with-continuation-mark
exited-key
#f
(call-with-continuation-prompt
(lambda ()
(dynamic-wind
(lambda ()
(wx:in-atomic-region monitor-sema)
(set! monitor-owner (current-thread)))
(lambda ()
(set! old-paramz (current-parameterization))
(set! old-break-paramz (current-break-parameterization))
(parameterize ([error-value->string-handler entered-err-string-handler])
(parameterize-break
#f
(call-with-exception-handler
(lambda (exn)
;; Get out of atomic region before letting
;; an exception handler work
(if (continuation-mark-set-first #f exited-key)
exn ; defer to previous exn handler
(abort-current-continuation
lock-tag
(lambda () (raise exn)))))
f))))
(lambda ()
(set! monitor-owner #f)
(set! old-paramz #f)
(set! old-break-paramz #f)
(semaphore-post monitor-sema)
(wx:in-atomic-region #f))))
lock-tag
(lambda (t) (t))))]))
(define (as-exit f)
;; (unless (eq? monitor-owner (current-thread)) (error 'monitor-exit "not in monitored area"))
(let ([paramz old-paramz]
[break-paramz old-break-paramz])
(with-continuation-mark
exited-key
#t ; disables special exception handling
(call-with-parameterization
paramz
(lambda ()
(call-with-break-parameterization
break-paramz
(lambda ()
(dynamic-wind
(lambda ()
(set! monitor-owner #f)
(semaphore-post monitor-sema)
(wx:in-atomic-region #f))
f
(lambda ()
(set! old-paramz paramz)
(set! old-break-paramz break-paramz)
(wx:in-atomic-region monitor-sema)
(set! monitor-owner (current-thread)))))))))))
(define-syntax entry-point
(lambda (stx)
(syntax-case stx (lambda case-lambda)
[(_ (lambda args body1 body ...))
(syntax (lambda args (as-entry (lambda () body1 body ...))))]
[(_ (case-lambda [vars body1 body ...] ...))
(syntax (case-lambda
[vars (as-entry (lambda () body1 body ...))]
...))])))
(define-syntax mk-param
(lambda (stx)
(syntax-case stx ()
[(_ val filter check force-redraw)
(syntax
(case-lambda
[() val]
[(v) (check v)
(let ([v2 (filter v)])
(unless (eq? v2 val)
(set! val v2)
(force-redraw)))]))]))))
;; Parameter-method pattern. (Why is this in the "lock" library?)
(define-syntax mk-param
(lambda (stx)
(syntax-case stx ()
[(_ val filter check force-redraw)
(syntax
(case-lambda
[() val]
[(v) (check v)
(let ([v2 (filter v)])
(unless (eq? v2 val)
(set! val v2)
(force-redraw)))]))])))

5
collects/mred/private/misc.rkt
View File

@ -10,7 +10,8 @@
play-sound
timer%)
;; Currently only used for PS print and preview
;; Formerly used for PS print and preview:
#;
(wx:set-executer
(let ([orig-err (current-error-port)])
(lambda (prog . args)
@ -30,7 +31,7 @@
(let loop ()
(let ([l (read-line p)])
(unless (eof-object? l)
(fprintf orig-err "~a~n" l)
(fprintf orig-err "~a\n" l)
(loop)))))
(lambda () (close-input-port p))))))])
(echo in)

63
collects/mred/private/moredialogs.rkt
View File

@ -208,7 +208,7 @@
((done #t) #f #f)))
init-val (list* 'single 'vertical-label style))]
[p (make-object horizontal-pane% f)])
(send p set-alignment 'right 'center)
(send p set-alignment 'right 'center)
(send f stretchable-height #f)
(ok-cancel
(lambda () (make-object button% "OK" p (done #t) '(border)))
@ -284,32 +284,58 @@
(check-top-level-parent/false 'get-color-from-user parent)
(check-instance 'get-color-from-user wx:color% 'color% #t color)
(check-style 'get-color-from-user #f null style)
(if (not (eq? (system-type) 'unix))
(if (eq? (wx:color-from-user-platform-mode) 'dialog)
(wx:get-color-from-user message (and parent (mred->wx parent)) color)
(letrec ([ok? #f]
[f (make-object dialog% "Choose Color" parent)]
[done (lambda (ok) (lambda (b e) (set! ok? ok) (send f show #f)))]
[canvas (make-object (class canvas%
(define/override (on-paint)
(repaint #f #f))
(repaint void))
(super-new [parent f])))]
[platform-p (and (string? (wx:color-from-user-platform-mode))
(new horizontal-panel%
[parent f]
[alignment '(right center)]))]
[p (make-object vertical-pane% f)]
[repaint (lambda (s e)
(let ([c (make-object wx:color%
(send red get-value)
(send green get-value)
(send blue get-value))])
(wx:fill-private-color (send canvas get-dc) c)))]
[make-color-slider (lambda (l) (make-object slider% l 0 255 p repaint))]
[repaint (lambda (ext)
(let ([c (get-current-color)])
(ext c)
(wx:fill-private-color (send canvas get-dc) c)))]
[update-and-repaint (lambda (s e)
(repaint
(lambda (c)
(when platform-p
(wx:get-color-from-user c)))))]
[make-color-slider (lambda (l) (make-object slider% l 0 255 p update-and-repaint))]
[red (make-color-slider "Red:")]
[green (make-color-slider "Green:")]
[blue (make-color-slider "Blue:")]
[bp (make-object horizontal-pane% f)])
(when color
(send red set-value (send color red))
(send green set-value (send color green))
(send blue set-value (send color blue)))
(ok-cancel
[bp (make-object horizontal-pane% f)]
[get-current-color
(lambda ()
(make-object wx:color%
(send red get-value)
(send green get-value)
(send blue get-value)))]
[install-color
(lambda (color)
(send red set-value (send color red))
(send green set-value (send color green))
(send blue set-value (send color blue))
(send canvas refresh))])
(when platform-p
(new button%
[parent platform-p]
[label (wx:color-from-user-platform-mode)]
[callback (lambda (b e) (wx:get-color-from-user 'show))])
(wx:get-color-from-user (or color
(make-object wx:color% 0 0 0)))
(send (mred->wx f) set-color-callback (lambda ()
(install-color
(wx:get-color-from-user 'get)))))
(when color (install-color color))
(ok-cancel
(lambda ()
(make-object button% "Cancel" bp (done #f)))
(lambda ()
@ -321,7 +347,4 @@
(send f center)
(send f show #t)
(and ok?
(make-object wx:color%
(send red get-value)
(send green get-value)
(send blue get-value)))))])))
(get-current-color))))])))

18
collects/mred/private/mrcanvas.rkt
View File

@ -51,6 +51,22 @@
[warp-pointer (entry-point (lambda (x y) (send wx warp-pointer x y)))]
[get-dc (entry-point (lambda () (send wx get-dc)))]
[make-bitmap (lambda (w h)
(unless (exact-positive-integer? w)
(raise-type-error (who->name '(method canvas% make-bitmap))
"exact positive integer"
w))
(unless (exact-positive-integer? h)
(raise-type-error (who->name '(method canvas% make-bitmap))
"exact positive integer"
h))
(send wx make-compatible-bitmap w h))]
[suspend-flush (lambda ()
(send wx begin-refresh-sequence))]
[resume-flush (lambda ()
(send wx end-refresh-sequence))]
[flush (lambda () (send wx flush))]
[set-canvas-background
(entry-point
@ -76,7 +92,7 @@
(sequence
(as-entry
(lambda ()
(super-init (lambda () (set! wx (mk-wx)) wx) (lambda () wx) mismatches #f parent #f))))))
(super-init (lambda () (set! wx (mk-wx)) wx) (lambda () wx) (lambda () wx) mismatches #f parent #f))))))
(define default-paint-cb (lambda (canvas dc) (void)))

9
collects/mred/private/mrcontainer.rkt
View File

@ -42,7 +42,7 @@
[alignment no-val])
(define (make-container% %) ; % implements area<%>
(class100* % (area-container<%> internal-container<%>) (mk-wx get-wx-pan mismatches parent
(class100* % (area-container<%> internal-container<%>) (mk-wx get-wx-pan get-wx-outer-pan mismatches parent
;; for keyword use
[border no-val]
[spacing no-val]
@ -122,7 +122,7 @@
(check-instance '(method area-container<%> delete-child) subwindow<%> 'subwindow<%> #f c)
(send (get-wx-panel) delete-child (mred->wx c))))])
(sequence
(super-init mk-wx get-wx-panel mismatches parent)
(super-init mk-wx get-wx-panel get-wx-outer-pan mismatches parent)
(unless (eq? border no-val) (bdr border))
(unless (eq? spacing no-val) (spc spacing))
(unless (eq? alignment no-val) (set-alignment . alignment)))))
@ -131,9 +131,8 @@
(interface (window<%> area-container<%>)))
(define (make-area-container-window% %) ; % implements window<%> (and area-container<%>)
(class100* % (area-container-window<%>) (mk-wx get-wx-pan mismatches label parent cursor)
(private-field [get-wx-panel get-wx-pan])
(class100* % (area-container-window<%>) (mk-wx get-wx-pan get-wx-outer-pan mismatches label parent cursor)
(sequence
(super-init mk-wx get-wx-panel mismatches label parent cursor)))))
(super-init mk-wx get-wx-pan get-wx-outer-pan mismatches label parent cursor)))))

13
collects/mred/private/mritem.rkt
View File

@ -11,6 +11,7 @@
"helper.ss"
"wx.ss"
"wxitem.ss"
"wxlitem.ss"
"mrwindow.ss"
"mrcontainer.ss")
@ -57,7 +58,7 @@
;; for keyword use
[font no-val])
(rename [super-set-label set-label])
(private-field [label lbl][callback cb])
(private-field [label lbl][callback cb] [is-bitmap? (lbl . is-a? . wx:bitmap%)])
(override
[get-label (lambda () label)]
[get-plain-label (lambda () (and (string? label) (wx:label->plain-label label)))]
@ -68,8 +69,12 @@
(let ([l (if (string? l)
(string->immutable-string l)
l)])
(send wx set-label l)
(set! label l))))])
(when (or (and is-bitmap?
(l . is-a? . wx:bitmap%))
(and (not is-bitmap?)
(string? l)))
(send wx set-label l)
(set! label l)))))])
(public
[hidden-child? (lambda () #f)] ; module-local method
[label-checker (lambda () check-label-string/false)] ; module-local method
@ -80,7 +85,7 @@
(sequence
(when (string? label)
(set! label (string->immutable-string label)))
(super-init (lambda () (set! wx (mk-wx)) wx) (lambda () wx) mismatches label parent cursor)
(super-init (lambda () (set! wx (mk-wx)) wx) (lambda () wx) (lambda () wx) mismatches label parent cursor)
(unless (hidden-child?)
(as-exit (lambda () (send parent after-new-child this)))))))

4
collects/mred/private/mrmenu.rkt
View File

@ -466,6 +466,4 @@
(define (menu-or-bar-parent who p)
(unless (or (is-a? p internal-menu<%>) (is-a? p menu-bar%))
(raise-type-error (constructor-name who) "built-in menu-item-container<%> object" p)))
(wx:set-menu-tester (lambda (m) (is-a? m popup-menu%))))
(raise-type-error (constructor-name who) "built-in menu-item-container<%> object" p))))

88
collects/mred/private/mrpanel.rkt
View File

@ -10,9 +10,7 @@
"kw.ss"
"wxpanel.ss"
"mrwindow.ss"
"mrcontainer.ss"
"mrtabgroup.ss"
"mrgroupbox.ss")
"mrcontainer.ss")
(provide pane%
vertical-pane%
@ -29,6 +27,8 @@
container%-keywords
area%-keywords)
(define-local-member-name get-initial-label)
(define pane%
(class100*/kw (make-subarea% (make-container% area%)) ()
[(parent) pane%-keywords]
@ -43,13 +43,17 @@
(check-container-parent cwho parent)
(as-entry
(lambda ()
(super-init (lambda () (set! wx (make-object (case who
[(vertical-pane) wx-vertical-pane%]
[(horizontal-pane) wx-horizontal-pane%]
[(grow-box-spacer-pane) wx-grow-box-pane%]
[else wx-pane%])
this this (mred->wx-container parent) null)) wx)
(lambda () wx)
(super-init (lambda ()
(set! wx (make-object (case who
[(vertical-pane) wx-vertical-pane%]
[(horizontal-pane) wx-horizontal-pane%]
[(grow-box-spacer-pane) wx-grow-box-pane%]
[else wx-pane%])
this this (mred->wx-container parent) null
#f))
wx)
(lambda () wx)
(lambda () wx)
(lambda ()
(check-container-ready cwho parent))
parent)
@ -70,6 +74,7 @@
(class100*/kw (make-area-container-window% (make-window% #f (make-subarea% (make-container% area%)))) (subwindow<%>)
[(parent [style null]) panel%-keywords]
(private-field [wx #f])
(public [get-initial-label (lambda () #f)])
(sequence
(let* ([who (cond ; yuck! - we do this to make h-p and v-p subclasses of p
[(is-a? this tab-panel%) 'tab-panel]
@ -83,10 +88,15 @@
(as-entry
(lambda ()
(super-init (lambda () (set! wx (make-object (case who
[(vertical-panel tab-panel group-box-panel) wx-vertical-panel%]
[(vertical-panel) wx-vertical-panel%]
[(tab-panel) wx-vertical-tab-panel%]
[(group-box-panel) wx-vertical-group-panel%]
[(horizontal-panel) wx-horizontal-panel%]
[else wx-panel%])
this this (mred->wx-container parent) style)) wx)
this this (mred->wx-container parent) style
(get-initial-label)))
wx)
(lambda () wx)
(lambda () wx)
(lambda () (check-container-ready cwho parent))
#f parent #f)
@ -112,6 +122,9 @@
(define tab-panel%
(class100*/kw vertical-panel% ()
[(choices parent [callback (lambda (b e) (void))] [style null] [font no-val]) panel%-keywords]
(private-field [save-choices choices])
(override [get-initial-label (lambda () save-choices)])
(sequence
(let ([cwho '(constructor tab-panel)])
(unless (and (list? choices) (andmap label-string? choices))
@ -120,22 +133,12 @@
(check-container-parent cwho parent)
(check-style cwho #f '(deleted no-border) style)
(check-font cwho font))
(super-init parent (if (memq 'deleted style)
'(deleted)
null)))
(private-field
[tabs (make-object tab-group% #f choices this (lambda (c e) (callback this e))
(if (memq 'no-border style)
null
'(border))
font)])
(sequence
(send (mred->wx this) set-first-child-is-hidden))
(private-field
[save-choices (map string->immutable-string choices)]
[hidden-tabs? #f])
(super-init parent (if (memq 'no-border style)
(if (eq? (car style) 'no-border)
(cdr style)
(list (car style)))
(cons 'border style)))
(send (mred->wx this) set-callback callback))
(public
[get-number (lambda () (length save-choices))]
@ -144,13 +147,13 @@
(check-label-string '(method tab-panel% append) n)
(let ([n (string->immutable-string n)])
(set! save-choices (list-append save-choices (list n)))
(send (mred->wx tabs) append n))))]
(send (mred->wx this) append n))))]
[get-selection (lambda () (and (pair? save-choices)
(send (mred->wx tabs) get-selection)))]
(send (mred->wx this) get-selection)))]
[set-selection (entry-point
(lambda (i)
(check-item 'set-selection i)
(send (mred->wx tabs) set-selection i)))]
(send (mred->wx this) set-selection i)))]
[delete (entry-point
(lambda (i)
(check-item 'delete i)
@ -158,7 +161,7 @@
(if (= p i)
(cdr l)
(cons (car l) (loop (add1 p) (cdr l))))))
(send (mred->wx tabs) delete i)))]
(send (mred->wx this) delete i)))]
[set-item-label (entry-point
(lambda (i s)
(check-item 'set-item-label i)
@ -168,14 +171,14 @@
(if (zero? i)
(cons s (cdr save-choices))
(cons (car save-choices) (loop (cdr save-choices) (sub1 i))))))
(send (mred->wx tabs) set-label i s))))]
(send (mred->wx this) set-label i s))))]
[set
(entry-point (lambda (l)
(unless (and (list? l) (andmap label-string? l))
(raise-type-error (who->name '(method tab-panel% set))
"list of strings (up to 200 characters)" l))
(set! save-choices (map string->immutable-string l))
(send (mred->wx tabs) set l)))]
(send (mred->wx this) set l)))]
[get-item-label (entry-point
(lambda (i)
(check-item 'get-item-label i)
@ -194,10 +197,13 @@
m (sub1 m)))
n))))])))
(define group-box-panel%
(class100*/kw vertical-panel% ()
[(label parent [style null] [font no-val]) panel%-keywords]
(private-field
[lbl label])
(override [get-initial-label (lambda () lbl)])
(sequence
(let ([cwho '(constructor group-box-panel)])
(check-label-string cwho label)
@ -211,14 +217,8 @@
(when (eq? vert-margin no-val) (set! vert-margin 2))
(super-init parent (if (memq 'deleted style)
'(deleted)
null)))
(private-field
[gbox (make-object group-box% label this null font)]
[lbl label])
(sequence
(send (mred->wx this) set-first-child-is-hidden))
'(deleted)
null)))
(override
[set-label (entry-point
@ -227,5 +227,5 @@
(set! lbl (if (immutable? s)
s
(string->immutable-string s)))
(send gbox set-label s)))]
(send (mred->wx this) set-label s)))]
[get-label (lambda () lbl)]))))

70
collects/mred/private/mrtextfield.rkt
View File

@ -57,11 +57,16 @@
(private-field
[wx #f])
(public
[set-field-background (lambda (c)
(check-instance '(method text-field% set-field-color)
wx:color% 'color% #f c)
(send wx set-field-background c))]
[get-field-background (lambda () (send wx get-field-background))]
[get-editor (entry-point (lambda () (send wx get-editor)))]
[get-value (lambda () (send wx get-value))] ; note: wx method doesn't expect as-entry
[set-value (entry-point
(lambda (v)
(check-string '(method text-control<%> set-value) v)
(check-string '(method text-field% set-value) v)
(send wx set-value v)))])
(sequence
;; Technically a bad way to change margin defaults, since it's
@ -96,36 +101,47 @@
parent callback init-value
style #f
font))
(private
[prep-popup
(lambda ()
(send menu on-demand)
(let ([items (send menu get-items)]
[wx (mred->wx this)])
(send wx clear-combo-items)
(for-each
(lambda (item)
(unless (item . is-a? . separator-menu-item%)
(send wx append-combo-item
(send item get-plain-label)
(lambda ()
(send item command
(make-object wx:control-event% 'menu-popdown))))))
items)))])
(public
[on-popup (lambda (e)
(let-values ([(w h) (get-size)]
[(cw) (send (mred->wx this) get-canvas-width)])
(send menu set-min-width cw)
(popup-menu menu (- w cw) h)))]
[on-popup (lambda (e) (void))]
[get-menu (lambda () menu)]
[append (lambda (item)
(check-label-string '(method combo-field% append) item)
(make-object menu-item% item menu
(lambda (i e)
(focus)
(set-value item)
(let ([e (get-editor)])
(send e set-position 0 (send e last-position)))
(send (as-entry (lambda () (mred->wx this)))
command
(make-object wx:control-event% 'text-field)))))])
(override
[on-subwindow-event (lambda (w e)
(and (send e button-down?)
(let-values ([(cw) (send (mred->wx this) get-canvas-width)])
(and ((send e get-x) . >= . (- cw side-combo-width))
(begin
(on-popup e)
#t)))))])
(make-object menu-item% item menu
(lambda (i e)
(handle-selected item))))])
(private
[handle-selected (lambda (item)
(focus)
(set-value item)
(let ([e (get-editor)])
(send e set-position 0 (send e last-position)))
(send (as-entry (lambda () (mred->wx this)))
command
(make-object wx:control-event% 'text-field)))])
(private-field
[menu (new popup-menu% [font font])])
(sequence
(for-each (lambda (item)
(append item))
choices)
(super-init label parent callback init-value (list* combo-flag 'single style))))))
(super-init label parent callback init-value (list* combo-flag 'single style))
(send (mred->wx this)
set-on-popup
(lambda ()
(on-popup (make-object wx:control-event% 'menu-popdown))
(prep-popup)))
(for-each (lambda (item) (append item))
choices)))))

40
collects/mred/private/mrtop.rkt
View File

@ -12,6 +12,7 @@
"wx.ss"
"wxtop.ss"
"wxpanel.ss"
"wxitem.ss"
"mrwindow.ss"
"mrcontainer.ss")
@ -41,6 +42,10 @@
(define-keywords top-level-window%-keywords
window%-keywords container%-keywords area%-keywords)
(define-local-member-name
do-create-status-line
do-set-status-text)
(define basic-top-level-window%
(class100* (make-area-container-window% (make-window% #t (make-container% area%))) (top-level-window<%>)
(mk-wx mismatches label parent)
@ -93,7 +98,7 @@
(lambda (w h)
(check-range-integer '(method top-level-window<%> resize) w)
(check-range-integer '(method top-level-window<%> resize) h)
(send wx set-size -1 -1 w h)))]
(send wx set-size -11111 -11111 w h)))]
[get-focus-window (entry-point
(lambda () (let ([w (send wx get-focus-window)])
@ -111,24 +116,41 @@
[on-message (lambda (m) (void))])
(private-field
[wx #f]
[mid-panel #f] ;; supports status line
[wx-panel #f]
[status-message #f]
[finish (entry-point
(lambda (top-level hide-panel?)
(set! wx-panel (make-object wx-vertical-panel% #f this top-level null))
(set! mid-panel (make-object wx-vertical-panel% #f this top-level null #f))
(send mid-panel skip-subwindow-events? #t)
(send (send mid-panel area-parent) add-child mid-panel)
(set! wx-panel (make-object wx-vertical-panel% #f this mid-panel null #f))
(send wx-panel skip-subwindow-events? #t)
(send (send wx-panel area-parent) add-child wx-panel)
(send top-level set-container wx-panel)
(when hide-panel?
(send wx-panel show #f))
(send mid-panel show #f))
top-level))])
(public
[do-create-status-line (lambda ()
(unless status-message
(set! status-message (make-object wx-message% this this mid-panel "" -1 -1 null #f))
(send status-message stretchable-in-x #t)))]
[do-set-status-text (lambda (s)
(when status-message
(send status-message set-label s)))])
(sequence
(super-init (lambda () (set! wx (mk-wx finish)) wx) (lambda () wx-panel) mismatches label parent arrow-cursor))))
(super-init (lambda () (set! wx (mk-wx finish)) wx)
(lambda () wx-panel) (lambda () mid-panel)
mismatches label parent arrow-cursor))))
(define frame%
(class100*/kw basic-top-level-window% ()
[(label [parent #f] [width #f] [height #f] [x #f] [y #f] [style null])
top-level-window%-keywords]
(inherit on-traverse-char on-system-menu-char)
(inherit on-traverse-char on-system-menu-char
do-create-status-line do-set-status-text)
(sequence
(let ([cwho '(constructor frame)])
(check-label-string cwho label)
@ -164,8 +186,8 @@
(send wx handle-menu-key e)))]
[on-mdi-activate (lambda (on?) (void))]
[on-toolbar-button-click (lambda () (void))]
[create-status-line (entry-point (lambda () (unless status-line? (send wx create-status-line) (set! status-line? #t))))]
[set-status-text (lambda (s) (send wx set-status-text s))]
[create-status-line (entry-point (lambda () (unless status-line? (do-create-status-line) (set! status-line? #t))))]
[set-status-text (lambda (s) (do-set-status-text s))]
[has-status-line? (lambda () status-line?)]
[iconize (entry-point (lambda (on?) (send wx iconize on?)))]
[is-iconized? (entry-point (lambda () (send wx iconized?)))]
@ -215,7 +237,7 @@
(check-label-string cwho label)
(check-top-level-parent/false cwho parent)
(for-each (lambda (x) (check-dimension cwho x)) (list width height x y))
(check-style cwho #f '(no-caption resize-border no-sheet) style)))
(check-style cwho #f '(no-caption resize-border no-sheet close-button) style)))
(rename [super-on-subwindow-char on-subwindow-char])
(private-field [wx #f])
(override
@ -228,7 +250,7 @@
(lambda ()
(super-init (lambda (finish)
(set! wx (finish (make-object wx-dialog% this this
(and parent (mred->wx parent)) label #t
(and parent (mred->wx parent)) label
(or x -11111) (or y -11111) (or width 0) (or height 0)
style)
#f))

27
collects/mred/private/mrwindow.rkt
View File

@ -21,7 +21,9 @@
window<%>
(protect window%-keywords)
subwindow<%>
(protect make-window%))
(protect make-window%)
(protect set-get-outer-panel))
(define area<%>
(interface ()
@ -36,8 +38,11 @@
[stretchable-width no-val]
[stretchable-height no-val])
(define-local-member-name
set-get-outer-panel)
(define area%
(class100* mred% (area<%>) (mk-wx get-wx-pan mismatches prnt
(class100* mred% (area<%>) (mk-wx get-wx-pan get-outer-wx-pan mismatches prnt
;; for keyword use:
[min-width no-val]
[min-height no-val]
@ -49,15 +54,15 @@
(unless (eq? min-height no-val) (check-non#f-dimension cwho min-height)))
(mismatches))
(private-field
[get-wx-panel get-wx-pan]
[get-wx-outer-panel get-outer-wx-pan]
[parent prnt])
(public
[get-parent (lambda () parent)]
[get-top-level-window (entry-point (lambda () (wx->mred (send wx get-top-level))))]
[(minw min-width) (param get-wx-panel min-width)]
[(minh min-height) (param get-wx-panel min-height)]
[(sw stretchable-width) (param get-wx-panel stretchable-in-x)]
[(sh stretchable-height) (param get-wx-panel stretchable-in-y)]
[(minw min-width) (param get-wx-outer-panel min-width)]
[(minh min-height) (param get-wx-outer-panel min-height)]
[(sw stretchable-width) (param get-wx-outer-panel stretchable-in-x)]
[(sh stretchable-height) (param get-wx-outer-panel stretchable-in-y)]
[get-graphical-min-size (entry-point (lambda ()
(if (wx . is-a? . wx-basic-panel<%>)
(apply values (send wx get-graphical-min-size))
@ -82,7 +87,7 @@
[vert-margin no-val])
(define (make-subarea% %) ; % implements area<%>
(class100* % (subarea<%>) (mk-wx get-wx-pan mismatches parent
(class100* % (subarea<%>) (mk-wx get-wx-pan get-outer-wx-pan mismatches parent
;; for keyword use
[horiz-margin no-val]
[vert-margin no-val])
@ -95,7 +100,7 @@
[(hm horiz-margin) (param get-wx-panel x-margin)]
[(vm vert-margin) (param get-wx-panel y-margin)])
(sequence
(super-init mk-wx get-wx-panel mismatches parent)
(super-init mk-wx get-wx-panel get-outer-wx-pan mismatches parent)
(unless (eq? horiz-margin no-val) (hm horiz-margin))
(unless (eq? vert-margin no-val) (vm vert-margin)))))
@ -119,7 +124,7 @@
(interface (window<%> subarea<%>)))
(define (make-window% top? %) ; % implements area<%>
(class100* % (window<%>) (mk-wx get-wx-panel mismatches lbl parent crsr
(class100* % (window<%>) (mk-wx get-wx-panel get-outer-wx-panel mismatches lbl parent crsr
;; for keyword use
[enabled #t])
(private-field [label lbl][cursor crsr])
@ -228,5 +233,5 @@
(private-field
[wx #f])
(sequence
(super-init (lambda () (set! wx (mk-wx)) wx) get-wx-panel mismatches parent)
(super-init (lambda () (set! wx (mk-wx)) wx) get-wx-panel get-outer-wx-panel mismatches parent)
(unless enabled (enable #f))))))

59
collects/mred/private/snipfile.rkt
View File

@ -1,11 +1,10 @@
(module snipfile mzscheme
(require mzlib/class
mzlib/etc
mzlib/port
(module snipfile racket/base
(require racket/class
racket/port
syntax/moddep
(prefix wx: "kernel.ss")
(prefix wx: "wxme/snip.ss")
(prefix wx: "wxme/cycle.ss")
(prefix-in wx: "kernel.ss")
(prefix-in wx: "wxme/snip.ss")
(prefix-in wx: "wxme/cycle.ss")
"check.ss"
"editor.ss")
@ -72,7 +71,8 @@
;; starting at position `start-in'
;; and ending at position `end'.
(define open-input-text-editor
(opt-lambda (text [start 0] [end 'end] [snip-filter values] [port-name text] [expect-to-read-all? #f])
(lambda (text [start 0] [end 'end] [snip-filter values] [port-name text] [expect-to-read-all? #f]
#:lock-while-reading? [lock-while-reading? #f])
;; Check arguments:
(unless (text . is-a? . text%)
(raise-type-error 'open-input-text-editor "text% object" text))
@ -105,24 +105,33 @@
;; It's all text, and it's short enough: just read it into a string
(open-input-string (send text get-text start end) port-name)
;; It's all text, so the reading process is simple:
(let ([start start])
(let-values ([(pipe-r pipe-w) (make-pipe)])
(let ([start start])
(when lock-while-reading? (send text lock #t))
(let-values ([(pipe-r pipe-w) (make-pipe)])
(make-input-port/read-to-peek
port-name
port-name
(lambda (s)
(let ([v (read-bytes-avail!* s pipe-r)])
(if (eq? v 0)
(let ([n (min 4096 (- end start))])
(if (zero? n)
(begin
(close-output-port pipe-w)
eof)
(close-output-port pipe-w)
(when lock-while-reading?
(set! lock-while-reading? #f)
(send text lock #f))
eof)
(begin
(write-string (send text get-text start (+ start n)) pipe-w)
(set! start (+ start n))
(read-bytes-avail!* s pipe-r))))
(let ([ans (read-bytes-avail!* s pipe-r)])
(when lock-while-reading?
(when (eof-object? ans)
(set! lock-while-reading? #f)
(send text lock #f)))
ans))))
v)))
(lambda (s skip general-peek)
(lambda (s skip general-peek)
(let ([v (peek-bytes-avail!* s skip #f pipe-r)])
(if (eq? v 0)
(general-peek s skip)
@ -184,17 +193,21 @@
[port (make-input-port/read-to-peek
port-name
(lambda (s)
(let ([v (read-bytes-avail!* s pipe-r)])
(if (eq? v 0)
(read-chars s)
v)))
(lambda (s skip general-peek)
(let* ([v (read-bytes-avail!* s pipe-r)]
[res (if (eq? v 0) (read-chars s) v)])
(when (eof-object? res)
(when lock-while-reading?
(set! lock-while-reading? #f)
(send text lock #f)))
res))
(lambda (s skip general-peek)
(let ([v (peek-bytes-avail!* s skip #f pipe-r)])
(if (eq? v 0)
(general-peek s skip)
v)))
close)])
(if (is-a? snip wx:string-snip%)
(when lock-while-reading? (send text lock #t))
(if (is-a? snip wx:string-snip%)
;; Special handling for initial snip string in
;; case it starts too early:
(let* ([snip-start (gsp snip)]
@ -235,7 +248,7 @@
(apply values last-time-values)
(call-with-values (lambda () (call-with-continuation-prompt
(lambda () (eval
(datum->syntax-object
(datum->syntax
#f
(cons '#%top-interaction exp)
exp)))
@ -271,7 +284,7 @@
p))
(define open-output-text-editor
(opt-lambda (text [start 'end] [special-filter values] [port-name text])
(lambda (text [start 'end] [special-filter values] [port-name text])
(define pos (if (eq? start 'end)
(send text last-position)
(min start

276
collects/mred/private/syntax.rkt
View File

@ -1,275 +1,3 @@
#lang scheme/base
(require scheme/class
scheme/stxparam
(for-syntax scheme/base))
(provide defclass defclass*
def/public def/public-final def/override def/override-final define/top case-args
maybe-box? any? bool? nonnegative-real? make-or-false make-box make-list make-alts
make-literal symbol-in make-procedure
method-name init-name
let-boxes
properties field-properties init-properties
->long
assert)
(define-syntax-parameter class-name #f)
(define-syntax-rule (defclass name super . body)
(defclass* name super () . body))
(define-syntax-rule (defclass* name super intfs . body)
(define name
(syntax-parameterize ([class-name 'name])
(class* super intfs . body))))
(define-syntax (def/public stx)
#`(def/thing define/public #,stx))
(define-syntax (def/public-final stx)
#`(def/thing define/public-final #,stx))
(define-syntax (def/override stx)
#`(def/thing define/override #,stx))
(define-syntax (def/override-final stx)
#`(def/thing define/override-final #,stx))
(define-syntax (define/top stx)
#`(def/thing define #,stx))
(define (method-name class method)
(string->symbol (format "~a in ~a" method class)))
(define (init-name class)
(string->symbol (format "initialization for ~a" class)))
(define-syntax just-id
(syntax-rules ()
[(_ [id default]) id]
[(_ id) id]))
(define-struct named-pred (pred make-name)
#:property prop:procedure (struct-field-index pred))
(define (apply-pred pred val)
(cond
[(procedure? pred) (pred val)]
[(class? pred) (val . is-a? . pred)]
[(interface? pred) (val . is-a? . pred)]
[else (error 'check-arg "unknown predicate type: ~e" pred)]))
(define (make-or-false pred)
(make-named-pred (lambda (v)
(or (not v) (apply-pred pred v)))
(lambda ()
(string-append (predicate-name pred)
" or #f"))))
(define (make-box pred)
(make-named-pred (lambda (v)
(and (box? v) (apply-pred pred (unbox v))))
(lambda ()
(string-append "boxed " (predicate-name pred)))))
(define (make-list pred)
(make-named-pred (lambda (v)
(and (list? v) (andmap (lambda (v) (apply-pred pred v)) v)))
(lambda ()
(string-append "list of " (predicate-name pred)))))
(define (make-alts a b)
(make-named-pred (lambda (v)
(or (apply-pred a v) (apply-pred b v)))
(lambda ()
(string-append (predicate-name a)
" or "
(predicate-name b)))))
(define (make-literal lit)
(make-named-pred (lambda (v) (equal? v lit))
(lambda () (if (symbol? lit)
(format "'~s" lit)
(format "~s" lit)))))
(define (make-symbol syms)
(make-named-pred (lambda (v) (memq v syms))
(lambda ()
(let loop ([syms syms])
(cond
[(null? (cdr syms))
(format "'~s" (car syms))]
[(null? (cddr syms))
(format "'~s, or '~s" (car syms) (cadr syms))]
[else
(format "'~s, ~a" (car syms) (loop (cdr syms)))])))))
(define-syntax-rule (symbol-in sym ...)
(make-symbol '(sym ...)))
(define (make-procedure arity)
(make-named-pred (lambda (p)
(and (procedure? p)
(procedure-arity-includes? p arity)))
(lambda ()
(format "procedure (arity ~a)" arity))))
(define (check-arg val pred pos)
(if (apply-pred pred val)
#f
(cons (predicate-name pred)
pos)))
(define (predicate-name pred)
(cond
[(named-pred? pred) ((named-pred-make-name pred))]
[(procedure? pred) (let ([s (symbol->string (object-name pred))])
(substring s 0 (sub1 (string-length s))))]
[(or (class? pred) (interface? pred))
(format "~a instance" (object-name pred))]
[else "???"]))
(define maybe-box? (make-named-pred (lambda (v) (or (not v) (box? v)))
(lambda () "box or #f")))
(define (any? v) #t)
(define (bool? v) #t)
(define (nonnegative-real? v) (and (real? v) (v . >= . 0)))
(define (method-of cls nam)
(if cls
(string->symbol (format "~a method of ~a" nam cls))
nam))
(define-syntax (def/thing stx)
(syntax-case stx ()
[(_ define/orig (_ (id [arg-type arg] ...)))
(raise-syntax-error #f "missing body" stx)]
[(_ define/orig (_ (id [arg-type arg] ...) . body))
(with-syntax ([(_ _ orig-stx) stx]
[(pos ...) (for/list ([i (in-range (length (syntax->list #'(arg ...))))])
i)]
[cname (syntax-parameter-value #'class-name)])
(syntax/loc #'orig-stx
(define/orig (id arg ...)
(let ([bad (or (check-arg (just-id arg) arg-type pos)
...)])
(when bad
(raise-type-error (method-of 'cname 'id) (car bad) (cdr bad) (just-id arg) ...)))
(let ()
. body))))]))
(define-for-syntax lifted (make-hash))
(define-syntax (lift-predicate stx)
(syntax-case stx ()
[(_ id) (identifier? #'id) #'id]
[(_ expr)
(let ([d (syntax->datum #'expr)])
(or (hash-ref lifted d #f)
(let ([id (syntax-local-lift-expression #'expr)])
(hash-set! lifted d id)
id)))]))
(define-syntax (case-args stx)
(syntax-case stx ()
[(_ expr [([arg-type arg] ...) rhs ...] ... who)
(with-syntax ([((min-args-len . max-args-len) ...)
(map (lambda (args)
(let ([args (syntax->list args)])
(cons (let loop ([args args])
(if (or (null? args)
(not (identifier? (car args))))
0
(add1 (loop (cdr args)))))
(length args))))
(syntax->list #'((arg ...) ...)))])
#'(let* ([args expr]
[len (length args)])
(find-match
(lambda (next)
(if (and (len . >= . min-args-len)
(len . <= . max-args-len))
(apply
(lambda (arg ...)
(if (and (not (check-arg (just-id arg) (lift-predicate arg-type) 0)) ...)
(lambda () rhs ...)
next))
args)
next))
...
(lambda (next)
(bad-args who args)))))]))
(define (bad-args who args)
(error who "bad argument combination:~a"
(apply string-append (map (lambda (x) (format " ~e" x))
args))))
(define-syntax find-match
(syntax-rules ()
[(_ proc)
((proc #f))]
[(_ proc1 proc ...)
((proc1 (lambda () (find-match proc ...))))]))
(define-syntax-rule (let-boxes ([id init] ...)
call
body ...)
(let ([id (box init)] ...)
call
(let ([id (unbox id)] ...)
body ...)))
(define-syntax (do-properties stx)
(syntax-case stx ()
[(_ define-base check-immutable [[type id] expr] ...)
(let ([ids (syntax->list #'(id ...))])
(with-syntax ([(getter ...)
(map (lambda (id)
(datum->syntax id
(string->symbol
(format "get-~a" (syntax-e id)))
id))
ids)]
[(setter ...)
(map (lambda (id)
(datum->syntax id
(string->symbol
(format "set-~a" (syntax-e id)))
id))
ids)])
#'(begin
(define-base id expr) ...
(define/public (getter) id) ...
(def/public (setter [type v]) (check-immutable 'setter) (set! id (coerce type v))) ...)))]))
(define-syntax coerce
(syntax-rules (bool?)
[(_ bool? v) (and v #t)]
[(_ _ v) v]))
(define-syntax properties
(syntax-rules ()
[(_ #:check-immutable check-immutable . props)
(do-properties define check-immutable . props)]
[(_ . props)
(do-properties define void . props)]))
(define-syntax field-properties
(syntax-rules ()
[(_ #:check-immutable check-immutable . props)
(do-properties define-field check-immutable . props)]
[(_ . props)
(do-properties define-field void . props)]))
(define-syntax-rule (define-field id val) (field [id val]))
(define-syntax init-properties
(syntax-rules ()
[(_ #:check-immutable check-immutable . props)
(do-properties define-init check-immutable . props)]
[(_ . props)
(do-properties define-init void . props)]))
(define-syntax-rule (define-init id val) (begin
(init [(internal id) val])
(define id internal)))
(define (->long i)
(cond
[(eqv? -inf.0 i) (- (expt 2 64))]
[(eqv? +inf.0 i) (expt 2 64)]
[(eqv? +nan.0 i) 0]
[else (inexact->exact (floor i))]))
(define-syntax-rule (assert e) (void))
; (define-syntax-rule (assert e) (unless e (error 'assert "failed: ~s" 'e)))
(require racket/draw/private/syntax)
(provide (all-from-out racket/draw/private/syntax))

19
collects/mred/private/te.rkt Normal file
View File

@ -0,0 +1,19 @@
#lang racket/base
(require racket/class
racket/draw)
(provide get-window-text-extent*)
(define get-window-text-extent*
(let ([bm #f][dc #f])
(case-lambda
[(string font) (get-window-text-extent* string font #f)]
[(string font combine?)
(unless bm
(set! bm (make-object bitmap% 2 2))
(set! dc (make-object bitmap-dc%))
(send dc set-bitmap bm))
(unless (send bm ok?)
(error 'get-window-text-extent "couldn't allocate sizing bitmap"))
(let-values ([(w h d a) (send dc get-text-extent string font combine?)])
(values w h d a))])))

16
collects/mred/private/wx/cocoa/README.txt Normal file
View File

@ -0,0 +1,16 @@
Allocation rules:
* Use `as-objc-allocation' when creating a Cocoa object. When the
resulting reference becomes unreachable, the Cocoa object will be
released.
* Use `with-autorelease' in atomic mode around calls that autorelease
and where the release should take effect immediate. Do not create
an autorelease pool except in atomic mode.
* Other autoreleased objects may end up in the root pool installed by
"pool.rkt". The root pool is periodically destroyed and replaced;
call `queue-autorelease-flush' if you need to encurage replacement
of the pool. If you need to use an object htat might be autoflushed,
be sure that you're in atomic mode.

162
collects/mred/private/wx/cocoa/button.rkt Normal file
View File

@ -0,0 +1,162 @@
#lang racket/base
(require ffi/unsafe/objc
ffi/unsafe
racket/class
"../../syntax.rkt"
"item.rkt"
"utils.rkt"
"types.rkt"
"const.rkt"
"window.rkt"
"../common/event.rkt"
"image.rkt")
(provide
(protect-out button%
core-button%
MyButton))
;; ----------------------------------------
(import-class NSButton NSView NSImageView)
(define MIN-BUTTON-WIDTH 72)
(define BUTTON-EXTRA-WIDTH 12)
(define NSSmallControlSize 1)
(define NSMiniControlSize 2)
(define-objc-class MyButton NSButton
#:mixins (FocusResponder KeyMouseResponder CursorDisplayer)
[wxb]
(-a _void (clicked: [_id sender])
(queue-window*-event wxb (lambda (wx) (send wx clicked)))))
(defclass core-button% item%
(init parent cb label x y w h style font
[button-type #f])
(init-field [event-type 'button])
(inherit get-cocoa get-cocoa-window init-font
register-as-child)
(define button-cocoa
(let ([cocoa
(as-objc-allocation
(tell (tell MyButton alloc)
initWithFrame: #:type _NSRect (make-NSRect (make-init-point x y)
(make-NSSize w h))))])
(when button-type
(tellv cocoa setButtonType: #:type _int button-type))
(unless button-type
(tellv cocoa setBezelStyle: #:type _int (if (not (string? label))
NSRegularSquareBezelStyle
NSRoundedBezelStyle)))
(cond
[(string? label)
(tellv cocoa setTitleWithMnemonic: #:type _NSString label)]
[(send label ok?)
(if button-type
(tellv cocoa setTitle: #:type _NSString "")
(tellv cocoa setImage: (bitmap->image label)))]
[else
(tellv cocoa setTitle: #:type _NSString "<bad>")])
(init-font cocoa font)
(tellv cocoa sizeToFit)
(when (and (eq? event-type 'button)
(string? label))
(when font
(let ([n (send font get-point-size)])
;; If the font is small, adjust the control size:
(when (n . < . sys-font-size)
(tellv (tell cocoa cell)
setControlSize: #:type _int
(if (n . < . (- sys-font-size 2))
NSMiniControlSize
NSSmallControlSize))
(tellv cocoa sizeToFit))
;; If the font is big, use a scalable control shape:
(when (n . > . (+ sys-font-size 2))
(tellv cocoa setBezelStyle: #:type _int NSRegularSquareBezelStyle)
(tellv cocoa sizeToFit))))
(let ([frame (tell #:type _NSRect cocoa frame)])
(tellv cocoa setFrame: #:type _NSRect
(make-NSRect (NSRect-origin frame)
(make-NSSize (+ BUTTON-EXTRA-WIDTH
(max MIN-BUTTON-WIDTH
(NSSize-width (NSRect-size frame))))
(NSSize-height (NSRect-size frame)))))))
cocoa))
(define-values (cocoa image-cocoa)
(if (and button-type
(not (string? label))
(send label ok?))
;; Check-box image: need an view to join a button and an image view:
;; (Could we use the NSImageButtonCell from the radio-box implementation
;; instead?)
(let* ([frame (tell #:type _NSRect button-cocoa frame)]
[new-width (+ (NSSize-width (NSRect-size frame))
(send label get-width))]
[new-height (max (NSSize-height (NSRect-size frame))
(send label get-height))])
(let ([cocoa (as-objc-allocation
(tell (tell NSView alloc)
initWithFrame: #:type _NSRect
(make-NSRect (NSRect-origin frame)
(make-NSSize new-width
new-height))))]
[image-cocoa (as-objc-allocation
(tell (tell NSImageView alloc) init))])
(tellv cocoa addSubview: button-cocoa)
(tellv cocoa addSubview: image-cocoa)
(tellv image-cocoa setImage: (bitmap->image label))
(tellv image-cocoa setFrame: #:type _NSRect
(make-NSRect (make-NSPoint (NSSize-width (NSRect-size frame))
(quotient (- new-height
(send label get-height))
2))
(make-NSSize (send label get-width)
(send label get-height))))
(tellv button-cocoa setFrame: #:type _NSRect
(make-NSRect (make-NSPoint 0 0)
(make-NSSize new-width new-height)))
(set-ivar! button-cocoa wxb (->wxb this))
(values cocoa image-cocoa)))
(values button-cocoa #f)))
(define we (make-will-executor))
(super-new [parent parent]
[cocoa cocoa]
[no-show? (memq 'deleted style)]
[callback cb])
(when (memq 'border style)
(tellv (get-cocoa-window) setDefaultButtonCell: (tell button-cocoa cell)))
(tellv button-cocoa setTarget: button-cocoa)
(tellv button-cocoa setAction: #:type _SEL (selector clicked:))
(define/override (get-cocoa-control) button-cocoa)
(define/override (maybe-register-as-child parent on?)
(register-as-child parent on?))
(define/override (set-label label)
(cond
[(string? label)
(tellv cocoa setTitleWithMnemonic: #:type _NSString label)]
[else
(tellv (or image-cocoa cocoa) setImage: (bitmap->image label))]))
(define callback cb)
(define/public (clicked)
(callback this (new control-event%
[event-type event-type]
[time-stamp (current-milliseconds)])))
(def/public-unimplemented set-border))
(define button%
(class core-button% (super-new)))

835
collects/mred/private/wx/cocoa/canvas.rkt Normal file
View File

@ -0,0 +1,835 @@
#lang racket/base
(require ffi/unsafe/objc
ffi/unsafe
racket/class
racket/draw
racket/draw/private/gl-context
racket/draw/private/color
"pool.rkt"
"utils.rkt"
"const.rkt"
"types.rkt"
"window.rkt"
"dc.rkt"
"bitmap.rkt"
"cg.rkt"
"queue.rkt"
"item.rkt"
"gc.rkt"
"image.rkt"
"../common/backing-dc.rkt"
"../common/canvas-mixin.rkt"
"../common/event.rkt"
"../common/queue.rkt"
"../../syntax.rkt"
"../../lock.rkt"
"../common/freeze.rkt")
(provide
(protect-out canvas%))
;; ----------------------------------------
(import-class NSView NSGraphicsContext NSScroller NSComboBox NSWindow
NSImageView NSTextFieldCell
NSOpenGLView NSOpenGLPixelFormat)
(import-protocol NSComboBoxDelegate)
(define NSWindowAbove 1)
(define o (current-error-port))
;; Called when a canvas has no backing store ready
(define (clear-background wxb)
(let ([wx (->wx wxb)])
(when wx
(let ([bg (send wx get-canvas-background-for-clearing)])
(when bg
(let ([ctx (tell NSGraphicsContext currentContext)])
(tellv ctx saveGraphicsState)
(let ([cg (tell #:type _CGContextRef ctx graphicsPort)]
[adj (lambda (v) (/ v 255.0))])
(CGContextSetRGBFillColor cg
(adj (color-red bg))
(adj (color-blue bg))
(adj (color-green bg))
1.0)
(CGContextFillRect cg (make-NSRect (make-NSPoint 0 0)
(make-NSSize 32000 32000))))
(tellv ctx restoreGraphicsState)))))))
(define-objc-mixin (MyViewMixin Superclass)
#:mixins (FocusResponder KeyMouseTextResponder CursorDisplayer)
[wxb]
(-a _void (drawRect: [_NSRect r])
(when wxb
(let ([wx (->wx wxb)])
(when wx
(unless (send wx paint-or-queue-paint)
(clear-background wxb)
;; ensure that `nextEventMatchingMask:' returns
(post-dummy-event))))))
(-a _void (viewWillMoveToWindow: [_id w])
(when wxb
(let ([wx (->wx wxb)])
(when wx
(queue-window-event wx (lambda () (send wx fix-dc)))))))
(-a _void (onHScroll: [_id scroller])
(when wxb
(let ([wx (->wx wxb)])
(when wx (send wx do-scroll 'horizontal scroller)))))
(-a _void (onVScroll: [_id scroller])
(when wxb
(let ([wx (->wx wxb)])
(when wx (send wx do-scroll 'vertical scroller))))))
(define-objc-class MyView NSView
#:mixins (MyViewMixin)
[wxb])
(define-objc-class MyGLView NSOpenGLView
#:mixins (MyViewMixin)
[wxb])
(define-objc-class FrameView NSView
[]
(-a _void (drawRect: [_NSRect r])
(let ([ctx (tell NSGraphicsContext currentContext)])
(tellv ctx saveGraphicsState)
(let ([cg (tell #:type _CGContextRef ctx graphicsPort)]
[r (tell #:type _NSRect self bounds)])
(CGContextSetRGBFillColor cg 0 0 0 1.0)
(CGContextAddRect cg r)
(CGContextStrokePath cg))
(tellv ctx restoreGraphicsState))))
(define-objc-class CornerlessFrameView NSView
[]
(-a _void (drawRect: [_NSRect r])
(let ([ctx (tell NSGraphicsContext currentContext)])
(tellv ctx saveGraphicsState)
(let ([cg (tell #:type _CGContextRef ctx graphicsPort)]
[r (tell #:type _NSRect self bounds)])
(CGContextSetRGBFillColor cg 0 0 0 1.0)
(let* ([l (NSPoint-x (NSRect-origin r))]
[t (NSPoint-y (NSRect-origin r))]
[b (+ t (NSSize-height (NSRect-size r)))]
[r (+ l (NSSize-width (NSRect-size r)))])
(CGContextAddLines cg
(vector
(make-NSPoint r (+ t scroll-width))
(make-NSPoint r b)
(make-NSPoint l b)
(make-NSPoint l t)
(make-NSPoint (- r scroll-width) t))))
(CGContextStrokePath cg))
(tellv ctx restoreGraphicsState))))
(define-cocoa NSSetFocusRingStyle (_fun _int -> _void))
(define-cocoa NSRectFill (_fun _NSRect -> _void))
(define bezel-cell
(tell (tell NSTextFieldCell alloc) initTextCell: #:type _NSString ""))
(tellv bezel-cell setBezeled: #:type _BOOL #t)
(define-objc-class FocusView NSView
[on?]
(-a _void (setFocusState: [_BOOL is-on?])
(set! on? is-on?))
(-a _void (drawRect: [_NSRect r])
(let ([f (tell #:type _NSRect self frame)])
(tellv bezel-cell
drawWithFrame: #:type _NSRect (make-NSRect (make-NSPoint 2 2)
(let ([s (NSRect-size r)])
(make-NSSize (- (NSSize-width s) 4)
(- (NSSize-height s) 4))))
inView: self))
(when on?
(let ([ctx (tell NSGraphicsContext currentContext)])
(tellv ctx saveGraphicsState)
(NSSetFocusRingStyle 0)
(let ([r (tell #:type _NSRect self bounds)])
(NSRectFill (make-NSRect (make-NSPoint
(+ (NSPoint-x (NSRect-origin r)) 2)
(+ (NSPoint-y (NSRect-origin r)) 2))
(make-NSSize
(- (NSSize-width (NSRect-size r)) 4)
(- (NSSize-height (NSRect-size r)) 4)))))
(tellv ctx restoreGraphicsState)))))
(define-objc-class MyComboBox NSComboBox
#:mixins (FocusResponder KeyMouseTextResponder CursorDisplayer)
#:protocols (NSComboBoxDelegate)
[wxb]
(-a _void (drawRect: [_NSRect r])
(super-tell #:type _void drawRect: #:type _NSRect r)
(let ([wx (->wx wxb)])
(when wx
(unless (send wx paint-or-queue-paint)
(unless (send wx during-menu-click?)
(clear-background wxb)
;; ensure that `nextEventMatchingMask:' returns
(post-dummy-event))))))
(-a _void (comboBoxWillPopUp: [_id notification])
(let ([wx (->wx wxb)])
(when wx
(send wx starting-combo))))
(-a _void (comboBoxWillDismiss: [_id notification])
(let ([wx (->wx wxb)])
(when wx
(send wx ending-combo))))
(-a _void (viewWillMoveToWindow: [_id w])
(when wxb
(let ([wx (->wx wxb)])
(when wx
(queue-window-event wx (lambda () (send wx fix-dc))))))))
(define NSOpenGLPFADoubleBuffer 5)
(define NSOpenGLPFAStereo 6)
(define NSOpenGLPFAColorSize 8)
(define NSOpenGLPFAAlphaSize 11)
(define NSOpenGLPFADepthSize 12)
(define NSOpenGLPFAStencilSize 13)
(define NSOpenGLPFAAccumSize 14)
(define NSOpenGLPFAOffScreen 53)
(define NSOpenGLPFASampleBuffers 55)
(define NSOpenGLPFASamples 56)
(define NSOpenGLPFAMultisample 59)
(define (gl-config->pixel-format conf)
(let ([conf (or conf (new gl-config%))])
(tell (tell NSOpenGLPixelFormat alloc)
initWithAttributes: #:type (_list i _int)
(append
(if (send conf get-double-buffered) (list NSOpenGLPFADoubleBuffer) null)
(if (send conf get-stereo) (list NSOpenGLPFAStereo) null)
(list
NSOpenGLPFADepthSize (send conf get-depth-size)
NSOpenGLPFAStencilSize (send conf get-stencil-size)
NSOpenGLPFAAccumSize (send conf get-accum-size))
(let ([ms (send conf get-multisample-size)])
(if (zero? ms)
null
(list NSOpenGLPFAMultisample
NSOpenGLPFASampleBuffers 1
NSOpenGLPFASamples ms)))
(list 0)))))
(define-struct scroller (cocoa [range #:mutable] [page #:mutable]))
(define scroll-width (tell #:type _CGFloat NSScroller scrollerWidth))
(define canvas%
(canvas-mixin
(class (canvas-autoscroll-mixin window%)
(init parent
x y w h
style
[ignored-name #f]
[gl-config #f])
(inherit get-cocoa get-cocoa-window
get-eventspace
make-graphics-context
is-shown-to-root?
is-shown-to-before-root?
is-enabled-to-root?
is-window-enabled?
block-mouse-events
move get-x get-y
on-size
register-as-child
get-size get-position
set-focus
client-to-screen
is-auto-scroll? get-virtual-width get-virtual-height
reset-auto-scroll
refresh-for-autoscroll)
(define vscroll-ok? (and (memq 'vscroll style) #t))
(define vscroll? vscroll-ok?)
(define hscroll-ok? (and (memq 'hscroll style) #t))
(define hscroll? hscroll-ok?)
(define wants-focus? (not (memq 'no-focus style)))
(define is-combo? (memq 'combo style))
(define has-control-border? (and (not is-combo?)
(memq 'control-border style)))
(define-values (x-margin y-margin x-sb-margin y-sb-margin)
(cond
[has-control-border? (values 3 3 3 3)]
[(memq 'border style) (values 1 1 0 0)]
[else (values 0 0 0 0)]))
(define canvas-style style)
(define/override (focus-is-on on?)
(when has-control-border?
(tellv cocoa setFocusState: #:type _BOOL on?)
(tellv cocoa setNeedsDisplay: #:type _BOOL #t))
(super focus-is-on on?))
;; The `queue-paint' and `paint-children' methods
;; are defined by `canvas-mixin' from ../common/canvas-mixin
(define/public (queue-paint) (void))
(define/public (request-canvas-flush-delay)
(unless is-gl?
(request-flush-delay (get-cocoa-window))))
(define/public (cancel-canvas-flush-delay req)
(unless is-gl?
(cancel-flush-delay req)))
(define/public (queue-canvas-refresh-event thunk)
(queue-window-refresh-event this thunk))
(define/public (paint-or-queue-paint)
(or (do-canvas-backing-flush #f)
(begin
(queue-paint)
#f)))
(define/public (do-canvas-backing-flush ctx)
(do-backing-flush this dc (tell NSGraphicsContext currentContext)
(if is-combo? 2 0) (if is-combo? 2 0)))
;; not used, because Cocoa canvas refreshes do not go through
;; the eventspace queue:
(define/public (schedule-periodic-backing-flush)
(void))
(define/public (begin-refresh-sequence)
(send dc suspend-flush))
(define/public (end-refresh-sequence)
(send dc resume-flush))
(define/public (get-flush-window)
(get-cocoa-window))
(define/override (refresh)
;; can be called from any thread, including the event-pump thread
(queue-paint))
(define/public (queue-backing-flush)
;; called atomically (not expecting exceptions)
(tellv content-cocoa setNeedsDisplay: #:type _BOOL #t))
(define/override (get-cocoa-content) content-cocoa)
(define is-gl? (and (not is-combo?) (memq 'gl style)))
(define/public (can-gl?) is-gl?)
(super-new
[parent parent]
[cocoa
(as-objc-allocation
(tell (tell (cond
[is-combo? NSView]
[has-control-border? FocusView]
[(memq 'border style) (if (memq 'vscroll style)
CornerlessFrameView
FrameView)]
[else NSView])
alloc)
initWithFrame: #:type _NSRect (make-NSRect (make-init-point x y)
(make-NSSize (max w (* 2 x-margin))
(max h (* 2 y-margin))))))]
[no-show? (memq 'deleted style)])
(define cocoa (get-cocoa))
(define content-cocoa
(let ([r (make-NSRect (make-NSPoint 0 0)
(make-NSSize (max 0 (- w (* 2 x-margin)))
(max 0 (- h (* 2 y-margin)))))])
(as-objc-allocation
(if (or is-combo? (not (memq 'gl style)))
(tell (tell (if is-combo? MyComboBox MyView) alloc)
initWithFrame: #:type _NSRect r)
(let ([pf (gl-config->pixel-format gl-config)])
(begin0
(tell (tell MyGLView alloc)
initWithFrame: #:type _NSRect r
pixelFormat: pf)
(tellv pf release)))))))
(tell #:type _void cocoa addSubview: content-cocoa)
(set-ivar! content-cocoa wxb (->wxb this))
(when is-combo?
(tellv content-cocoa setEditable: #:type _BOOL #f)
(tellv content-cocoa setDelegate: content-cocoa)
(install-control-font content-cocoa #f))
(define dc (make-object dc% this))
(send dc start-backing-retained)
(queue-paint)
(define/public (get-dc) dc)
(define/public (make-compatible-bitmap w h)
(make-object quartz-bitmap% w h))
(define/override (fix-dc [refresh? #t])
(when (dc . is-a? . dc%)
(send dc reset-backing-retained)
(send dc set-auto-scroll
(if (is-auto-scroll?) (scroll-pos h-scroller) 0)
(if (is-auto-scroll?) (scroll-pos v-scroller) 0)))
(when refresh? (refresh)))
(define/override (get-client-size xb yb)
(super get-client-size xb yb)
(when is-combo?
(set-box! yb (max 0 (- (unbox yb) 5)))))
(define/override (maybe-register-as-child parent on?)
(register-as-child parent on?))
(define/public (on-paint) (void))
(define/override (set-size x y w h)
(do-set-size x y w h))
(define tr 0)
(define/override (show on?)
;; FIXME: what if we're in the middle of an on-paint?
(super show on?)
(fix-dc))
(define/override (hide-children)
(super hide-children)
(suspend-all-reg-blits))
(define/override (show-children)
(super show-children)
(resume-all-reg-blits))
(define/override (fixup-locations-children)
;; in atomic mode
(suspend-all-reg-blits)
(resume-all-reg-blits))
(define/private (do-set-size x y w h)
(when (pair? blits)
(atomically (suspend-all-reg-blits)))
(super set-size x y w h)
(when tr
(tellv content-cocoa removeTrackingRect: #:type _NSInteger tr)
(set! tr #f))
(let ([sz (make-NSSize (- w (if vscroll? scroll-width 0) x-margin x-margin)
(- h (if hscroll? scroll-width 0) y-margin y-margin))]
[pos (make-NSPoint x-margin (+ (if hscroll? scroll-width 0) y-margin))])
(tellv content-cocoa setFrame: #:type _NSRect (make-NSRect pos sz))
(set! tr (tell #:type _NSInteger
content-cocoa
addTrackingRect: #:type _NSRect (make-NSRect (make-NSPoint x-margin y-margin) sz)
owner: content-cocoa
userData: #f
assumeInside: #:type _BOOL #f)))
(when v-scroller
(tellv (scroller-cocoa v-scroller) setFrame: #:type _NSRect
(make-NSRect
(make-NSPoint (- w scroll-width x-sb-margin)
(+ (if hscroll?
scroll-width
0)
y-sb-margin))
(make-NSSize scroll-width
(max 0 (- h (if hscroll? scroll-width 0)
x-sb-margin x-sb-margin))))))
(when h-scroller
(tellv (scroller-cocoa h-scroller) setFrame: #:type _NSRect
(make-NSRect
(make-NSPoint x-sb-margin y-sb-margin)
(make-NSSize (max 0 (- w (if vscroll? scroll-width 0)
x-sb-margin x-sb-margin))
scroll-width))))
(when (and (pair? blits)
(is-shown-to-root?))
(atomically (resume-all-reg-blits)))
(fix-dc)
(when (is-auto-scroll?)
(reset-auto-scroll 0 0))
(on-size 0 0))
(define/public (show-scrollbars h? v?)
(let ([h? (and h? hscroll-ok?)]
[v? (and v? vscroll-ok?)])
(unless (and (eq? h? hscroll?)
(eq? v? vscroll?))
(cond
[(and h? (not hscroll?))
(tell #:type _void cocoa addSubview: (scroller-cocoa h-scroller))]
[(and hscroll? (not h?))
(tell #:type _void (scroller-cocoa h-scroller) removeFromSuperview)])
(set! hscroll? h?)
(cond
[(and v? (not vscroll?))
(tell #:type _void cocoa addSubview: (scroller-cocoa v-scroller))]
[(and vscroll? (not v?))
(tell #:type _void (scroller-cocoa v-scroller) removeFromSuperview)])
(set! vscroll? v?)
(let ([x (box 0)] [y (box 0)] [w (box 0)] [h (box 0)])
(get-position x y)
(get-size w h)
(do-set-size (unbox x) (unbox y) (unbox w) (unbox h))))))
(define/override (do-set-scrollbars h-step v-step
h-len v-len
h-page v-page
h-pos v-pos)
(scroll-range h-scroller h-len)
(scroll-page h-scroller h-page)
(scroll-pos h-scroller h-pos)
(when h-scroller
(tellv (scroller-cocoa h-scroller) setEnabled: #:type _BOOL (and h-step (positive? h-len))))
(scroll-range v-scroller v-len)
(scroll-page v-scroller v-page)
(scroll-pos v-scroller v-pos)
(when v-scroller
(tellv (scroller-cocoa v-scroller) setEnabled: #:type _BOOL (and v-step (positive? v-len)))))
(define/override (reset-dc-for-autoscroll)
(fix-dc))
(define/private (update which scroll- v)
(if (eq? which 'vertical)
(scroll- v-scroller v)
(scroll- h-scroller v)))
(define/public (set-scroll-page which v)
(update which scroll-page v))
(define/public (set-scroll-range which v)
(update which scroll-range v))
(define/public (set-scroll-pos which v)
(update which scroll-pos v))
(define/private (guard-scroll which v)
(if (is-auto-scroll?)
0
v))
(define/public (get-scroll-page which)
(guard-scroll which
(scroll-page (if (eq? which 'vertical) v-scroller h-scroller))))
(define/public (get-scroll-range which)
(guard-scroll which
(scroll-range (if (eq? which 'vertical) v-scroller h-scroller))))
(define/public (get-scroll-pos which)
(guard-scroll which
(scroll-pos (if (eq? which 'vertical) v-scroller h-scroller))))
(define v-scroller
(and vscroll-ok?
(make-scroller
(as-objc-allocation
(tell (tell NSScroller alloc) initWithFrame:
#:type _NSRect (make-NSRect
(make-NSPoint (- w scroll-width x-sb-margin)
(+ (if hscroll?
scroll-width
0)
y-sb-margin))
(make-NSSize scroll-width
(max (- h (if hscroll? scroll-width 0)
y-sb-margin y-sb-margin)
(+ scroll-width 10))))))
1
1)))
(define h-scroller
(and hscroll-ok?
(make-scroller
(as-objc-allocation
(tell (tell NSScroller alloc) initWithFrame:
#:type _NSRect (make-NSRect
(make-NSPoint x-sb-margin y-sb-margin)
(make-NSSize (max (- w (if vscroll? scroll-width 0)
x-sb-margin x-sb-margin)
(+ scroll-width 10))
scroll-width))))
1
1)))
(when v-scroller
(tell #:type _void cocoa addSubview: (scroller-cocoa v-scroller))
(tellv (scroller-cocoa v-scroller) setTarget: content-cocoa)
(tellv (scroller-cocoa v-scroller) setAction: #:type _SEL (selector onVScroll:)))
(when h-scroller
(tell #:type _void cocoa addSubview: (scroller-cocoa h-scroller))
(tellv (scroller-cocoa h-scroller) setTarget: content-cocoa)
(tellv (scroller-cocoa h-scroller) setAction: #:type _SEL (selector onHScroll:)))
(define scroll-pos
(case-lambda
[(scroller val)
(when scroller
(tellv (scroller-cocoa scroller) setFloatValue:
#:type _float (max (min 1.0 (/ val (exact->inexact (scroller-range scroller))))
0.0)))]
[(scroller)
(if scroller
(->long (round (* (tell #:type _float (scroller-cocoa scroller) floatValue)
(scroller-range scroller))))
0)]))
(define scroll-range
(case-lambda
[(scroller val)
(when scroller
(let ([pos (scroll-pos scroller)]
[page (scroll-page scroller)])
(set-scroller-range! scroller val)
(tell (scroller-cocoa scroller) setEnabled: #:type _BOOL (positive? val))
(scroll-pos scroller pos)
(scroll-page scroller page)))]
[(scroller)
(if scroller
(scroller-range scroller)
1)]))
(define scroll-page
(case-lambda
[(scroller val)
(when scroller
(set-scroller-page! scroller val)
(let ([proportion
(max (min 1.0 (/ val
(+ val (exact->inexact (scroller-range scroller)))))
0.0)])
(if old-cocoa?
(tellv (scroller-cocoa scroller)
setFloatValue: #:type _float (tell #:type _float (scroller-cocoa scroller)
floatValue)
knobProportion: #:type _CGFloat proportion)
(tellv (scroller-cocoa scroller) setKnobProportion:
#:type _CGFloat proportion))))]
[(scroller)
(if scroller
(scroller-page scroller)
1)]))
(define/override (enable-window on?)
;; in atomic mode
(let ([on? (and on? (is-window-enabled?))])
(let ([w (tell content-cocoa window)])
(when (ptr-equal? content-cocoa (tell w firstResponder))
(tellv w makeFirstResponder: #f)))
(block-mouse-events (not on?))
(when is-combo?
(tellv content-cocoa setEnabled: #:type _BOOL on?))))
(define/public (clear-combo-items)
(tellv content-cocoa removeAllItems))
(define/public (append-combo-item str)
(tellv content-cocoa addItemWithObjectValue: #:type _NSString str)
#t)
(define/public (on-combo-select i) (void))
(define clear-bg? (and (not (memq 'transparent canvas-style))
(not (memq 'no-autoclear canvas-style))))
(define bg-col (make-object color% "white"))
(define/public (get-canvas-background) (if (memq 'transparent canvas-style)
#f
bg-col))
(define/public (set-canvas-background col) (set! bg-col col))
(define/public (get-canvas-background-for-backing) (and clear-bg? bg-col))
(define/public (get-canvas-background-for-clearing)
(and clear-bg?
bg-col))
(define/public (reject-partial-update r)
;; Called in the event-pump thread.
;; A transparent canvas cannot handle a partial update.
(and (or
;; Multiple clipping rects?
(let ([i (malloc _NSInteger)]
[r (malloc 'atomic _pointer)])
(tellv content-cocoa getRectsBeingDrawn: #:type _pointer r
count: #:type _pointer i)
((ptr-ref i _NSInteger) . > . 1))
;; Single clipping not whole area?
(let ([s1 (NSRect-size (tell #:type _NSRect content-cocoa frame))]
[s2 (NSRect-size r)])
(or ((NSSize-width s2) . < . (NSSize-width s1))
((NSSize-height s2) . < . (NSSize-height s1)))))
(begin
(queue-window-event this (lambda () (refresh)))
#t)))
(define/public (do-scroll direction scroller)
;; Called from the Cocoa handler thread
(let ([part (tell #:type _int scroller hitPart)])
(queue-window-event
this
(lambda ()
(let ([kind
(cond
[(= part NSScrollerDecrementPage)
(set-scroll-pos direction (- (get-scroll-pos direction)
(get-scroll-page direction)))
'page-up]
[(= part NSScrollerIncrementPage)
(set-scroll-pos direction (+ (get-scroll-pos direction)
(get-scroll-page direction)))
'page-down]
[(= part NSScrollerDecrementLine)
(set-scroll-pos direction (- (get-scroll-pos direction) 1))
'line-up]
[(= part NSScrollerIncrementLine)
(set-scroll-pos direction (+ (get-scroll-pos direction) 1))
'line-down]
[(= part NSScrollerKnob)
'thumb]
[else #f])])
(when kind
(if (is-auto-scroll?)
(refresh-for-autoscroll)
(on-scroll (new scroll-event%
[event-type kind]
[direction direction]
[position (get-scroll-pos direction)]))))))))
(constrained-reply (get-eventspace)
(lambda ()
(let loop () (pre-event-sync #t) (when (yield) (loop))))
(void)))
(define/public (on-scroll e) (void))
(define/override (definitely-wants-event? e)
;; Called in Cocoa event-handling mode
(when (and wants-focus?
(e . is-a? . mouse-event%)
(send e button-down? 'left))
(set-focus))
(or (not is-combo?)
(e . is-a? . key-event%)
(not (send e button-down? 'left))
(not (on-menu-click? e))))
(define/override (gets-focus?)
wants-focus?)
(define/override (can-be-responder?)
(and wants-focus? (is-enabled-to-root?)))
(define/private (on-menu-click? e)
;; Called in Cocoa event-handling mode
(let ([xb (box 0)]
[yb (box 0)])
(get-client-size xb yb)
((send e get-x) . > . (- (unbox xb) 22))))
(define/public (on-popup) (void))
(define/public (starting-combo)
(set! in-menu-click? #t)
(tellv content-cocoa setStringValue: #:type _NSString current-text)
(constrained-reply (get-eventspace)
(lambda () (on-popup))
(void)))
(define/public (ending-combo)
(set! in-menu-click? #f)
(let ([pos (tell #:type _NSInteger content-cocoa indexOfSelectedItem)])
(when (pos . > . -1)
(queue-window-event this (lambda () (on-combo-select pos)))))
(refresh))
(define current-text "")
(define/public (set-combo-text t)
(set! current-text t))
(define in-menu-click? #f)
(define/public (during-menu-click?)
;; Called in Cocoa event-handling mode
in-menu-click?)
(define/public (scroll x y)
(when (is-auto-scroll?)
(when (x . >= . 0) (scroll-pos h-scroller (floor (* x (scroll-range h-scroller)))))
(when (y . >= . 0) (scroll-pos v-scroller (floor (* y (scroll-range v-scroller)))))
(refresh-for-autoscroll)))
(define/public (warp-pointer x y) (void))
(define/override (get-virtual-h-pos)
(scroll-pos h-scroller))
(define/override (get-virtual-v-pos)
(scroll-pos v-scroller))
(define/public (set-resize-corner on?)
(void))
(define/public (get-backing-size xb yb)
(get-client-size xb yb)
(when is-combo?
(set-box! xb (- (unbox xb) 22))))
(define/override (get-cursor-width-delta)
(if is-combo? 22 0))
(define/public (is-flipped?)
(tell #:type _BOOL (get-cocoa-content) isFlipped))
(define blits null)
(define reg-blits null)
(define/private (suspend-all-reg-blits)
(let ([cocoa-win (get-cocoa-window)])
(for ([r (in-list reg-blits)])
(tellv cocoa-win removeChildWindow: (car r))
(release (car r))
(scheme_remove_gc_callback (cdr r))))
(set! reg-blits null))
(define/public (resume-all-reg-blits)
(unless (pair? reg-blits)
(when (pair? blits)
(set! reg-blits
(for/list ([b (in-list blits)])
(let-values ([(x y w h img) (apply values b)])
(register-one-blit x y w h img)))))))
(define/private (register-one-blit x y w h img)
(let ([xb (box x)]
[yb (box y)])
(client-to-screen xb yb #f)
(let* ([cocoa-win (get-cocoa-window)])
(atomically
(let ([win (as-objc-allocation
(tell (tell NSWindow alloc)
initWithContentRect: #:type _NSRect (make-NSRect (make-NSPoint (unbox xb)
(- (unbox yb)
h))
(make-NSSize w h))
styleMask: #:type _int NSBorderlessWindowMask
backing: #:type _int NSBackingStoreBuffered
defer: #:type _BOOL NO))]
[iv (tell (tell NSImageView alloc) init)])
(tellv iv setImage: img)
(tellv iv setFrame: #:type _NSRect (make-NSRect (make-NSPoint 0 0)
(make-NSSize w h)))
(tellv (tell win contentView) addSubview: iv)
(tellv win setAlphaValue: #:type _CGFloat 0.0)
(tellv cocoa-win addChildWindow: win ordered: #:type _int NSWindowAbove)
(tellv iv release)
(let ([r (scheme_add_gc_callback
(make-gc-action-desc win (selector setAlphaValue:) 1.0)
(make-gc-action-desc win (selector setAlphaValue:) 0.0))])
(cons win r)))))))
(define/public (register-collecting-blit x y w h on off on-x on-y off-x off-y)
(let ([on (fix-bitmap-size on w h on-x on-y)])
(let ([img (bitmap->image on)])
(atomically
(set! blits (cons (list x y w h img) blits))
(when (is-shown-to-root?)
(set! reg-blits (cons (register-one-blit x y w h img) reg-blits)))))))
(define/public (unregister-collecting-blits)
(atomically
(suspend-all-reg-blits)
(set! blits null))))))

21
collects/mred/private/wx/cocoa/cg.rkt Normal file
View File

@ -0,0 +1,21 @@
#lang racket/base
(require ffi/unsafe
ffi/unsafe/objc
"types.rkt"
"utils.rkt")
(provide (protect-out (all-defined-out)))
(define _CGContextRef (_cpointer 'CGContextRef))
(define-appserv CGContextSynchronize (_fun _CGContextRef -> _void))
(define-appserv CGContextFlush (_fun _CGContextRef -> _void))
(define-appserv CGContextTranslateCTM (_fun _CGContextRef _CGFloat _CGFloat -> _void))
(define-appserv CGContextScaleCTM (_fun _CGContextRef _CGFloat _CGFloat -> _void))
(define-appserv CGContextRotateCTM (_fun _CGContextRef _CGFloat -> _void))
(define-appserv CGContextSaveGState (_fun _CGContextRef -> _void))
(define-appserv CGContextRestoreGState (_fun _CGContextRef -> _void))
(define-appserv CGContextSetRGBFillColor (_fun _CGContextRef _CGFloat _CGFloat _CGFloat _CGFloat -> _void))
(define-appserv CGContextFillRect (_fun _CGContextRef _NSRect -> _void))
(define-appserv CGContextAddRect (_fun _CGContextRef _NSRect -> _void))
(define-appserv CGContextAddLines (_fun _CGContextRef (v : (_vector i _NSPoint)) (_long = (vector-length v)) -> _void))
(define-appserv CGContextStrokePath (_fun _CGContextRef -> _void))

24
collects/mred/private/wx/cocoa/check-box.rkt Normal file
View File

@ -0,0 +1,24 @@
#lang racket/base
(require ffi/unsafe/objc
ffi/unsafe
racket/class
"../../syntax.rkt"
"button.rkt"
"types.rkt"
"const.rkt")
(provide
(protect-out check-box%))
;; ----------------------------------------
(defclass check-box% core-button%
(inherit get-cocoa)
(super-new [button-type NSSwitchButton]
[event-type 'check-box])
(define/public (set-value v)
(tellv (get-cocoa) setState: #:type _NSInteger (if v 1 0)))
(define/public (get-value)
(positive? (tell #:type _NSInteger (get-cocoa) state))))

73
collects/mred/private/wx/cocoa/choice.rkt Normal file
View File

@ -0,0 +1,73 @@
#lang racket/base
(require racket/class
ffi/unsafe
ffi/unsafe/objc
"../../syntax.rkt"
"item.rkt"
"types.rkt"
"const.rkt"
"utils.rkt"
"window.rkt"
"../common/event.rkt")
(provide
(protect-out choice%))
;; ----------------------------------------
(import-class NSPopUpButton)
(define-objc-class MyPopUpButton NSPopUpButton
#:mixins (FocusResponder KeyMouseResponder CursorDisplayer)
[wxb]
(-a _void (clicked: [_id sender])
(queue-window*-event wxb (lambda (wx) (send wx clicked)))))
(defclass choice% item%
(init parent cb label
x y w h
choices style font)
(inherit get-cocoa init-font register-as-child)
(super-new [parent parent]
[cocoa
(let ([cocoa
(as-objc-allocation
(tell (tell MyPopUpButton alloc)
initWithFrame: #:type _NSRect (make-NSRect (make-init-point x y)
(make-NSSize w h))
pullsDown: #:type _BOOL #f))])
(for ([lbl (in-list choices)]
[i (in-naturals)])
(tellv cocoa
insertItemWithTitle: #:type _NSString lbl
atIndex: #:type _NSInteger i))
(init-font cocoa font)
(tellv cocoa sizeToFit)
(tellv cocoa setTarget: cocoa)
(tellv cocoa setAction: #:type _SEL (selector clicked:))
cocoa)]
[callback cb]
[no-show? (memq 'deleted style)])
(define callback cb)
(define/public (clicked)
(callback this (new control-event%
[event-type 'choice]
[time-stamp (current-milliseconds)])))
(define/public (set-selection i)
(tellv (get-cocoa) selectItemAtIndex: #:type _NSInteger i))
(define/public (get-selection)
(tell #:type _NSInteger (get-cocoa) indexOfSelectedItem))
(define/public (number)
(tell #:type _NSInteger (get-cocoa) numberOfItems))
(define/public (clear)
(tellv (get-cocoa) removeAllItems))
(define/public (append lbl)
(tellv (get-cocoa)
insertItemWithTitle: #:type _NSString lbl
atIndex: #:type _NSInteger (number)))
(define/override (maybe-register-as-child parent on?)
(register-as-child parent on?)))

98
collects/mred/private/wx/cocoa/clipboard.rkt Normal file
View File

@ -0,0 +1,98 @@
#lang racket/base
(require racket/class
ffi/unsafe
ffi/unsafe/objc
"utils.rkt"
"types.rkt"
"image.rkt"
racket/draw/unsafe/bstr
"../../syntax.rkt"
"../../lock.rkt")
(provide
(protect-out clipboard-driver%
has-x-selection?))
(import-class NSPasteboard NSArray NSData NSImage NSGraphicsContext)
(import-protocol NSPasteboardOwner)
(define (has-x-selection?) #f)
(define (map-type s)
(cond
[(string=? s "TEXT") "public.utf8-plain-text"]
[else (string-append "org.racket-lang." s)]))
(define (unmap-type s)
(cond
[(string=? s "public.utf8-plain-text") "TEXT"]
[(regexp-match #rx"^org[.]racket-lang[.](.*)$" s)
=> (lambda (m) (cadr m))]
[else s]))
(defclass clipboard-driver% object%
(init x-selection?) ; always #f
(super-new)
(define client #f)
(define counter -1)
(define/public (clear-client)
;; called in event-pump thread
(set! client #f))
(define/public (get-client)
(and client
(let ([c (tell #:type _NSInteger (tell NSPasteboard generalPasteboard)
changeCount)])
(if (= c counter)
client
(begin
(set! client #f)
#f)))))
(define/public (set-client c types)
(atomically
(with-autorelease
(let ([pb (tell NSPasteboard generalPasteboard)]
[a (tell NSArray arrayWithObjects:
#:type (_list i _NSString) (map map-type types)
count: #:type _NSUInteger (length types))])
(set! counter (tell #:type _NSInteger pb
declareTypes: a
owner: #f))
(set! client c)
(for ([type (in-list types)])
(let* ([bstr (send c get-data type)]
[data (tell NSData
dataWithBytes: #:type _bytes bstr
length: #:type _NSUInteger (bytes-length bstr))])
(tellv (tell NSPasteboard generalPasteboard)
setData: data
forType: #:type _NSString (map-type type))))))))
(define/public (get-data-for-type type)
(log-error "didn't expect clipboard data request"))
(define/public (get-text-data)
(let ([bstr (get-data "TEXT")])
(and bstr
(bytes->string/utf-8 bstr #\?))))
(define/public (get-data type)
(atomically
(with-autorelease
(let* ([pb (tell NSPasteboard generalPasteboard)]
[data (tell pb dataForType: #:type _NSString (map-type type))])
(and data
(let ([len (tell #:type _NSUInteger data length)]
[bstr (tell #:type _pointer data bytes)])
(scheme_make_sized_byte_string bstr len 1)))))))
(define/public (get-bitmap-data)
(atomically
(with-autorelease
(let ([i (tell (tell NSImage alloc)
initWithPasteboard: (tell NSPasteboard generalPasteboard))])
(and i
(image->bitmap i)))))))

44
collects/mred/private/wx/cocoa/colordialog.rkt Normal file
View File

@ -0,0 +1,44 @@
#lang racket/base
(require ffi/unsafe
ffi/unsafe/objc
racket/class
racket/draw/private/color
"../../lock.rkt"
"utils.rkt"
"types.rkt")
(provide
(protect-out get-color-from-user))
(import-class NSColorPanel
NSColor)
(define-cocoa NSDeviceRGBColorSpace _id)
(define (get-color-from-user mode)
(cond
[(eq? mode 'show)
(tellv (tell NSColorPanel sharedColorPanel)
orderFront: #f)]
[(eq? mode 'get)
(atomically
(let ([c (tell (tell (tell NSColorPanel sharedColorPanel) color)
colorUsingColorSpaceName: NSDeviceRGBColorSpace)]
[as-color (lambda (v)
(inexact->exact (floor (* 255.0 v))))])
(make-object color%
(as-color
(tell #:type _CGFloat c redComponent))
(as-color
(tell #:type _CGFloat c greenComponent))
(as-color
(tell #:type _CGFloat c blueComponent)))))]
[else
(let ([p (tell NSColorPanel sharedColorPanel)]
[color mode])
(atomically
(tellv p setColor: (tell NSColor
colorWithDeviceRed: #:type _CGFloat (/ (color-red color) 255.0)
green: #:type _CGFloat (/ (color-green color) 255.0)
blue: #:type _CGFloat (/ (color-blue color) 255.0)
alpha: #:type _CGFloat 1.0))))]))

126
collects/mred/private/wx/cocoa/const.rkt Normal file
View File

@ -0,0 +1,126 @@
#lang racket/base
(provide (except-out (all-defined-out) <<))
(define (<< a b) (arithmetic-shift a b))
(define NSTitledWindowMask 1)
(define NSBorderlessWindowMask 0)
(define NSClosableWindowMask 2)
(define NSMiniaturizableWindowMask 4)
(define NSResizableWindowMask 8)
(define NSUtilityWindowMask (1 . << . 4))
(define NSTexturedBackgroundWindowMask 256)
(define NSBackingStoreBuffered 2)
(define NSRoundedBezelStyle 1)
(define NSRegularSquareBezelStyle 2)
(define NSAnyEventMask #xffffffff)
(define NSLeftMouseDown 1)
(define NSLeftMouseUp 2)
(define NSRightMouseDown 3)
(define NSRightMouseUp 4)
(define NSMouseMoved 5)
(define NSLeftMouseDragged 6)
(define NSRightMouseDragged 7)
(define NSMouseEntered 8)
(define NSMouseExited 9)
(define NSKeyDown 10)
(define NSKeyUp 11)
(define NSFlagsChanged 12)
(define NSAppKitDefined 13)
(define NSSystemDefined 14)
(define NSApplicationDefined 15)
(define NSPeriodic 16)
(define NSCursorUpdate 17)
(define NSScrollWheel 22)
(define NSTabletPoint 23)
(define NSTabletProximity 24)
(define NSOtherMouseDown 25)
(define NSOtherMouseUp 26)
(define NSOtherMouseDragged 27)
(define NSEventTypeGesture 29)
(define NSEventTypeMagnify 30)
(define NSEventTypeSwipe 31)
(define NSEventTypeRotate 18)
(define NSEventTypeBeginGesture 19)
(define NSEventTypeEndGesture 20)
(define MouseAndKeyEventMask
(bitwise-ior
(1 . << . NSLeftMouseDown)
(1 . << . NSLeftMouseUp)
(1 . << . NSRightMouseDown)
(1 . << . NSRightMouseUp)
(1 . << . NSMouseMoved)
(1 . << . NSLeftMouseDragged)
(1 . << . NSRightMouseDragged)
(1 . << . NSMouseEntered)
(1 . << . NSMouseExited)
(1 . << . NSKeyDown)
(1 . << . NSKeyUp)
(1 . << . NSScrollWheel)
(1 . << . NSTabletPoint)
(1 . << . NSTabletProximity)
(1 . << . NSOtherMouseDown)
(1 . << . NSOtherMouseUp)
(1 . << . NSOtherMouseDragged)
(1 . << . NSEventTypeGesture)
(1 . << . NSEventTypeMagnify)
(1 . << . NSEventTypeSwipe)
(1 . << . NSEventTypeRotate)
(1 . << . NSEventTypeBeginGesture)
(1 . << . NSEventTypeEndGesture)))
(define NSAlphaShiftKeyMask (1 . << . 16))
(define NSShiftKeyMask (1 . << . 17))
(define NSControlKeyMask (1 . << . 18))
(define NSAlternateKeyMask (1 . << . 19))
(define NSCommandKeyMask (1 . << . 20))
(define NSNumericPadKeyMask (1 . << . 21))
(define NSHelpKeyMask (1 . << . 22))
(define NSFunctionKeyMask (1 . << . 23))
(define NSScrollerNoPart 0)
(define NSScrollerDecrementPage 1)
(define NSScrollerKnob 2)
(define NSScrollerIncrementPage 3)
(define NSScrollerDecrementLine 4)
(define NSScrollerIncrementLine 5)
(define NSScrollerKnobSlot 6)
(define NSMomentaryLightButton 0)
(define NSPushOnPushOffButton 1)
(define NSToggleButton 2)
(define NSSwitchButton 3)
(define NSRadioButton 4)
(define NSMomentaryChangeButton 5)
(define NSOnOffButton 6)
(define NSMomentaryPushInButton 7)
(define NSMomentaryPushButton 0)
(define NSMomentaryLight 7)
(define NSFocusRingTypeDefault 0)
(define NSFocusRingTypeNone 1)
(define NSFocusRingTypeExterior 2)
(define kCGBitmapAlphaInfoMask #x1F)
(define kCGBitmapFloatComponents (1 . << . 8))
(define kCGBitmapByteOrderMask #x7000)
(define kCGBitmapByteOrderDefault (0 . << . 12))
(define kCGBitmapByteOrder16Little (1 . << . 12))
(define kCGBitmapByteOrder32Little (2 . << . 12))
(define kCGBitmapByteOrder16Big (3 . << . 12))
(define kCGBitmapByteOrder32Big (4 . << . 12))
(define kCGImageAlphaNone 0)
(define kCGImageAlphaPremultipliedLast 1)
(define kCGImageAlphaPremultipliedFirst 2)
(define kCGImageAlphaLast 3)
(define kCGImageAlphaFirst 4)
(define kCGImageAlphaNoneSkipLast 5)
(define kCGImageAlphaNoneSkipFirst 6)

87
collects/mred/private/wx/cocoa/cursor.rkt Normal file
View File

@ -0,0 +1,87 @@
#lang racket/base
(require ffi/unsafe
ffi/unsafe/objc
racket/class
racket/draw
"image.rkt"
"types.rkt"
"utils.rkt"
"../common/cursor-draw.rkt"
"../common/local.rkt")
(provide
(protect-out cursor-driver%
arrow-cursor-handle
get-wait-cursor-handle))
(import-class NSCursor)
(define wait #f)
(define bullseye #f)
(define blank #f)
(define size-ne/sw #f)
(define size-nw/se #f)
(define-syntax-rule (image-cursor id draw-proc)
(or id
(begin
(set! id (make-image-cursor draw-proc))
id)))
(define (make-image-cursor draw-proc)
(let* ([bm (make-cursor-image draw-proc)])
(let ([image (bitmap->image bm)])
(tell (tell NSCursor alloc)
initWithImage: image
hotSpot: #:type _NSPoint (make-NSPoint 8 8)))))
(define arrow-cursor-handle (tell NSCursor arrowCursor))
(define (get-wait-cursor-handle)
(image-cursor wait draw-watch))
(define cursor-driver%
(class object%
(define handle #f)
(define/public (set-standard sym)
(case sym
[(arrow)
(set! handle arrow-cursor-handle)]
[(cross)
(set! handle (tell NSCursor crosshairCursor))]
[(hand)
(set! handle (tell NSCursor openHandCursor))]
[(ibeam)
(set! handle (tell NSCursor IBeamCursor))]
[(size-n/s)
(set! handle (tell NSCursor resizeUpDownCursor))]
[(size-e/w)
(set! handle (tell NSCursor resizeLeftRightCursor))]
[(size-nw/se)
(set! handle (image-cursor size-nw/se draw-nw/se))]
[(size-ne/sw)
(set! handle (image-cursor size-ne/sw draw-ne/sw))]
[(watch)
(set! handle (get-wait-cursor-handle))]
[(bullseye)
(set! handle (image-cursor bullseye draw-bullseye))]
[(blank)
(set! handle (image-cursor blank void))]))
(define/public (set-image image mask hot-spot-x hot-spot-y)
(let ([bm (make-object bitmap% 16 16 #f #t)])
(let ([dc (make-object bitmap-dc% bm)])
(send dc draw-bitmap image 0 0 'solid (send the-color-database find-color "black") mask)
(send dc set-bitmap #f))
(let ([image (bitmap->image bm)])
(set! handle
(as-objc-allocation
(tell (tell NSCursor alloc)
initWithImage: image
hotSpot: #:type _NSPoint (make-NSPoint hot-spot-x hot-spot-y)))))))
(define/public (ok?) (and handle #t))
(define/public (get-handle) handle)
(super-new)))

101
collects/mred/private/wx/cocoa/dc.rkt Normal file
View File

@ -0,0 +1,101 @@
#lang racket/base
(require racket/class
ffi/unsafe
ffi/unsafe/objc
racket/draw/unsafe/cairo
racket/draw/private/bitmap
racket/draw/private/local
racket/draw/private/gl-context
"types.rkt"
"utils.rkt"
"bitmap.rkt"
"window.rkt"
"../../lock.rkt"
"../common/queue.rkt"
"../common/backing-dc.rkt"
"cg.rkt")
(provide
(protect-out dc%
do-backing-flush))
(import-class NSOpenGLContext)
(define dc%
(class backing-dc%
(init [(cnvs canvas)])
(define canvas cnvs)
(inherit end-delay)
(super-new)
(define gl #f)
(define/override (get-gl-context)
(and (send canvas can-gl?)
(let ([gl-ctx (tell (send canvas get-cocoa-content) openGLContext)])
(or gl
(let ([g (new (class gl-context%
(define/override (do-call-as-current t)
(dynamic-wind
(lambda () (tellv gl-ctx makeCurrentContext))
t
(lambda () (tellv NSOpenGLContext clearCurrentContext))))
(define/override (do-swap-buffers)
(tellv gl-ctx flushBuffer))
(super-new)))])
(set! gl g)
g)))))
;; Use a quartz bitmap so that text looks good:
(define/override (make-backing-bitmap w h) (make-object quartz-bitmap% w h))
(define/override (can-combine-text? sz) #t)
(define/override (get-backing-size xb yb)
(send canvas get-backing-size xb yb))
(define/override (get-size)
(let ([xb (box 0)]
[yb (box 0)])
(send canvas get-virtual-size xb yb)
(values (unbox xb) (unbox yb))))
(define/override (queue-backing-flush)
;; Re-enable expose events so that the queued
;; backing flush will be handled:
(end-delay)
(send canvas queue-backing-flush))
(define/override (flush)
(send canvas flush))
(define/override (request-delay)
(send canvas request-canvas-flush-delay))
(define/override (cancel-delay req)
(send canvas cancel-canvas-flush-delay req))))
(define (do-backing-flush canvas dc ctx dx dy)
(tellv ctx saveGraphicsState)
(begin0
(send dc on-backing-flush
(lambda (bm)
(let ([w (box 0)]
[h (box 0)])
(send canvas get-client-size w h)
(let ([cg (tell #:type _CGContextRef ctx graphicsPort)])
(unless (send canvas is-flipped?)
(CGContextTranslateCTM cg 0 (unbox h))
(CGContextScaleCTM cg 1 -1))
(CGContextTranslateCTM cg dx dy)
(let* ([surface (cairo_quartz_surface_create_for_cg_context cg (unbox w) (unbox h))]
[cr (cairo_create surface)])
(cairo_surface_destroy surface)
(let ([s (cairo_get_source cr)])
(cairo_pattern_reference s)
(cairo_set_source_surface cr (send bm get-cairo-surface) 0 0)
(cairo_new_path cr)
(cairo_rectangle cr 0 0 (unbox w) (unbox h))
(cairo_fill cr)
(cairo_set_source cr s)
(cairo_pattern_destroy s))
(cairo_destroy cr))))))
(tellv ctx restoreGraphicsState)))

17
collects/mred/private/wx/cocoa/dialog.rkt Normal file
View File

@ -0,0 +1,17 @@
#lang racket/base
(require racket/class
"../../syntax.rkt"
"../common/queue.rkt"
"../common/dialog.rkt"
"../../lock.rkt"
"frame.rkt")
(provide
(protect-out dialog%))
(define dialog%
(class (dialog-mixin frame%)
(super-new [is-dialog? #t])
;; #t result avoids children sheets
(define/override (get-sheet) #t)))

102
collects/mred/private/wx/cocoa/filedialog.rkt Normal file
View File

@ -0,0 +1,102 @@
#lang racket/base
(require ffi/unsafe
ffi/unsafe/objc
racket/class
racket/path
"../../lock.rkt"
"utils.rkt"
"types.rkt"
"queue.rkt"
"frame.rkt")
(provide
(protect-out file-selector))
(import-class NSOpenPanel NSSavePanel NSURL NSArray)
(define (nsurl->string url)
(string->path (tell #:type _NSString url path)))
(define (file-selector message directory filename
extension
filters style parent)
(let ([ns (as-objc-allocation-with-retain
(if (memq 'put style)
(tell NSSavePanel savePanel)
(tell NSOpenPanel openPanel)))]
[parent (and parent
(not (send parent get-sheet))
parent)])
(let ([extensions (append
(if extension (list extension) null)
(if (memq 'packages style) (list "app") null)
(for/list ([e (in-list filters)]
#:when (and (regexp-match #rx"[*][.][^.]+$" (cadr e))
(not (equal? (cadr e) "*.*"))))
(car (regexp-match #rx"[^.]+$" (cadr e)))))])
(unless (null? extensions)
(when (memq 'put style)
(tellv ns setCanSelectHiddenExtension: #:type _BOOL #t))
(let ([a (tell NSArray
arrayWithObjects: #:type (_list i _NSString) extensions
count: #:type _NSUInteger (length extensions))])
(tellv ns setAllowedFileTypes: a))
(let ([others? (ormap (lambda (e)
(equal? (cadr e) "*.*"))
filters)])
(tellv ns setAllowsOtherFileTypes: #:type _BOOL others?))))
(cond
[(memq 'multi style)
(tellv ns setAllowsMultipleSelection: #:type _BOOL #t)]
[(memq 'dir style)
(tellv ns setCanChooseDirectories: #:type _BOOL #t)
(tellv ns setCanChooseFiles: #:type _BOOL #f)])
(when message
(tellv ns setMessage: #:type _NSString message))
(when directory
(let ([dir (if (string? directory)
directory
(path->string directory))])
(if (version-10.6-or-later?)
(tellv ns setDirectoryURL: (tell NSURL
fileURLWithPath: #:type _NSString dir
isDirectory: #:type _BOOL #t))
(tellv ns setDirectory: #:type _NSString dir))))
(when filename
(when (version-10.6-or-later?)
(tellv ns setNameFieldStringValue: #:type _NSString (path->string
(file-name-from-path filename)))))
(when (memq 'enter-packages style)
(tellv ns setTreatsFilePackagesAsDirectories: #:type _BOOL #t))
(let ([result
;; We run the file dialog completely modally --- shutting out
;; all other eventspaces and threads. It would be nice to improve
;; on this, but it's good enough.
(atomically
(let ([front (get-front)]
[parent (and (version-10.6-or-later?)
parent)])
(when parent
(tellv ns beginSheetModalForWindow: (send parent get-cocoa-window)
completionHandler: #f))
(begin0
(tell #:type _NSInteger ns runModal)
(when parent (tell app endSheet: ns))
(when front (tellv (send front get-cocoa-window)
makeKeyAndOrderFront: #f)))))])
(begin0
(if (zero? result)
#f
(if (memq 'multi style)
(let ([urls (tell ns URLs)])
(for/list ([i (in-range (tell #:type _NSUInteger urls count))])
(nsurl->string (tell urls objectAtIndex: #:type _NSUInteger i))))
(let ([url (tell ns URL)])
(nsurl->string url))))
(release ns)))))

148
collects/mred/private/wx/cocoa/finfo.rkt Normal file
View File

@ -0,0 +1,148 @@
#lang racket/base
(require ffi/unsafe
ffi/unsafe/define
"utils.rkt"
"types.rkt")
(provide
(protect-out file-creator-and-type))
(define coreserv-lib (ffi-lib (format "/System/Library/Frameworks/CoreServices.framework/CoreServices")))
(define-ffi-definer define-coreserv coreserv-lib)
(define kFSCatInfoFinderInfo #x00000800)
(define _FSCatalogInfoBitmap _uint32)
(define _FSVolumeRefNum _int16)
(define-cstruct _UTCDateTime
([highSeconds _uint16]
[lowSeconds _uint32]
[fraction _uint16])
#:alignment 2)
(define-cstruct _Point
([v _short]
[h _short]))
(define _OSType _uint32)
(define-cstruct _FileInfo
([fileType _OSType]
[fileCreator _OSType]
[finderFlags _uint16]
[location _Point]
[reservedField _uint16])
#:alignment 2)
(define-cstruct _FSPermissionInfo
([userID _uint32]
[groupID _uint32]
[word _uint32]
[fileSec _pointer])
#:alignment 2)
(define-cstruct _FSCatalogInfo
([nodeFlags _uint16]
[volume _FSVolumeRefNum]
[parentDirID _uint32]
[nodeID _uint32]
[sharingFlags _uint8]
[userPrivileges _uint8]
[reserved1 _uint8]
[reserved2 _uint8]
[createDate _UTCDateTime]
[contentModDate _UTCDateTime]
[attributeModDate _UTCDateTime]
[accessDate _UTCDateTime]
[backupDate _UTCDateTime]
[permissions _FSPermissionInfo]
[finderInfo _FileInfo]
;; .... 144 or 148 bytes total
)
#:alignment 2)
(define _FSRef _pointer) ; 80 bytes
(define-coreserv FSPathMakeRef (_fun _path _FSRef (_pointer = #f) -> _OSStatus))
(define-coreserv FSGetCatalogInfo
(_fun _FSRef
_FSCatalogInfoBitmap
_FSCatalogInfo-pointer
_pointer ; outname, #f is ok
_pointer ; fsSpec, #f is ok
_pointer ; parentRef, #f is ok
-> _OSStatus))
(define-coreserv FSSetCatalogInfo
(_fun _FSRef
_FSCatalogInfoBitmap
_FSCatalogInfo-pointer
-> _OSStatus))
(define (path->fsref s)
(let ([fs (malloc 80)])
(let ([r (FSPathMakeRef s fs)])
(unless (zero? r)
(error 'file-creator-and-type "could not access file (~a): ~v"
r
s)))
fs))
(define (int->str v)
(bytes (arithmetic-shift (bitwise-and v #xFF000000) -24)
(arithmetic-shift (bitwise-and v #xFF0000) -16)
(arithmetic-shift (bitwise-and v #xFF00) -8)
(bitwise-and v #xFF)))
(define (str->int v)
(bitwise-ior (arithmetic-shift (bytes-ref v 0) 24)
(arithmetic-shift (bytes-ref v 1) 16)
(arithmetic-shift (bytes-ref v 2) 8)
(bytes-ref v 3)))
(define (get-info v fs path)
(let ([r (FSGetCatalogInfo fs
kFSCatInfoFinderInfo
v
#f #f #f)])
(unless (zero? r)
(error 'file-creator-and-type "lookup failed (~a): ~e"
r
path))))
(define file-creator-and-type
(case-lambda
[(path)
(unless (path-string? path)
(raise-type-error 'file-creator-and-type "path string" path))
(let ([info (let ([fs (path->fsref path)]
[v (cast (malloc 256) _pointer (_gcable _FSCatalogInfo-pointer))])
(get-info v fs path)
(FSCatalogInfo-finderInfo v))])
(values (int->str (FileInfo-fileCreator info))
(int->str (FileInfo-fileType info))))]
[(path creator type)
(unless (path-string? path)
(raise-type-error 'file-creator-and-type "path string" path))
(unless (and (bytes? creator) (= 4 (bytes-length creator)))
(raise-type-error 'file-creator-and-type "bytes string of length 4" creator))
(unless (and (bytes? type) (= 4 (bytes-length type)))
(raise-type-error 'file-creator-and-type "bytes string of length 4" type))
(let ([fs (path->fsref path)]
[v (cast (malloc 256) _pointer (_gcable _FSCatalogInfo-pointer))])
(get-info v fs path)
(let ([info (FSCatalogInfo-finderInfo v)])
(set-FileInfo-fileCreator! info (str->int creator))
(set-FileInfo-fileType! info (str->int type)))
(let ([r (FSSetCatalogInfo fs
kFSCatInfoFinderInfo
v)])
(unless (zero? r)
(error 'file-creator-and-type "change failed (~a): ~e"
r
path))))
(void)]))

49
collects/mred/private/wx/cocoa/font.rkt Normal file
View File

@ -0,0 +1,49 @@
#lang racket/base
(require racket/class
racket/draw
ffi/unsafe
ffi/unsafe/objc
"../../lock.rkt"
"const.rkt"
"utils.rkt"
"types.rkt")
(provide
(protect-out font->NSFont))
(import-class NSFont NSFontManager)
(define NSItalicFontMask #x00000001)
(define NSBoldFontMask #x00000002)
(define (font->NSFont f)
(let* ([weight (send f get-weight)]
[style (send f get-style)]
[name (or (send f get-face)
(send the-font-name-directory
get-screen-name
(send the-font-name-directory
find-family-default-font-id
(send f get-family))
weight
style))])
(atomically
(with-autorelease
(let ([f (tell NSFont
fontWithName: #:type _NSString name
size: #:type _CGFloat (send f get-point-size))])
(if (and (eq? 'normal weight)
(eq? 'normal style))
(begin
(retain f)
f)
(let ([fm (tell NSFontManager sharedFontManager)])
(let ([f (tell fm
convertFont: f
toHaveTrait: #:type _int (bitwise-ior
(if (eq? weight 'bold) NSBoldFontMask 0)
(if (eq? style 'italic) NSItalicFontMask 0)))])
(begin
(retain f)
f)))))))))

560
collects/mred/private/wx/cocoa/frame.rkt Normal file
View File

@ -0,0 +1,560 @@
#lang racket/base
(require ffi/unsafe/objc
ffi/unsafe
scheme/class
"pool.rkt"
"utils.rkt"
"const.rkt"
"types.rkt"
"window.rkt"
"queue.rkt"
"menu-bar.rkt"
"cursor.rkt"
"../../syntax.rkt"
"../common/queue.rkt"
"../common/freeze.rkt"
"../../lock.rkt")
(provide
(protect-out frame%
location->window
get-front))
;; ----------------------------------------
(import-class NSWindow NSGraphicsContext NSMenu NSPanel
NSApplication NSAutoreleasePool NSScreen
NSToolbar)
(define NSWindowCloseButton 0)
(define NSWindowToolbarButton 3)
(define front #f)
(define (get-front) front)
(define empty-mb (new menu-bar%))
(define root-fake-frame #f)
;; Maps window numbers to weak boxes of frame objects;
;; the weak-box layer is needed to avoid GC-accounting
;; problems.
(define all-windows (make-hash))
(define-objc-mixin (MyWindowMethods Superclass)
[wxb]
[-a _scheme (getEventspace)
(let ([wx (->wx wxb)])
(and wx (send wx get-eventspace)))]
[-a _BOOL (canBecomeKeyWindow)
(let ([wx (->wx wxb)])
(and wx
(not (other-modal? wx))))]
[-a _BOOL (canBecomeMainWindow) #t]
[-a _BOOL (windowShouldClose: [_id win])
(queue-window*-event wxb (lambda (wx)
(unless (other-modal? wx)
(when (send wx on-close)
(atomically
(send wx direct-show #f))))))
#f]
[-a _void (windowDidResize: [_id notification])
(when wxb
(let ([wx (->wx wxb)])
(when wx
(queue-window-event wx (lambda ()
(send wx on-size 0 0)
(send wx clean-up)))
;; Live resize:
(constrained-reply (send wx get-eventspace)
(lambda ()
(pre-event-sync #t)
(let loop () (when (yield) (loop))))
(void)))))]
[-a _void (windowDidMove: [_id notification])
(when wxb
(queue-window*-event wxb (lambda (wx)
(send wx on-size 0 0))))]
[-a _void (windowDidBecomeMain: [_id notification])
;; We check whether the window is visible because
;; clicking the dock item tries to resurrect a hidden
;; frame. See also `setOneShot' below.
(when (tell #:type _BOOL self isVisible)
(when wxb
(let ([wx (->wx wxb)])
(when wx
(set! front wx)
(send wx install-wait-cursor)
(send wx install-mb)
(send wx notify-responder #t)
(queue-window-event wx (lambda ()
(send wx on-activate #t)))))))]
[-a _void (windowDidResignMain: [_id notification])
(when wxb
(let ([wx (->wx wxb)])
(when wx
(when (eq? front wx)
(set! front #f)
(send wx uninstall-wait-cursor))
(if root-fake-frame
(send root-fake-frame install-mb)
(send empty-mb install))
(send wx notify-responder #f)
(queue-window-event wx (lambda ()
(send wx on-activate #f))))))]
[-a _void (toggleToolbarShown: [_id sender])
(when wxb
(let ([wx (->wx wxb)])
(when wx
(queue-window-event wx
(lambda () (send wx on-toolbar-click))))))
(void)])
(define-objc-class MyWindow NSWindow
#:mixins (FocusResponder KeyMouseResponder MyWindowMethods)
[wxb])
(define-objc-class MyPanel NSPanel
#:mixins (FocusResponder KeyMouseResponder MyWindowMethods)
[wxb])
(set-front-hook! (lambda () (values front
(and front (send front get-eventspace)))))
(set-eventspace-hook! (lambda (w)
(or (and w
(if (objc-is-a? w MyWindow)
(tell #:type _scheme w getEventspace)
#f))
(and front
(send front get-eventspace)))))
(define frame%
(class window%
(init parent
label
x y w h
style)
(init [is-dialog? #f])
(inherit get-cocoa get-parent
get-eventspace
pre-on-char pre-on-event
get-x
on-new-child
is-window-enabled?)
(super-new [parent parent]
[cocoa
(let ([is-sheet? (and #f
is-dialog?
parent
(not (send parent frame-is-dialog?)))]
[init-rect (make-NSRect (make-init-point x y)
(make-NSSize (max 30 w)
(max (if (memq 'no-caption style)
0
22)
h)))])
(let ([c (as-objc-allocation
(tell (tell (if is-sheet?
MyPanel
MyWindow)
alloc)
initWithContentRect: #:type _NSRect init-rect
styleMask: #:type _int (if (memq 'no-caption style)
NSBorderlessWindowMask
(bitwise-ior
NSTitledWindowMask
(if is-sheet? NSUtilityWindowMask 0)
(if is-dialog?
(if (memq 'close-button style)
NSClosableWindowMask
0)
(bitwise-ior
NSClosableWindowMask
NSMiniaturizableWindowMask
(if (memq 'no-resize-border style)
0
NSResizableWindowMask)))))
backing: #:type _int NSBackingStoreBuffered
defer: #:type _BOOL NO))])
;; use init rect as frame size, not content size
(tellv c setFrame: #:type _NSRect init-rect display: #:type _BOOL #f)
c))]
[no-show? #t])
(define cocoa (get-cocoa))
(tellv cocoa setDelegate: cocoa)
(when (memq 'toolbar-button style)
(atomically
(let ([tb (tell (tell NSToolbar alloc) initWithIdentifier: #:type _NSString "Ok")])
(tellv cocoa setToolbar: tb)
(tellv tb setVisible: #:type _BOOL #f)
(tellv tb release))))
(internal-move -11111 (if (= y -11111) 0 y))
(tellv cocoa setAcceptsMouseMovedEvents: #:type _BOOL #t)
;; Setting the window in one-shot mode helps prevent the
;; frame from being resurrected by a click on the dock icon.
(tellv cocoa setOneShot: #:type _BOOL #t)
(define/override (get-cocoa-content)
(tell cocoa contentView))
(define/override (get-cocoa-window) cocoa)
(define/override (get-wx-window) this)
(define/override (make-graphics-context)
(tell cocoa graphicsContext)
#;
(as-objc-allocation
(tell NSGraphicsContext graphicsContextWithWindow: cocoa)))
(define is-a-dialog? is-dialog?)
(define/public (frame-is-dialog?) is-a-dialog?)
(define/public (frame-relative-dialog-status win) #f)
(define/override (get-dialog-level) 0)
(define/public (clean-up)
;; When a window is resized, then any drawing that is in flight
;; might draw outside the canvas boundaries. Just refresh everything.
(tellv cocoa display))
(when label
(tellv cocoa setTitle: #:type _NSString label))
(define child-sheet #f)
(define/public (get-sheet) child-sheet)
(define/public (set-sheet s) (set! child-sheet s))
(define caption? (not (memq 'no-caption style)))
(define/public (can-have-sheet?) caption?)
(define/public (direct-show on?)
;; in atomic mode
(when (and (not on?)
(eq? front this))
(set! front #f)
(send empty-mb install))
(if on?
(show-children)
(hide-children))
(if on?
(if (and is-a-dialog?
(let ([p (get-parent)])
(and p
(send p can-have-sheet?)
(not (send p get-sheet)))))
(let ([p (get-parent)])
(send p set-sheet this)
(tellv (tell NSApplication sharedApplication)
beginSheet: cocoa
modalForWindow: (send p get-cocoa)
modalDelegate: #f
didEndSelector: #:type _SEL #f
contextInfo: #f))
(tellv cocoa makeKeyAndOrderFront: #f))
(begin
(when is-a-dialog?
(let ([p (get-parent)])
(when (and p
(eq? this (send p get-sheet)))
(send p set-sheet #f)
(tell (tell NSApplication sharedApplication)
endSheet: cocoa))))
(tellv cocoa orderOut: #f)
(let ([next
(atomically
(with-autorelease
(let ([wins (tell (tell NSApplication sharedApplication) orderedWindows)])
(begin0
(for/or ([i (in-range (tell #:type _NSUInteger wins count))])
(let ([win (tell wins objectAtIndex: #:type _NSUInteger i)])
(and (tell #:type _BOOL win isVisible)
(not (tell win parentWindow))
(or (not root-fake-frame)
(not (ptr-equal? win (send root-fake-frame get-cocoa))))
win)))))))])
(cond
[next (tellv next makeKeyWindow)]
[root-fake-frame (send root-fake-frame install-mb)]
[else (void)]))))
(register-frame-shown this on?)
(let ([num (tell #:type _NSInteger cocoa windowNumber)])
(if on?
(hash-set! all-windows num (make-weak-box this))
(hash-remove! all-windows num)))
(when on?
(let ([b (eventspace-wait-cursor-count (get-eventspace))])
(set-wait-cursor-mode (not (zero? b))))))
(define/override (show on?)
(let ([es (get-eventspace)])
(when on?
(when (eventspace-shutdown? es)
(error (string->symbol
(format "show method in ~a" (if is-a-dialog? 'dialog% 'frame%)))
"the eventspace hash been shutdown"))
(when saved-child
(if (eq? (current-thread) (eventspace-handler-thread es))
(do-paint-children)
(let ([s (make-semaphore)])
(queue-callback (lambda ()
(do-paint-children)
(semaphore-post s)))
(sync/timeout 1 s))))))
(atomically
(direct-show on?)))
(define/private (do-paint-children)
(when saved-child
(send saved-child paint-children))
(yield-refresh)
(try-to-sync-refresh))
(define/public (destroy)
(when child-sheet (send child-sheet destroy))
(atomically
(direct-show #f)))
(define/override (hide-children)
(when saved-child
(send saved-child hide-children)))
(define/override (show-children)
(when saved-child
(send saved-child show-children)))
(define/override (fixup-locations-children)
(when saved-child
(send saved-child fixup-locations-children)))
(define/override (children-accept-drag on?)
(when saved-child
(send saved-child child-accept-drag on?)))
(define/override (enable-window on?)
(when saved-child
(send saved-child enable-window (and on? (is-window-enabled?)))))
(define/override (is-shown?)
(tell #:type _bool cocoa isVisible))
(define/override (is-shown-to-root?)
(is-shown?))
(define/override (is-shown-to-before-root?) #t)
(define/override (is-parent-enabled-to-root?)
#t)
(define/override (is-view?) #f)
(define is-main? #f)
(define first-responder #f)
(define saved-child #f)
(define/override (register-child child on?)
(unless on? (error 'register-child-in-frame "did not expect #f"))
(unless (or (not saved-child) (eq? child saved-child))
(error 'register-child-in-frame "expected only one child"))
(set! saved-child child)
(on-new-child child #t))
(define/override (set-cursor c)
(when saved-child
(send saved-child set-cursor c)))
(define/public (notify-responder on?)
(set! is-main? on?)
(when first-responder
(do-notify-responder first-responder on?)))
(define/private (do-notify-responder wx on?)
(send wx focus-is-on on?)
(queue-window-event wx
(if on?
(lambda () (send wx on-set-focus))
(lambda () (send wx on-kill-focus)))))
(define/override (is-responder wx on?)
(unless (and (not on?)
(not (eq? first-responder wx)))
(if on?
(set! first-responder wx)
(set! first-responder #f))
(when is-main?
(do-notify-responder wx on?))))
(define/public (install-wait-cursor)
(when (positive? (eventspace-wait-cursor-count (get-eventspace)))
(tellv (get-wait-cursor-handle) set)))
(define/public (uninstall-wait-cursor)
(when (positive? (eventspace-wait-cursor-count (get-eventspace)))
(tellv arrow-cursor-handle set)))
(define/public (set-wait-cursor-mode on?)
(if on?
(tell cocoa disableCursorRects)
(tell cocoa enableCursorRects))
(when (eq? this front)
(if on?
(install-wait-cursor)
(uninstall-wait-cursor))))
(define/override (start-no-cursor-rects)
(tell cocoa disableCursorRects))
(define/override (end-no-cursor-rects)
(unless (positive? (eventspace-wait-cursor-count (get-eventspace)))
(tell cocoa enableCursorRects)))
(define/public (flip-screen y)
(let ([f (tell #:type _NSRect (tell cocoa screen) frame)])
(- (NSSize-height (NSRect-size f)) y)))
(define/override (flip y h) (flip-screen (+ y h)))
(define/override (get-y)
(- (super get-y) (if caption? 22 0)))
(define/override (set-size x y w h)
(unless (and (= x -1) (= y -1))
(internal-move x y))
(let ([f (tell #:type _NSRect cocoa frame)])
(tellv cocoa setFrame:
#:type _NSRect (make-NSRect
(make-NSPoint (if (and is-a-dialog?
(let ([p (get-parent)])
(and p
(eq? this (send p get-sheet)))))
;; need to re-center sheet:
(let* ([p (get-parent)]
[px (send p get-x)]
[pw (send p get-width)])
(+ px (/ (- pw w) 2)))
;; keep current x position:
(NSPoint-x (NSRect-origin f)))
;; keep current y position:
(- (NSPoint-y (NSRect-origin f))
(- h
(NSSize-height (NSRect-size f)))))
(make-NSSize w h))
display: #:type _BOOL #t)))
(define/override (internal-move x y)
(let ([x (if (= x -11111) (get-x) x)]
[y (if (= y -11111) (get-y) y)])
(tellv cocoa setFrameTopLeftPoint: #:type _NSPoint (make-NSPoint x (- (flip-screen y)
(get-menu-bar-height))))))
(define/override (center dir wrt)
(let ([f (tell #:type _NSRect cocoa frame)]
[s (tell #:type _NSRect (tell cocoa screen) frame)])
(tellv cocoa setFrame:
#:type _NSRect (make-NSRect (make-NSPoint
(if (or (eq? dir 'both)
(eq? dir 'horizontal))
(quotient (- (NSSize-width (NSRect-size s))
(NSSize-width (NSRect-size f)))
2)
(NSPoint-x (NSRect-origin f)))
(if (or (eq? dir 'both)
(eq? dir 'vertical))
(quotient (- (NSSize-height (NSRect-size s))
(NSSize-height (NSRect-size f)))
2)
(NSPoint-x (NSRect-origin f))))
(NSRect-size f))
display: #:type _BOOL #t)))
(define/public (enforce-size min-x min-y max-x max-y inc-x inc-y)
(define (adj v) (if (negative? v) 32000 v))
(tellv cocoa setMinSize: #:type _NSSize (make-NSSize (max min-x 1)
(max min-y 1)))
(tellv cocoa setMaxSize: #:type _NSSize (make-NSSize (adj max-x)
(adj max-y)))
(tellv cocoa setResizeIncrements: #:type _NSSize (make-NSSize inc-x inc-y)))
(define hide-mb? (and (memq 'hide-menu-bar style) #t))
(define mb #f)
(define/public (get-menu-bar) mb)
(define/public (set-menu-bar _mb)
(set! mb _mb)
(send mb set-top-window this)
(when (tell #:type _BOOL cocoa isMainWindow)
(install-mb)))
(define/public (install-mb)
(tellv NSMenu setMenuBarVisible: #:type _BOOL (not hide-mb?))
(if mb
(send mb install)
(send empty-mb install)))
(define/public (on-activate on?) (void))
(define/public (set-icon bm1 bm2 [mode 'both]) (void)) ;; FIXME
(define/override (call-pre-on-event w e)
(pre-on-event w e))
(define/override (call-pre-on-char w e)
(pre-on-char w e))
(define/public (on-menu-click) (void))
(define/public (on-toolbar-click) (void))
(define/public (on-menu-command c) (void))
(def/public-unimplemented on-mdi-activate)
(define/public (on-close) #t)
(define/public (designate-root-frame)
(set! root-fake-frame this))
(def/public-unimplemented system-menu)
(define/public (set-modified on?)
(let ([b (tell cocoa standardWindowButton: #:type _NSInteger NSWindowCloseButton)])
(tellv b setDocumentEdited: #:type _BOOL on?)))
(define/public (is-maximized?)
(tell #:type _BOOL cocoa isZoomed))
(define/public (maximize on?)
(unless (eq? (tell #:type _BOOL cocoa isZoomed)
(and on? #t))
(tellv cocoa zoom: cocoa)))
(define/public (iconized?)
(tell #:type _BOOL cocoa isMiniaturized))
(define/public (iconize on?)
(if on?
(tellv cocoa miniaturize: cocoa)
(tellv cocoa deminiaturize: cocoa)))
(define/public (set-title s)
(tellv cocoa setTitle: #:type _NSString s))
(define color-callback void)
(define/public (set-color-callback cb)
(set! color-callback cb))
(define/override (on-color-change)
(queue-window-event this (lambda () (color-callback))))))
;; ----------------------------------------
(define (location->window x y)
(let ([n (tell #:type _NSInteger NSWindow
windowNumberAtPoint: #:type _NSPoint
(let ([f (tell #:type _NSRect (tell NSScreen mainScreen) frame)])
(make-NSPoint x (- (NSSize-height (NSRect-size f)) y)))
belowWindowWithWindowNumber: #:type _NSInteger 0)])
(atomically (let ([b (hash-ref all-windows n #f)])
(and b (weak-box-value b))))))
(set-fixup-window-locations!
(lambda ()
;; in atomic mode
(for ([b (in-hash-values all-windows)])
(let ([f (weak-box-value b)])
(when f
(send f fixup-locations-children))))))

71
collects/mred/private/wx/cocoa/gauge.rkt Normal file
View File

@ -0,0 +1,71 @@
#lang racket/base
(require racket/class
ffi/unsafe
racket/math
ffi/unsafe/objc
"../../syntax.rkt"
"item.rkt"
"types.rkt"
"const.rkt"
"utils.rkt"
"window.rkt")
(provide
(protect-out gauge%))
;; ----------------------------------------
(import-class NSProgressIndicator)
(define-objc-class MyProgressIndicator NSProgressIndicator
#:mixins (KeyMouseResponder CursorDisplayer)
[wxb])
(defclass gauge% item%
(init parent
label
rng
x y w h
style
font)
(inherit get-cocoa)
(super-new [parent parent]
[cocoa (let ([cocoa (as-objc-allocation
;; Beware that a guage may be finally deallocated in
;; a seperate OS-level thread
(tell (tell MyProgressIndicator alloc) init))])
(tellv cocoa setIndeterminate: #:type _BOOL #f)
(tellv cocoa setMaxValue: #:type _double* rng)
(tellv cocoa setDoubleValue: #:type _double* 0.0)
(tellv cocoa sizeToFit)
(when (memq 'vertical style)
(let ([r (tell #:type _NSRect cocoa frame)])
(printf "height ~s\n" (NSSize-height (NSRect-size r)))
(tellv cocoa setFrame:
#:type _NSRect (make-NSRect
(NSRect-origin r)
(make-NSSize
(NSSize-height (NSRect-size r))
(NSSize-width (NSRect-size r)))))
(tellv cocoa rotateByAngle: #:type _CGFloat -90)))
cocoa)]
[callback void]
[no-show? (memq 'deleted style)])
(define cocoa (get-cocoa))
(define/override (enable on?) (void))
(define/override (is-window-enabled?) #t)
(define/public (get-range)
(inexact->exact (floor (tell #:type _double cocoa maxValue))))
(define/public (set-range rng)
(tellv cocoa setMaxValue: #:type _double* rng)
(tellv cocoa setDoubleValue: #:type _double* (min rng (tell #:type _double cocoa doubleValue))))
(define/public (set-value v)
(tellv cocoa setDoubleValue: #:type _double* v))
(define/public (get-value)
(min (inexact->exact (floor (tell #:type _double cocoa doubleValue)))
(get-range))))

27
collects/mred/private/wx/cocoa/gc.rkt Normal file
View File

@ -0,0 +1,27 @@
#lang racket/base
(require ffi/unsafe
ffi/unsafe/objc
"utils.rkt"
"types.rkt")
(provide
(protect-out scheme_add_gc_callback
scheme_remove_gc_callback
make-gc-action-desc))
(define objc-lib (ffi-lib "libobjc"))
(define msg-send-proc (get-ffi-obj 'objc_msgSend objc-lib _fpointer))
(define-mz scheme_add_gc_callback (_fun _racket _racket -> _racket))
(define-mz scheme_remove_gc_callback (_fun _racket -> _void))
(define (make-gc-action-desc win sel val)
(vector
(vector (if (= (ctype-sizeof _CGFloat) 4)
'ptr_ptr_float->void
'ptr_ptr_double->void)
msg-send-proc
win
sel
val)))

43
collects/mred/private/wx/cocoa/group-panel.rkt Normal file
View File

@ -0,0 +1,43 @@
#lang racket/base
(require racket/class
ffi/unsafe
ffi/unsafe/objc
"../../syntax.rkt"
"types.rkt"
"utils.rkt"
"window.rkt"
"panel.rkt")
(provide
(protect-out group-panel%))
(import-class NSBox)
(define-objc-class MyBox NSBox
#:mixins (FocusResponder KeyMouseResponder CursorDisplayer)
[wxb])
(defclass group-panel% (panel-mixin window%)
(init parent
x y w h
style
label)
(inherit get-cocoa)
(super-new [parent parent]
[cocoa
(let ([cocoa (as-objc-allocation
(tell (tell MyBox alloc) init))])
(when label
(tellv cocoa setTitle: #:type _NSString label)
(tellv cocoa sizeToFit))
cocoa)]
[no-show? (memq 'deleted style)])
(define/override (get-cocoa-content)
(tell (get-cocoa) contentView))
(define/override (get-cocoa-cursor-content)
(get-cocoa))
(define/public (set-label l)
(tellv (get-cocoa) setTitle: #:type _NSString l)))

137
collects/mred/private/wx/cocoa/image.rkt Normal file
View File

@ -0,0 +1,137 @@
#lang racket/base
(require ffi/unsafe
ffi/unsafe/objc
racket/class
racket/draw/unsafe/cairo
racket/draw/private/local
racket/draw/unsafe/bstr
"utils.rkt"
"types.rkt"
"const.rkt"
"cg.rkt"
"bitmap.rkt"
"../../lock.rkt"
(only-in '#%foreign ffi-callback))
(provide
(protect-out bitmap->image
image->bitmap))
(import-class NSImage NSGraphicsContext)
(define NSCompositeCopy 1)
(define _CGImageRef (_cpointer 'CGImageRef))
(define _CGColorSpaceRef (_cpointer 'CGColorSpaceRef))
(define _CGDataProviderRef (_cpointer 'GCDataProviderRef))
(define _CGRect _NSRect)
(define _size_t _long)
(define _off_t _long)
(define-appserv CGColorSpaceCreateDeviceRGB (_fun -> _CGColorSpaceRef))
(define-appserv CGColorSpaceRelease (_fun _CGColorSpaceRef -> _void))
(define-appserv CGImageCreate (_fun _size_t ; w
_size_t ; h
_size_t ; bitsPerComponent
_size_t ; bitsPerPixel
_size_t ; bytesPerRow
_CGColorSpaceRef ; colorspace
_int ; bitmapInfo
_CGDataProviderRef ; provider
_pointer ; CGFloat decode[]
_bool ; shouldInterpolate
_int ; intent
-> _CGImageRef))
(define-appserv CGContextDrawImage (_fun _CGContextRef _CGRect _CGImageRef -> _void))
(define free-it
(ffi-callback free (list _pointer) _void #f #t))
(define-appserv CGDataProviderCreateWithData (_fun _pointer _pointer _size_t _fpointer
-> _CGDataProviderRef))
(define-appserv CGDataProviderRelease (_fun _CGDataProviderRef -> _void))
(define (get-image-bytes info)
info)
(define (release-image-bytes info bytes)
(void))
(define (get-bytes-at-position bytes dest-bytes start count)
(memcpy dest-bytes (ptr-add bytes start) count))
(define (release-info info)
(free info))
(define (bitmap->image bm)
(let* ([w (send bm get-width)]
[h (send bm get-height)]
[str (make-bytes (* w h 4) 255)])
(send bm get-argb-pixels 0 0 w h str #f)
(let ([mask (send bm get-loaded-mask)])
(when mask
(send mask get-argb-pixels 0 0 w h str #t)))
(atomically
(let ([rgba (scheme_make_sized_byte_string (malloc (* w h 4) 'raw) (* w h 4) 0)])
(memcpy rgba str (sub1 (* w h 4)))
(let* ([cs (CGColorSpaceCreateDeviceRGB)]
[provider (CGDataProviderCreateWithData #f rgba (* w h 4) free-it)]
[image (CGImageCreate w
h
8
32
(* 4 w)
cs
(bitwise-ior kCGImageAlphaFirst
kCGBitmapByteOrder32Big)
provider ; frees `rgba'
#f
#f
0)])
(CGDataProviderRelease provider)
(CGColorSpaceRelease cs)
;; This works on 10.6 and later:
#;
(as-objc-allocation
(tell (tell NSImage alloc)
initWithCGImage: #:type _CGImageRef image
size: #:type _NSSize (make-NSSize w h)))
;; To work with older versions:
(let* ([size (make-NSSize w h)]
[i (as-objc-allocation
(tell (tell NSImage alloc)
initWithSize: #:type _NSSize size))])
(tellv i lockFocus)
(CGContextDrawImage
(tell #:type _CGContextRef (tell NSGraphicsContext currentContext) graphicsPort)
(make-NSRect (make-NSPoint 0 0) size)
image)
(tellv i unlockFocus)
i))))))
(define (image->bitmap i)
(let* ([s (tell #:type _NSSize i size)]
[w (NSSize-width s)]
[h (NSSize-height s)]
[bm (make-object quartz-bitmap%
(inexact->exact (ceiling w))
(inexact->exact (ceiling h)))]
[surface (let ([s (send bm get-cairo-surface)])
(cairo_surface_flush s)
s)]
[cg (cairo_quartz_surface_get_cg_context surface)]
[gc (tell NSGraphicsContext
graphicsContextWithGraphicsPort: #:type _pointer cg
flipped: #:type _BOOL #f)])
(CGContextSaveGState cg)
(CGContextTranslateCTM cg 0 h)
(CGContextScaleCTM cg 1 -1)
(tellv NSGraphicsContext saveGraphicsState)
(tellv NSGraphicsContext setCurrentContext: gc)
(let ([r (make-NSRect (make-NSPoint 0 0) (make-NSSize w h))])
(tellv i drawInRect: #:type _NSRect r fromRect: #:type _NSRect r
operation: #:type _int NSCompositeCopy fraction: #:type _CGFloat 1.0))
(tellv NSGraphicsContext restoreGraphicsState)
(CGContextRestoreGState cg)
bm))

6
collects/mred/private/wx/cocoa/init.rkt Normal file
View File

@ -0,0 +1,6 @@
#lang racket/base
(require "pool.rkt"
"queue.rkt")
(define pump-thread (cocoa-start-event-pump))
(cocoa-install-event-wakeup)

54
collects/mred/private/wx/cocoa/item.rkt Normal file
View File

@ -0,0 +1,54 @@
#lang racket/base
(require racket/class
ffi/unsafe
ffi/unsafe/objc
"../../syntax.rkt"
"../../lock.rkt"
"window.rkt"
"const.rkt"
"types.rkt"
"font.rkt")
(provide
(protect-out item%
install-control-font
sys-font-size))
(import-class NSFont)
(define sys-font-size 13)
(define sys-font
(atomically
(let ([f (tell NSFont systemFontOfSize: #:type _CGFloat sys-font-size)])
(tellv f retain)
f)))
(define (install-control-font cocoa font)
(if font
(tellv cocoa setFont: (font->NSFont font))
(tellv cocoa setFont: sys-font)))
(defclass item% window%
(inherit get-cocoa
is-window-enabled?)
(init-field callback)
(define/public (get-cocoa-control) (get-cocoa))
(define/override (enable-window on?)
(let ([on? (and on? (is-window-enabled?))])
(tellv (get-cocoa-control) setEnabled: #:type _BOOL on?)))
(define/override (gets-focus?)
(tell #:type _BOOL (get-cocoa-control) canBecomeKeyView))
(define/public (command e)
(callback this e))
(def/public-unimplemented set-label)
(def/public-unimplemented get-label)
(super-new)
(define/public (init-font cocoa font)
(install-control-font cocoa font)))

56
collects/mred/private/wx/cocoa/keycode.rkt Normal file
View File

@ -0,0 +1,56 @@
#lang racket/base
(provide map-key-code)
(define (map-key-code v)
(hash-ref
#hash((122 . f1)
(120 . f2)
(99 . f3)
(118 . f4)
(96 . f5)
(97 . f6)
(98 . f7)
(100 . f8)
(101 . f9)
(109 . f10)
(103 . f11)
(111 . f12)
(105 . f13)
(107 . f14)
(113 . f15)
(#x35 . escape)
(#x7e . up)
(#x7d . down)
(#x3d . down)
(#x7b . left)
(#x3b . left)
(#x7c . right)
(#x3c . right)
(#x24 . #\return)
(#x30 . #\tab)
(#x33 . #\backspace)
(#x75 . #\rubout)
(#x73 . home)
(#x77 . end)
(#x74 . prior)
(#x79 . next)
(#x45 . add)
(78 . subtract)
(#x43 . multiply)
(#x4b . divide)
(71 . separator)
(65 . decimal)
(76 . #\u3) ; numpad enter
(82 . numpad0)
(83 . numpad1)
(84 . numpad2)
(85 . numpad3)
(86 . numpad4)
(87 . numpad5)
(88 . numpad6)
(89 . numpad7)
(91 . numpad8)
(92 . numpad9))
v
#f))

215
collects/mred/private/wx/cocoa/list-box.rkt Normal file
View File

@ -0,0 +1,215 @@
#lang racket/base
(require ffi/unsafe/objc
ffi/unsafe
racket/class
(only-in scheme/list take drop)
"../../syntax.rkt"
"../../lock.rkt"
"item.rkt"
"utils.rkt"
"types.rkt"
"const.rkt"
"window.rkt"
"font.rkt"
"../common/event.rkt")
(provide
(protect-out list-box%))
;; ----------------------------------------
(import-class NSScrollView NSTableView NSTableColumn NSCell NSIndexSet)
(import-protocol NSTableViewDataSource)
(define-objc-class MyTableView NSTableView
#:mixins (FocusResponder KeyMouseResponder CursorDisplayer)
[wxb]
[-a _id (preparedCellAtColumn: [_NSInteger column] row: [_NSInteger row])
(let ([wx (->wx wxb)])
(tell
(let ([c (tell (tell NSCell alloc) initTextCell: #:type _NSString
(if wx (send wx get-row row) "???"))]
[font (and wx (send wx get-cell-font))])
(when font
(tellv c setFont: font))
c)
autorelease))]
[-a _void (doubleClicked: [_id sender])
(queue-window*-event wxb (lambda (wx) (send wx clicked 'list-box-dclick)))]
[-a _void (tableViewSelectionDidChange: [_id aNotification])
(queue-window*-event wxb (lambda (wx) (send wx clicked 'list-box)))])
(define-objc-class MyDataSource NSObject
#:protocols (NSTableViewDataSource)
[wxb]
[-a _NSInteger (numberOfRowsInTableView: [_id view])
(let ([wx (->wx wxb)])
(send wx number))]
[-a _NSString (tableView: [_id aTableView]
objectValueForTableColumn: [_id aTableColumn]
row: [_NSInteger rowIndex])
(let ([wx (->wx wxb)])
(if wx
(send wx get-row rowIndex)
"???"))])
(define (remove-nth data i)
(cond
[(zero? i) (cdr data)]
[else (cons (car data) (remove-nth (cdr data) (sub1 i)))]))
(defclass list-box% item%
(init parent cb
label kind x y w h
choices style
font label-font)
(inherit set-size init-font
register-as-child)
(define source (as-objc-allocation
(tell (tell MyDataSource alloc) init)))
(set-ivar! source wxb (->wxb this))
(define items choices)
(define data (map (lambda (x) (box #f)) choices))
(define count (length choices))
(define cocoa (as-objc-allocation
(tell (tell NSScrollView alloc) init)))
(define content-cocoa (let ([content-cocoa
(as-objc-allocation
(tell (tell MyTableView alloc) init))])
(tellv content-cocoa setDelegate: content-cocoa)
(tellv content-cocoa setDataSource: source)
(tellv content-cocoa addTableColumn:
(as-objc-allocation
(tell (tell NSTableColumn alloc) initWithIdentifier: content-cocoa)))
(init-font content-cocoa font)
content-cocoa))
(set-ivar! content-cocoa wxb (->wxb this))
(tellv cocoa setDocumentView: content-cocoa)
(tellv cocoa setHasVerticalScroller: #:type _BOOL #t)
(tellv content-cocoa setHeaderView: #f)
(define allow-multi? (not (eq? kind 'single)))
(when allow-multi?
(tellv content-cocoa setAllowsMultipleSelection: #:type _BOOL #t))
(define/override (get-cocoa-content) content-cocoa)
(define/override (get-cocoa-control) content-cocoa)
(super-new [parent parent]
[cocoa cocoa]
[no-show? (memq 'deleted style)]
[callback cb])
(set-size 0 0 32 50)
; (tellv content-cocoa sizeToFit)
(tellv content-cocoa setTarget: content-cocoa)
(tellv content-cocoa setDoubleAction: #:type _SEL (selector doubleClicked:))
(def/public-unimplemented get-label-font)
(define cell-font (and font (font->NSFont font)))
(define/public (get-cell-font)
cell-font)
(define/public (get-selection)
(if allow-multi?
(let ([l (get-selections)])
(if (null? l)
-1
(car l)))
(tell #:type _NSInteger content-cocoa selectedRow)))
(define/public (get-selections)
(atomically
(with-autorelease
(let ([v (tell content-cocoa selectedRowIndexes)])
(begin0
(let loop ([i (tell #:type _NSInteger v firstIndex)])
(cond
[(= i NSNotFound) null]
[else (cons i (loop (tell #:type _NSInteger v
indexGreaterThanIndex: #:type _NSInteger i)))])))))))
(define/private (visible-range)
(tell #:type _NSRange content-cocoa
rowsInRect: #:type _NSRect (tell #:type _NSRect cocoa documentVisibleRect)))
(define/public (get-first-item)
(NSRange-location (visible-range)))
(define/public (number-of-visible-items)
(NSRange-length (visible-range)))
(define/public (set-first-visible-item i)
;; FIXME: visble doesn't mean at top:
(tellv content-cocoa scrollRowToVisible: #:type _NSInteger i))
(define/public (set-string i s)
(set! items
(append (take items i)
(list s)
(drop items (add1 i))))
(reset))
(define/public (number)
;; Can be called by event-handling thread
count)
(define/public (get-row n)
;; Can be called by event-handling thread
(list-ref items n))
(define callback cb)
(define/public (clicked event-type)
(unless (zero? count)
(callback this (new control-event%
[event-type event-type]
[time-stamp (current-milliseconds)]))))
(define/public (set-data i v) (set-box! (list-ref data i) v))
(define/public (get-data i) (unbox (list-ref data i)))
(define/public (selected? i)
(tell #:type _BOOL content-cocoa isRowSelected: #:type _NSInteger i))
(define/public (select i [on? #t] [extend? #t])
(if on?
(atomically
(with-autorelease
(let ([index (tell (tell NSIndexSet alloc) initWithIndex: #:type _NSUInteger i)])
(tellv content-cocoa
selectRowIndexes: index
byExtendingSelection: #:type _BOOL (and extend? allow-multi?)))))
(tellv content-cocoa deselectRow: #:type _NSInteger i)))
(define/public (set-selection i)
(select i #t #f))
(define/public (delete i)
(set! count (sub1 count))
(set! items (remove-nth items i))
(set! data (remove-nth data i))
(reset))
(define/public (clear)
(set! count 0)
(set! items null)
(set! data null)
(reset))
(define/public (set choices)
(set! items choices)
(set! data (map (lambda (x) (box #f)) choices))
(set! count (length choices))
(reset))
(public [append* append])
(define (append* s [v #f])
(set! count (add1 count))
(set! items (append items (list s)))
(set! data (append data (list (box v))))
(reset))
(define/public (reset)
(tellv content-cocoa noteNumberOfRowsChanged)
(tellv content-cocoa reloadData))
(define/override (maybe-register-as-child parent on?)
(register-as-child parent on?)))

199
collects/mred/private/wx/cocoa/menu-bar.rkt Normal file
View File

@ -0,0 +1,199 @@
#lang racket/base
(require racket/class
ffi/unsafe
ffi/unsafe/objc
(only-in racket/list take drop)
"../../syntax.rkt"
"../../lock.rkt"
"utils.rkt"
"types.rkt"
"const.rkt"
"queue.rkt")
(provide
(protect-out menu-bar%
get-menu-bar-height))
(import-class NSApplication NSMenu NSMenuItem NSProcessInfo NSScreen)
(define-cf CFBundleGetMainBundle (_fun -> _pointer))
(define-cf CFBundleGetInfoDictionary (_fun _pointer -> _id))
(define app-name
(or
(let ([dict (CFBundleGetInfoDictionary (CFBundleGetMainBundle))])
(and dict
(let ([appName (tell dict objectForKey: #:type _NSString "CFBundleName")]
[alt (lambda ()
(tell #:type _NSString (tell NSProcessInfo processInfo) processName))])
(if (not appName)
(alt)
(let ([appName (cast appName _id _NSString)])
(if (equal? appName "")
(alt)
appName))))))
"MrEd"))
(define the-apple-menu #f)
(define recurring-for-command (make-parameter #f))
(define-objc-class MyBarMenu NSMenu
[]
;; Disable automatic handling of keyboard shortcuts, except for
;; the Apple menu
(-a _BOOL (performKeyEquivalent: [_id evt])
(or (and the-apple-menu
(tell #:type _BOOL the-apple-menu performKeyEquivalent: evt))
;; Explicity send the event to the keyWindow:
(and
;; Don't go into an infinite loop:
(not (recurring-for-command))
;; Don't handle Cmd-` for cycling through windows:
;; [Is this right for all locales?]
(not (equal? "`" (tell #:type _NSString evt characters)))
;; Otherwise, try to dispatch to the first respnder:
(let ([w (tell app keyWindow)])
(and w
(let ([r (tell w firstResponder)])
(and r
(begin
(parameterize ([recurring-for-command #t])
(tell r keyDown: evt))
#t)))))))))
(define cocoa-mb (tell (tell MyBarMenu alloc) init))
(define current-mb #f)
;; Used to detect mouse click on the menu bar:
(define in-menu-bar-range
(let ([f (tell #:type _NSRect
(tell (tell NSScreen screens) objectAtIndex: #:type _NSUInteger 0)
frame)])
(let ([x (NSPoint-x (NSRect-origin f))]
[w (NSSize-width (NSRect-size f))]
[y (+ (NSPoint-y (NSRect-origin f))
(NSSize-height (NSRect-size f)))])
(lambda (p)
(let ([h (tell #:type _CGFloat cocoa-mb menuBarHeight)])
(and (<= x (NSPoint-x p) (+ x w))
(<= (- y h) (NSPoint-y p) y)))))))
(define (get-menu-bar-height)
(inexact->exact (floor (tell #:type _CGFloat cocoa-mb menuBarHeight))))
(set-menu-bar-hooks! in-menu-bar-range)
;; Init menu bar
(let ([app (tell NSApplication sharedApplication)]
[add-one (lambda (mb menu)
(let ([item (tell (tell NSMenuItem alloc)
initWithTitle: #:type _NSString ""
action: #:type _SEL #f
keyEquivalent: #:type _NSString "")])
(tellv item setSubmenu: menu)
(tellv mb addItem: item)
(tellv item release)))])
(let ([apple (tell (tell NSMenu alloc) initWithTitle: #:type _NSString "")])
(let ([std (lambda (title sel [shortcut ""] [mods #f] [delegate? #f])
(let ([item (tell (tell NSMenuItem alloc)
initWithTitle: #:type _NSString title
action: #:type _SEL sel
keyEquivalent: #:type _NSString shortcut)])
(when mods
(tellv item setKeyEquivalentModifierMask: #:type _NSInteger mods))
(tellv item setTarget: (if delegate?
(tell app delegate)
app))
(tellv apple addItem: item)
(tellv item release)))])
(std (format "About ~a" app-name) (selector orderFrontStandardAboutPanel:))
(std "Preferences..." (selector openPreferences:) "," #f #t)
(tellv apple addItem: (tell NSMenuItem separatorItem))
(let ([services (tell (tell NSMenu alloc) initWithTitle: #:type _NSString "Services")])
(tellv app setServicesMenu: services)
(let ([item (tell (tell NSMenuItem alloc)
initWithTitle: #:type _NSString "Services"
action: #:type _SEL #f
keyEquivalent: #:type _NSString "")])
(tellv item setSubmenu: services)
(tellv apple addItem: item)
(tellv item release)))
(tellv apple addItem: (tell NSMenuItem separatorItem))
(std (format "Hide ~a" app-name) (selector hide:) "h")
(std "Hide Others" (selector hideOtherApplications:) "h" (bitwise-ior
NSAlternateKeyMask
NSCommandKeyMask))
(std "Show All" (selector unhideAllApplications:))
(tellv apple addItem: (tell NSMenuItem separatorItem))
(std (format "Quit ~a" app-name) (selector terminate:) "q"))
(add-one cocoa-mb apple)
(tellv app setAppleMenu: apple)
(tellv apple release)
(tellv app setMainMenu: cocoa-mb)
(set! the-apple-menu apple)))
(tellv cocoa-mb setAutoenablesItems: #:type _BOOL #f)
(defclass menu-bar% object%
(define menus null)
(define/public (enable-top pos on?)
(set-box! (cddr (list-ref menus pos)) on?)
(when (eq? current-mb this)
(tellv (tell cocoa-mb itemAtIndex: #:type _NSInteger (add1 pos))
setEnabled: #:type _BOOL on?)))
(define/public (delete which pos)
(atomically
(when (eq? current-mb this)
(tellv cocoa-mb removeItem:
(tell cocoa-mb itemAtIndex: #:type _NSInteger (add1 pos))))
(set! menus (let loop ([menus menus]
[pos pos])
(cond
[(null? menus) menus]
[(zero? pos) (cdr menus)]
[else (cons (car menus)
(loop (cdr menus)
(sub1 pos)))])))))
(public [append-menu append])
(define (append-menu menu title)
(set! menus (append menus (list (list* menu title (box #t)))))
(send menu set-parent this)
(when (eq? current-mb this)
(send menu install cocoa-mb title #t)))
(define/public (install)
(let loop ()
(when ((tell #:type _NSInteger cocoa-mb numberOfItems) . > . 1)
(tellv cocoa-mb removeItem: (tell cocoa-mb itemAtIndex: #:type _NSInteger 1))
(loop)))
(for-each (lambda (menu)
(send (car menu) install cocoa-mb (cadr menu) (unbox (cddr menu))))
menus)
(set! current-mb this))
(define top-wx #f)
(define/public (set-top-window top)
(set! top-wx top))
(define/public (get-top-window)
top-wx)
(define/public (set-label-top pos str)
(set! menus (append
(take menus pos)
(let ([i (list-ref menus pos)])
(list (cons (car i) (cons str (cddr i)))))
(drop menus (add1 pos))))
(when (eq? current-mb this)
(tellv (tell cocoa-mb itemAtIndex: #:type _NSInteger 1)
setTitle: #:type _NSString (clean-menu-label str))))
(define/public (do-on-menu-click)
(let ([es (send top-wx get-eventspace)])
(when es
(queue-event es (lambda ()
(send top-wx on-menu-click))))))
(super-new))

101
collects/mred/private/wx/cocoa/menu-item.rkt Normal file
View File

@ -0,0 +1,101 @@
#lang racket/base
(require racket/class
ffi/unsafe
ffi/unsafe/objc
"../../syntax.rkt"
"utils.rkt"
"types.rkt"
"const.rkt")
(provide
(protect-out menu-item%
set-menu-item-shortcut))
(import-class NSMenuItem)
(define-objc-class MyMenuItem NSMenuItem
[wxb]
(-a _void (selected: [_id sender])
(let ([wx (->wx wxb)])
(when wx
(send wx selected))))
(-a _void (selectedCheckable: [_id sender])
(let ([wx (->wx wxb)])
(when wx
(send wx selected-checkable self)))))
(defclass menu-item% object%
(define/public (id) this)
(define parent #f)
(define/public (selected)
;; called in Cocoa thread
(send parent item-selected this))
(define/public (selected-checkable cocoa)
;; called in Cocoa thread
(set! checked? (not checked?))
(tellv cocoa setState: #:type _int (if checked? 1 0))
(send parent item-selected this))
(define/public (set-parent p)
(set! parent p))
(define label #f)
(define/public (set-label l) (set! label l))
(define/public (get-label) label)
(define checked? #f)
(define/public (set-checked c?) (set! checked? c?))
(define/public (get-checked) checked?)
(define enabled? #t)
(define/public (set-enabled-flag e?) (set! enabled? e?))
(define/public (get-enabled-flag) enabled?)
(define submenu #f)
(define/public (set-submenu m) (set! submenu m))
(define/public (install menu checkable?)
(if submenu
(send submenu install menu label enabled?)
(let ([item (as-objc-allocation
(tell (tell MyMenuItem alloc)
initWithTitle: #:type _NSString (regexp-replace #rx"\t.*" label "")
action: #:type _SEL #f
keyEquivalent: #:type _NSString ""))])
(set-ivar! item wxb (->wxb this))
(tellv menu addItem: item)
(tellv item setEnabled: #:type _BOOL enabled?)
(when checked?
(tellv item setState: #:type _int 1))
(tellv item setTarget: item)
(tellv item setAction: #:type _SEL (if checkable?
(selector selectedCheckable:)
(selector selected:)))
(set-menu-item-shortcut item label)
(release item))))
(super-new))
(define (set-menu-item-shortcut item label)
(let ([shortcut (regexp-match #rx"\tCut=(.)(.*)" label)])
(if shortcut
(let* ([s (string-downcase (string (integer->char (string->number (caddr shortcut)))))]
[flags (- (char->integer (string-ref (cadr shortcut) 0))
(char->integer #\A))]
[mods (+ (if (positive? (bitwise-and flags 1))
NSShiftKeyMask
0)
(if (positive? (bitwise-and flags 2))
NSAlternateKeyMask
0)
(if (positive? (bitwise-and flags 4))
NSControlKeyMask
0)
(if (positive? (bitwise-and flags 8))
0
NSCommandKeyMask))])
(tellv item setKeyEquivalent: #:type _NSString s)
(tellv item setKeyEquivalentModifierMask: #:type _NSUInteger mods))
(tellv item setKeyEquivalent: #:type _NSString ""))))

194
collects/mred/private/wx/cocoa/menu.rkt Normal file
View File

@ -0,0 +1,194 @@
#lang racket/base
(require racket/class
ffi/unsafe
ffi/unsafe/objc
(only-in scheme/list drop take)
"../common/event.rkt"
"../../syntax.rkt"
"../../lock.rkt"
"utils.rkt"
"types.rkt"
"const.rkt"
"window.rkt"
"menu-item.rkt")
(provide
(protect-out menu%))
(import-class NSMenu NSMenuItem NSEvent)
(define-struct mitem (item checkable?))
(defclass menu% object%
(init-field label
callback
font)
(super-new)
(define items null)
(define cocoa #f)
(define cocoa-menu #f)
(define/public (create-menu label)
(unless cocoa
(set! cocoa
(as-objc-allocation
(tell (tell NSMenuItem alloc)
initWithTitle: #:type _NSString (clean-menu-label label)
action: #:type _SEL #f
keyEquivalent: #:type _NSString "")))
(set! cocoa-menu
(as-objc-allocation
(tell (tell NSMenu alloc)
initWithTitle: #:type _NSString (clean-menu-label label))))
(tellv cocoa-menu setAutoenablesItems: #:type _BOOL #f)
(tellv cocoa setSubmenu: cocoa-menu)
(for-each (lambda (item)
(if item
(send (mitem-item item) install cocoa-menu (mitem-checkable? item))
(tellv cocoa-menu addItem: (tell NSMenuItem separatorItem))))
items)))
(define/public (install cocoa-parent label enabled?)
(create-menu label)
(tellv cocoa-parent addItem: cocoa)
(tellv cocoa setEnabled: #:type _BOOL enabled?))
(define popup-box #f)
(define/public (do-popup v win x y queue-cb)
(unless (null? items)
(create-menu "menu")
(let ([b (box #f)])
(set! popup-box b)
(if (not (version-10.6-or-later?))
;; For 10.5 and earlier:
(let ([p (tell #:type _NSPoint v
convertPoint: #:type _NSPoint (make-NSPoint x y)
toView: #f)])
(atomically
(with-autorelease
(tellv NSMenu popUpContextMenu: cocoa-menu
withEvent: (tell NSEvent
mouseEventWithType: #:type _int NSLeftMouseDown
location: #:type _NSPoint p
modifierFlags: #:type _NSUInteger 0
timestamp: #:type _double 0.0
windowNumber: #:type _NSUInteger
(tell #:type _NSInteger win windowNumber)
context: #:type _pointer #f
eventNumber: #:type _NSInteger 0
clickCount: #:type _NSInteger 1
pressure: #:type _float 1.0)
forView: v))))
;; 10.6 and later:
(tellv cocoa-menu
popUpMenuPositioningItem: (tell cocoa-menu itemAtIndex: #:type _NSUInteger 0)
atLocation: #:type _NSPoint (make-NSPoint x y)
inView: v))
(set! popup-box #f)
(let* ([i (unbox b)]
[e (new popup-event% [event-type 'menu-popdown])])
(send e set-menu-id i)
(queue-cb (lambda () (callback this e)))))))
(define/public (item-selected menu-item)
;; called in Cocoa thread
(cond
[popup-box
(set-box! popup-box menu-item)]
[(parent . is-a? . menu%)
(send parent item-selected menu-item)]
[else
(let ([top (get-top-parent)])
(when top
(queue-window-event
top
(lambda () (send top on-menu-command menu-item)))))]))
(define parent #f)
(define/public (set-parent p) (set! parent p))
(define/public (get-top-parent)
;; called in Cocoa thread
(and parent
(if (parent . is-a? . menu%)
(send parent get-top-parent)
(send parent get-top-window))))
(public [append-item append])
(define (append-item i label help-str-or-submenu chckable?)
(send i set-label label)
(when (help-str-or-submenu . is-a? . menu%)
(send i set-submenu help-str-or-submenu)
(send help-str-or-submenu set-parent this))
(set! items (append items (list (make-mitem i chckable?))))
(send i set-parent this)
(when cocoa-menu
(send i install cocoa-menu chckable?)))
(define/public (append-separator)
(set! items (append items (list #f)))
(when cocoa-menu
(tellv cocoa-menu addItem: (tell NSMenuItem separatorItem))))
(def/public-unimplemented select)
(def/public-unimplemented get-font)
(def/public-unimplemented set-width)
(def/public-unimplemented set-title)
(define/public (set-help-string m s) (void))
(def/public-unimplemented number)
(define/private (find-pos item)
(for/or ([i (in-list items)]
[pos (in-naturals)])
(and i
(eq? (mitem-item i) item)
pos)))
(define/public (adjust item cocoa-cb cb)
(let ([pos (find-pos item)])
(when pos
(when cocoa-menu
(cocoa-cb (tell cocoa-menu itemAtIndex: #:type _NSInteger pos)))
(cb (list-ref items pos)))))
(define/public (set-label item label)
(adjust item
(lambda (item-cocoa)
(tellv item-cocoa setTitle: #:type _NSString (clean-menu-label (regexp-replace #rx"\t.*" label "")))
(set-menu-item-shortcut item-cocoa label))
(lambda (mitem)
(send (mitem-item mitem) set-label (clean-menu-label label)))))
(define/public (check item on?)
(adjust item
(lambda (item-cocoa)
(tellv item-cocoa setState: #:type _int (if on? 1 0)))
(lambda (mitem)
(send (mitem-item mitem) set-checked (and on? #t)))))
(define/public (enable item on?)
(adjust item
(lambda (item-cocoa)
(tellv item-cocoa setEnabled: #:type _BOOL on?))
(lambda (mitem)
(send (mitem-item mitem) set-enabled-flag (and on? #t)))))
(define/public (checked? item)
(send item get-checked))
(define/public (delete-by-position pos)
(let ([mitem (list-ref items pos)])
(set! items (append (take items pos)
(drop items (add1 pos))))
(when cocoa-menu
(tellv cocoa-menu removeItemAtIndex: #:type _NSInteger pos))))
(define/public (delete item)
(let ([pos (find-pos item)])
(when pos
(delete-by-position pos)))))

130
collects/mred/private/wx/cocoa/message.rkt Normal file
View File

@ -0,0 +1,130 @@
#lang racket/base
(require racket/class
ffi/unsafe
ffi/unsafe/objc
racket/draw/private/bitmap
"../../syntax.rkt"
"../../lock.rkt"
"window.rkt"
"item.rkt"
"utils.rkt"
"types.rkt"
"image.rkt")
(provide
(protect-out message%))
;; ----------------------------------------
(import-class NSTextField NSImageView NSWorkspace)
(define _OSType _uint32)
(define-cocoa NSFileTypeForHFSTypeCode (_fun _OSType -> _id))
(define (get-app-icon)
(tell (tell NSWorkspace sharedWorkspace)
iconForFile:
(tell (tell (tell NSWorkspace sharedWorkspace)
activeApplication)
objectForKey:
#:type _NSString
"NSApplicationPath")))
(define (make-icon label)
(let ([icon
(if (eq? label 'app)
(get-app-icon)
(let ([id (integer-bytes->integer
(case label
[(caution) #"caut"]
[(stop) #"stop"])
#f
#t)])
(tell (tell NSWorkspace sharedWorkspace)
iconForFileType:
(NSFileTypeForHFSTypeCode id))))])
(tellv icon retain)
(tellv icon setSize: #:type _NSSize (make-NSSize 64 64))
(unless (eq? label 'app)
;; Add badge:
(let ([app-icon (get-icon 'app)])
(tellv icon lockFocus)
(tellv app-icon drawInRect: #:type _NSRect (make-NSRect (make-NSPoint 32 0)
(make-NSSize 32 32))
fromRect: #:type _NSRect (make-NSRect (make-NSPoint 0 0)
(make-NSSize 64 64))
operation: #:type _int 2 ; NSCompositeSourceOver
fraction: #:type _CGFloat 1.0)
(tellv icon unlockFocus)))
icon))
(define icons (make-hash))
(define (get-icon label)
(or (hash-ref icons label #f)
(let ([icon (atomically (make-icon label))])
(hash-set! icons label icon)
icon)))
;; ----------------------------------------
(define-objc-class MyTextField NSTextField
#:mixins (KeyMouseResponder CursorDisplayer)
[wxb])
(define-objc-class MyImageView NSImageView
#:mixins (KeyMouseResponder CursorDisplayer)
[wxb])
(defclass message% item%
(init parent label
x y
style font)
(inherit get-cocoa init-font)
(super-new [parent parent]
[cocoa (let* ([label (cond
[(string? label) label]
[(symbol? label) (get-icon label)]
[(send label ok?) label]
[else "<bad>"])]
[cocoa
(if (string? label)
(as-objc-allocation
(tell (tell MyTextField alloc) init))
(as-objc-allocation
(tell (tell MyImageView alloc) init)))])
(cond
[(string? label)
(init-font cocoa font)
(tellv cocoa setSelectable: #:type _BOOL #f)
(tellv cocoa setEditable: #:type _BOOL #f)
(tellv cocoa setBordered: #:type _BOOL #f)
(tellv cocoa setDrawsBackground: #:type _BOOL #f)
(tellv cocoa setTitleWithMnemonic: #:type _NSString label)
(tellv cocoa sizeToFit)]
[else
(tellv cocoa setImage: (if (label . is-a? . bitmap%)
(bitmap->image label)
label))
(tellv cocoa setFrame: #:type _NSRect
(make-NSRect (make-NSPoint 0 0)
(if (label . is-a? . bitmap%)
(make-NSSize (send label get-width)
(send label get-height))
(tell #:type _NSSize label size))))])
cocoa)]
[callback void]
[no-show? (memq 'deleted style)])
(define/override (set-label label)
(cond
[(string? label)
(tellv (get-cocoa) setTitleWithMnemonic: #:type _NSString label)]
[else
(tellv (get-cocoa) setImage: (bitmap->image label))]))
(define/override (gets-focus?) #f)
(def/public-unimplemented get-font))

95
collects/mred/private/wx/cocoa/panel.rkt Normal file
View File

@ -0,0 +1,95 @@
#lang racket/base
(require racket/class
ffi/unsafe
ffi/unsafe/objc
"../../syntax.rkt"
"types.rkt"
"utils.rkt"
"window.rkt")
(provide
(protect-out panel%
panel-mixin))
(import-class NSView)
(define-objc-class MyPanelView NSView
#:mixins (KeyMouseTextResponder CursorDisplayer)
[wxb])
(define (panel-mixin %)
(class %
(inherit register-as-child on-new-child
is-window-enabled?)
(define lbl-pos 'horizontal)
(define children null)
(super-new)
(define/public (get-label-position) lbl-pos)
(define/public (set-label-position pos) (set! lbl-pos pos))
(define/override (fix-dc)
(for ([child (in-list children)])
(send child fix-dc)))
(define/override (hide-children)
(for ([child (in-list children)])
(send child hide-children)))
(define/override (show-children)
(for ([child (in-list children)])
(send child show-children)))
(define/override (fixup-locations-children)
(for ([child (in-list children)])
(send child fixup-locations-children)))
(define/override (paint-children)
(for ([child (in-list children)])
(send child paint-children)))
(define/override (children-accept-drag on?)
(for ([child (in-list children)])
(send child child-accept-drag on?)))
(define/override (enable-window on?)
(let ([on? (and on? (is-window-enabled?))])
(for ([child (in-list children)])
(send child enable-window on?))))
(define/override (set-size x y w h)
(super set-size x y w h)
(fix-dc))
(define/override (maybe-register-as-child parent on?)
(register-as-child parent on?))
(define/override (register-child child on?)
(let ([now-on? (and (memq child children) #t)])
(unless (eq? on? now-on?)
(set! children
(if on?
(cons child children)
(remq child children)))
(on-new-child child on?))))
(define/override (show on?)
(super show on?)
(fix-dc))
(define/public (set-item-cursor x y) (void))))
(defclass panel% (panel-mixin window%)
(init parent
x y w h
style
label)
(super-new [parent parent]
[cocoa
(as-objc-allocation
(tell (tell MyPanelView alloc)
initWithFrame: #:type _NSRect (make-NSRect (make-init-point x y)
(make-NSSize (max 1 w) (max 1 h)))))]
[no-show? (memq 'deleted style)]))

89
collects/mred/private/wx/cocoa/platform.rkt Normal file
View File

@ -0,0 +1,89 @@
#lang racket/base
(require "init.rkt"
"button.rkt"
"canvas.rkt"
"check-box.rkt"
"choice.rkt"
"clipboard.rkt"
"cursor.rkt"
"dialog.rkt"
"frame.rkt"
"gauge.rkt"
"group-panel.rkt"
"item.rkt"
"list-box.rkt"
"menu.rkt"
"menu-bar.rkt"
"menu-item.rkt"
"message.rkt"
"panel.rkt"
"printer-dc.rkt"
"radio-box.rkt"
"slider.rkt"
"tab-panel.rkt"
"window.rkt"
"procs.rkt")
(provide (protect-out platform-values))
(define (platform-values)
(values
button%
canvas%
check-box%
choice%
clipboard-driver%
cursor-driver%
dialog%
frame%
gauge%
group-panel%
item%
list-box%
menu%
menu-bar%
menu-item%
message%
panel%
printer-dc%
radio-box%
slider%
tab-panel%
window%
can-show-print-setup?
show-print-setup
id-to-menu-item
file-selector
is-color-display?
get-display-depth
has-x-selection?
hide-cursor
bell
display-size
display-origin
flush-display
fill-private-color
cancel-quit
get-control-font-face
get-control-font-size
get-control-font-size-in-pixels?
get-double-click-time
run-printout
file-creator-and-type
location->window
shortcut-visible-in-label?
unregister-collecting-blit
register-collecting-blit
find-graphical-system-path
play-sound
get-panel-background
font-from-user-platform-mode
get-font-from-user
color-from-user-platform-mode
get-color-from-user
special-option-key
special-control-key
get-highlight-background-color
get-highlight-text-color
make-screen-bitmap
make-gl-bitmap
check-for-break))

45
collects/mred/private/wx/cocoa/pool.rkt Normal file
View File

@ -0,0 +1,45 @@
#lang racket/base
(require ffi/unsafe
ffi/unsafe/objc
ffi/unsafe/atomic
"utils.rkt"
"const.rkt"
"types.rkt")
(provide
(protect-out queue-autorelease-flush
autorelease-flush))
(import-class NSAutoreleasePool)
;; This pool manages all objects that would otherwise not
;; have a pool:
(define pool (tell (tell NSAutoreleasePool alloc) init))
;; We need to periodically flush the main pool, otherwise
;; object autoreleased through the pool live until the
;; end of execution:
(define (autorelease-flush)
(start-atomic)
(tellv pool drain)
(set! pool (tell (tell NSAutoreleasePool alloc) init))
(end-atomic))
(define queued? #f)
(define autorelease-evt (make-semaphore))
(define (queue-autorelease-flush)
(start-atomic)
(unless queued?
(semaphore-post autorelease-evt)
(set! queued? #t))
(end-atomic))
;; Create a thread to periodically flush:
(void
(thread (lambda ()
(let loop ()
(sync autorelease-evt)
(set! queued? #f)
(autorelease-flush)
(loop)))))

208
collects/mred/private/wx/cocoa/printer-dc.rkt Normal file
View File

@ -0,0 +1,208 @@
#lang racket/base
(require racket/class
racket/math
racket/draw/private/local
racket/draw/private/dc
racket/draw/unsafe/cairo
racket/draw/private/bitmap
racket/draw/private/bitmap-dc
racket/draw/private/record-dc
racket/draw/private/ps-setup
ffi/unsafe
ffi/unsafe/objc
"../../lock.rkt"
"dc.rkt"
"frame.rkt"
"bitmap.rkt"
"cg.rkt"
"utils.rkt"
"types.rkt")
(provide
(protect-out printer-dc%
show-print-setup))
(import-class NSPrintOperation NSView NSGraphicsContext
NSPrintInfo NSDictionary NSPageLayout
NSNumber)
(define NSPortraitOrientation 0)
(define NSLandscapeOrientation 1)
(define-cocoa NSPrintScalingFactor _id)
(define-objc-class PrinterView NSView
[wxb]
[-a _BOOL (knowsPageRange: [_NSRange-pointer rng])
(set-NSRange-location! rng 1)
(set-NSRange-length! rng (let ([wx (->wx wxb)])
(if wx
(send wx get-page-count)
0)))
#t]
[-a _NSRect (rectForPage: [_NSInteger n])
(let ([wx (->wx wxb)])
(if wx
(send wx get-rect-for-page n)
(make-NSRect (make-NSPoint 0 0)
(make-NSSize 10 10))))]
[-a _void (beginPageInRect: [_NSRect aRect] atPlacement: [_NSPoint location])
(let ([wx (->wx wxb)])
(when wx
(send wx start-page-at aRect)))
(super-tell #:type _void beginPageInRect: #:type _NSRect aRect atPlacement: #:type _NSPoint location)]
[-a _void (drawPageBorderWithSize: [_NSSize size])
(let ([wx (->wx wxb)])
(when wx
(send wx draw-print-page self size)))])
(define (make-print-info [prev #f])
(as-objc-allocation-with-retain
(tell (tell NSPrintInfo alloc)
initWithDictionary:
(if prev
(tell prev dictionary)
(tell NSDictionary dictionary)))))
(define (get-scaling-factor print-info)
;; 10.6 only:
#;
(tell #:type _CGFloat print-info scalingFactor)
(atomically
(with-autorelease
(tell #:type _double
(tell (tell print-info dictionary)
objectForKey: NSPrintScalingFactor)
doubleValue))))
(define (install-pss-to-print-info pss print-info)
(tellv print-info setOrientation: #:type _int (if (eq? (send pss get-orientation) 'landscape)
NSLandscapeOrientation
NSPortraitOrientation))
(let ([scale (let ([x (box 0)]
[y (box 0)])
(send pss get-scaling x y)
(unbox y))])
;; 10.6 only:
#;
(tellv print-info setScalingFactor: #:type _CGFloat scale)
(atomically
(with-autorelease
(tellv (tell print-info dictionary)
setObject: (tell NSNumber numberWithDouble: #:type _double scale)
forKey: NSPrintScalingFactor)))))
(define NSOkButton 1)
(define (show-print-setup parent)
(let* ([pss (current-ps-setup)]
[print-info (let ([pi (send pss get-native)])
(or pi
(let ([pi (make-print-info)])
(send pss set-native pi make-print-info)
pi)))])
(install-pss-to-print-info pss print-info)
(if (atomically
(let ([front (get-front)])
(begin0
(= (tell #:type _NSInteger (tell NSPageLayout pageLayout) runModalWithPrintInfo: print-info)
NSOkButton)
(when front
(tellv (send front get-cocoa-window) makeKeyAndOrderFront: #f)))))
(begin
(let ([o (tell #:type _int print-info orientation)])
(send pss set-orientation (if (= o NSLandscapeOrientation)
'landscape
'portrait)))
(let ([s (get-scaling-factor print-info)])
(send pss set-scaling s s))
#t)
#f)))
(define printer-dc%
(class (record-dc-mixin (dc-mixin bitmap-dc-backend%))
(init [parent #f])
(super-make-object (make-object quartz-bitmap% 1 1))
(inherit get-recorded-command
reset-recording)
(define pages null)
(define/override (end-page)
(set! pages (cons (get-recorded-command) pages))
(reset-recording))
(define print-info (or (let-values ([(pi copier)
(send (current-ps-setup)
get-native-copy)])
pi)
(make-print-info)))
(install-pss-to-print-info (current-ps-setup) print-info)
(define-values (page-width page-height page-scaling)
(let ([s (NSRect-size (tell #:type _NSRect print-info imageablePageBounds))]
[scaling (get-scaling-factor print-info)])
(values (NSSize-width s)
(NSSize-height s)
scaling)))
(define/override (get-size)
(values (/ page-width page-scaling) (/ page-height page-scaling)))
(define current-page 0)
(define/public (get-page-count) (length pages))
(define/public (get-rect-for-page i)
(make-NSRect (make-NSPoint 0 (* (sub1 i) page-height))
(make-NSSize page-width page-height)))
(define/public (start-page-at r)
(set! current-page (inexact->exact (round (/ (NSPoint-y (NSRect-origin r)) page-height)))))
(define/public (draw-print-page view-cocoa s)
(let ([f (tell #:type _NSRect view-cocoa frame)])
(tellv view-cocoa lockFocus)
(let ([cg (tell #:type _CGContextRef (tell NSGraphicsContext currentContext) graphicsPort)]
[s (tell #:type _NSSize print-info paperSize)]
[b (tell #:type _NSRect print-info imageablePageBounds)])
(CGContextTranslateCTM cg 0 (/ (NSSize-height s) page-scaling))
(CGContextScaleCTM cg 1 -1)
(CGContextTranslateCTM cg
(/ (NSPoint-x (NSRect-origin b)) page-scaling)
(/ (- (NSSize-height s)
(+ (NSPoint-y (NSRect-origin b))
(NSSize-height (NSRect-size b))))
page-scaling))
(let* ([surface (cairo_quartz_surface_create_for_cg_context cg
(inexact->exact (ceiling page-width))
(inexact->exact (ceiling page-height)))]
[cr (cairo_create surface)])
(cairo_surface_destroy surface)
(let ([dc (make-object (dc-mixin
(class default-dc-backend%
(define/override (get-cr) cr)
(super-new))))])
(let ([proc (list-ref (reverse pages) current-page)])
(proc dc)))
(cairo_destroy cr)))
(tellv view-cocoa unlockFocus)))
(define/override (end-doc)
(define view-cocoa (as-objc-allocation-with-retain
(tell (tell PrinterView alloc)
initWithFrame: #:type _NSRect (make-NSRect
(make-NSPoint 0 0)
(make-NSSize 10 10)))))
(define op-cocoa (as-objc-allocation-with-retain
(tell NSPrintOperation printOperationWithView: view-cocoa
printInfo: print-info)))
(set-ivar! view-cocoa wxb (->wxb this))
(atomically
(let ([front (get-front)])
(tellv op-cocoa runOperation)
(when front
(tellv (send front get-cocoa-window) makeKeyAndOrderFront: #f)))))))

157
collects/mred/private/wx/cocoa/procs.rkt Normal file
View File

@ -0,0 +1,157 @@
#lang racket/base
(require "../../syntax.rkt"
racket/class
racket/draw
ffi/unsafe
ffi/unsafe/objc
"utils.rkt"
"types.rkt"
"frame.rkt"
"window.rkt"
"finfo.rkt" ; file-creator-and-type
"filedialog.rkt"
"colordialog.rkt"
"dc.rkt"
"bitmap.rkt"
"printer-dc.rkt"
"../common/printer.rkt"
"menu-bar.rkt"
"agl.rkt"
"sound.rkt"
"../../lock.rkt"
"../common/handlers.rkt"
(except-in "../common/default-procs.rkt"
special-control-key
special-option-key
file-creator-and-type))
(provide
(protect-out
color-from-user-platform-mode
font-from-user-platform-mode
get-font-from-user
find-graphical-system-path
register-collecting-blit
unregister-collecting-blit
shortcut-visible-in-label?
run-printout
get-double-click-time
get-control-font-face
get-control-font-size
get-control-font-size-in-pixels?
cancel-quit
display-origin
display-size
bell
hide-cursor
get-display-depth
is-color-display?
id-to-menu-item
can-show-print-setup?
get-highlight-background-color
get-highlight-text-color
check-for-break)
make-screen-bitmap
make-gl-bitmap
show-print-setup
get-color-from-user
get-panel-background
fill-private-color
flush-display
play-sound
file-creator-and-type
file-selector)
(import-class NSScreen NSCursor)
(define (find-graphical-system-path what)
#f)
(define (color-from-user-platform-mode) "Show Picker")
(define-unimplemented get-font-from-user)
(define (font-from-user-platform-mode) #f)
(define (register-collecting-blit canvas x y w h on off on-x on-y off-x off-y)
(send canvas register-collecting-blit x y w h on off on-x on-y off-x off-y))
(define (unregister-collecting-blit canvas)
(send canvas unregister-collecting-blits))
(define (shortcut-visible-in-label? [x #f]) #f)
(define run-printout (make-run-printout printer-dc%))
(define (get-double-click-time)
500)
(define (get-control-font-face) "Lucida Grande")
(define (get-control-font-size) 13)
(define (get-control-font-size-in-pixels?) #f)
(define (cancel-quit) (void))
(define (check-for-break) #f)
(define (display-origin xb yb all?)
(if all?
(atomically
(with-autorelease
(let* ([screen (tell (tell NSScreen screens) objectAtIndex: #:type _NSUInteger 0)]
[f (tell #:type _NSRect screen visibleFrame)])
(set-box! xb (->long (NSPoint-x (NSRect-origin f)))))))
(set-box! xb 0))
(set-box! yb (get-menu-bar-height)))
(define (display-size xb yb all?)
(atomically
(with-autorelease
(let* ([screen (tell (tell NSScreen screens) objectAtIndex: #:type _NSUInteger 0)]
[f (if all?
(tell #:type _NSRect screen frame)
(tell #:type _NSRect screen visibleFrame))])
(set-box! xb (->long (NSSize-width (NSRect-size f))))
(set-box! yb (->long (NSSize-height (NSRect-size f))))))))
(define-appkit NSBeep (_fun -> _void))
(define (bell) (NSBeep))
(define (hide-cursor)
(tellv NSCursor setHiddenUntilMouseMoves: #:type _BOOL #t))
(define (get-display-depth) 32)
(define (is-color-display?) #t)
(define (id-to-menu-item id) id)
(define (can-show-print-setup?) #t)
(define/top (make-screen-bitmap [exact-positive-integer? w]
[exact-positive-integer? h])
(make-object quartz-bitmap% w h))
(define/top (make-gl-bitmap [exact-positive-integer? w]
[exact-positive-integer? h]
[gl-config% c])
(create-gl-bitmap w h c))
;; ------------------------------------------------------------
;; Text & highlight color
(import-class NSColor)
(define-cocoa NSDeviceRGBColorSpace _id)
(define (get-highlight-background-color)
(let ([hi (as-objc-allocation-with-retain
(tell (tell NSColor selectedTextBackgroundColor)
colorUsingColorSpaceName: NSDeviceRGBColorSpace))]
[as-color (lambda (v)
(inexact->exact (floor (* 255.0 v))))])
(begin0
(make-object color%
(as-color
(tell #:type _CGFloat hi redComponent))
(as-color
(tell #:type _CGFloat hi greenComponent))
(as-color
(tell #:type _CGFloat hi blueComponent)))
(release hi))))
(define (get-highlight-text-color)
#f)

394
collects/mred/private/wx/cocoa/queue.rkt Normal file
View File

@ -0,0 +1,394 @@
#lang racket/base
(require ffi/unsafe/objc
ffi/unsafe
racket/class
racket/draw/private/dc
"pool.rkt"
"utils.rkt"
"const.rkt"
"types.rkt"
"../common/queue.rkt"
"../common/handlers.rkt"
"../../lock.rkt"
"../common/freeze.rkt")
(provide
(protect-out app
cocoa-start-event-pump
cocoa-install-event-wakeup
set-eventspace-hook!
set-front-hook!
set-menu-bar-hooks!
set-fixup-window-locations!
post-dummy-event
try-to-sync-refresh)
;; from common/queue:
current-eventspace
queue-event
yield)
(import-class NSApplication NSAutoreleasePool NSColor NSProcessInfo NSArray)
(import-protocol NSApplicationDelegate)
;; Extreme hackery to hide original arguments from
;; NSApplication, because NSApplication wants to turn
;; the arguments into `application:openFile:' calls.
;; To hide the arguments, we replace the implementation
;; of `arguments' in the NSProcessInfo object.
(define (hack-argument-replacement self method)
(tell NSArray
arrayWithObjects: #:type (_vector i _NSString) (vector (path->string (find-system-path 'exec-file)))
count: #:type _NSUInteger 1))
(let ([m (class_getInstanceMethod NSProcessInfo (selector arguments))])
(void (method_setImplementation m hack-argument-replacement)))
(define app (tell NSApplication sharedApplication))
(define-objc-class MyApplicationDelegate NSObject #:protocols (NSApplicationDelegate)
[]
[-a _int (applicationShouldTerminate: [_id app])
(queue-quit-event)
0]
[-a _BOOL (openPreferences: [_id app])
(queue-prefs-event)
#t]
[-a _BOOL (validateMenuItem: [_id menuItem])
(if (ptr-equal? (selector openPreferences:)
(tell #:type _SEL menuItem action))
(not (eq? (application-pref-handler) nothing-application-pref-handler))
(super-tell #:type _BOOL validateMenuItem: menuItem))]
[-a _BOOL (application: [_id theApplication] openFile: [_NSString filename])
(queue-file-event (string->path filename))]
[-a _BOOL (applicationShouldHandleReopen: [_id app] hasVisibleWindows: [_BOOL has-visible?])
;; If we have any visible windows, return #t to do the default thing.
;; Otherwise return #f, because we don't want any invisible windows resurrected.
has-visible?]
[-a _void (applicationDidChangeScreenParameters: notification)
;; Screen changes sometimes make the event loop get stuck;
;; hack: schedule a wake-up call in 5 seconds
(let ([priviledged-custodian ((get-ffi-obj 'scheme_make_custodian #f (_fun _pointer -> _scheme)) #f)])
(parameterize ([current-custodian priviledged-custodian])
(thread (lambda () (sleep 5.0)))))
;; Also need to reset blit windows, since OS may move them incorrectly:
(fixup-window-locations)])
(define fixup-window-locations void)
(define (set-fixup-window-locations! f) (set! fixup-window-locations f))
;; In case we were started in an executable without a bundle,
;; explicitly register with the dock so the application can receive
;; keyboard events.
(define-cstruct _ProcessSerialNumber
([highLongOfPSN _ulong]
[lowLongOfPSN _ulong]))
(define kCurrentProcess 2)
(define kProcessTransformToForegroundApplication 1)
(define-appserv TransformProcessType (_fun _ProcessSerialNumber-pointer
_uint32
-> _OSStatus))
(void (TransformProcessType (make-ProcessSerialNumber 0 kCurrentProcess)
kProcessTransformToForegroundApplication))
(define app-delegate (tell (tell MyApplicationDelegate alloc) init))
(tellv app setDelegate: app-delegate)
(unless (scheme_register_process_global "Racket-GUI-no-front" #f)
(tellv app activateIgnoringOtherApps: #:type _BOOL #t))
;; For some reason, nextEventMatchingMask:... gets stuck if the
;; display changes, and it doesn't even send the
;; `applicationDidChangeScreenParameters:' callback. Unstick
;; it by posting a dummy event, since we fortunately can receive
;; a callback via CGDisplayRegisterReconfigurationCallback().
;; This seems to unstick things enough that `applicationDidChangeScreenParameters:'
;; is called, but sometimes the event loop gets stuck after
;; that, so there's an additional hack above.
(define-appserv CGDisplayRegisterReconfigurationCallback
(_fun (_fun #:atomic? #t -> _void) _pointer -> _int32))
(define (on-screen-changed) (post-dummy-event))
(void
(CGDisplayRegisterReconfigurationCallback on-screen-changed #f))
(tellv app finishLaunching)
;; ------------------------------------------------------------
;; Create an event to post when MzScheme has been sleeping but is
;; ready to wake up
(import-class NSEvent)
(define wake-evt
(tell NSEvent
otherEventWithType: #:type _int NSApplicationDefined
location: #:type _NSPoint (make-NSPoint 0.0 0.0)
modifierFlags: #:type _NSUInteger 0
timestamp: #:type _double 0.0
windowNumber: #:type _NSUInteger 0
context: #:type _pointer #f
subtype: #:type _short 0
data1: #:type _NSInteger 0
data2: #:type _NSInteger 0))
(retain wake-evt)
(define (post-dummy-event)
(tell #:type _void app postEvent: wake-evt atStart: #:type _BOOL YES))
;; This callback will be invoked by the CoreFoundation run loop
;; when data is available on `ready_sock', which is used to indicate
;; that MzScheme would like to wake up (and posting a Cocoa event
;; causes the event-getting function to unblock).
(define (socket_callback)
(read2 ready_sock read-buf 1)
(post-dummy-event))
;; ------------------------------------------------------------
;; Create a pipe's pair of file descriptors, used to communicate
;; from the MzScheme-sleep thread to the CoreFoundation run loop.
(define pipe2 (get-ffi-obj 'pipe #f (_fun _pointer -> _int)))
(define write2 (get-ffi-obj 'write #f (_fun _int _pointer _long -> _long)))
(define read2 (get-ffi-obj 'read #f (_fun _int _pointer _long -> _long)))
(define read-buf (make-bytes 1))
(define-values (ready_sock write_sock)
(let ([s (malloc 'raw 2 _int)])
(unless (zero? (pipe2 s))
(error "pipe didn't create fds"))
(let ([r (ptr-ref s _int 0)]
[w (ptr-ref s _int 1)])
(free s)
(values r w))))
;; ------------------------------------------------------------
;; Register the event-posting callback on `ready_sock' with
;; the CoreFoundation run loop
(define _CFIndex _uint)
(define _CFStringRef _NSString)
(define-cstruct _CFSocketContext ([version _CFIndex]
[info _pointer]
[retain (_fun _pointer -> _pointer)]
[release (_fun _pointer -> _void)]
[copyDescription (_fun _pointer -> _CFStringRef)]))
(define (sock_retain v) #f)
(define (sock_release v) (void))
(define (sock_copy_desc v) "sock")
(define sock-context (make-CFSocketContext 0 #f sock_retain sock_release sock_copy_desc))
(define _CFRunLoopRef _pointer)
(define _CFAllocatorRef _pointer)
(define _CFSocketRef _pointer)
(define _CFRunLoopSourceRef _pointer)
(define _CFSocketNativeHandle _int)
(define _CFOptionFlags _uint)
(define _CFSocketCallBack (_fun -> _void))
(define-cf CFAllocatorGetDefault (_fun -> _pointer))
(define-cf CFSocketCreateWithNative (_fun _CFAllocatorRef
_CFSocketNativeHandle
_CFOptionFlags
_CFSocketCallBack
_CFSocketContext-pointer
-> _CFSocketRef))
(define-cf CFSocketCreateRunLoopSource (_fun _CFAllocatorRef
_CFSocketRef
_CFIndex
-> _CFRunLoopSourceRef))
(define-cf CFRunLoopAddSource (_fun _CFRunLoopRef
_CFRunLoopSourceRef
_CFStringRef
-> _void))
(define-cf kCFRunLoopDefaultMode _CFStringRef)
(define kCFSocketReadCallBack 1)
(import-class NSRunLoop)
(let* ([rl (tell #:type _CFRunLoopRef (tell NSRunLoop currentRunLoop) getCFRunLoop)]
[cfs (CFSocketCreateWithNative (CFAllocatorGetDefault) ready_sock kCFSocketReadCallBack
socket_callback sock-context)]
[source (CFSocketCreateRunLoopSource (CFAllocatorGetDefault) cfs 0)])
(CFRunLoopAddSource rl source kCFRunLoopDefaultMode))
;; ------------------------------------------------------------
;; Another hack:
;; Install a run-loop observer that noticed when the core run loop
;; is exited multiple times during a single wait for a Cocoa event.
;; When that happens, it's a sign that something has gone wrong,
;; and we should interrupt the event wait and try again. This happens
;; when the user hides the application and then clicks on the dock
;; icon. (But why does that happen?)
(define _Boolean _BOOL)
(define-cf kCFRunLoopCommonModes _pointer)
(define-cf CFRunLoopObserverCreate (_fun _pointer ; CFAllocatorRef
_int ; CFOptionFlags
_Boolean ; repeats?
_CFIndex ; order
(_fun #:atomic? #t _pointer _int _pointer -> _void)
_pointer ; CFRunLoopObserverContext
-> _pointer))
(define-cf CFRunLoopAddObserver (_fun _pointer _pointer _pointer -> _void))
(define-cf CFRunLoopGetMain (_fun -> _pointer))
(define kCFRunLoopExit (arithmetic-shift 1 7))
(define-mz scheme_signal_received (_fun -> _void))
(define already-exited? #f)
(define sleeping? #f)
(define (exiting-run-loop x y z)
(when sleeping?
(if already-exited?
(scheme_signal_received)
(set! already-exited? #t))))
(let ([o (CFRunLoopObserverCreate #f kCFRunLoopExit #t 0 exiting-run-loop #f)])
(CFRunLoopAddObserver (CFRunLoopGetMain) o kCFRunLoopCommonModes))
;; ------------------------------------------------------------
;; Cocoa event pump
(define-cocoa NSDefaultRunLoopMode _id) ; more specifically an _NSString, but we don't need a conversion
(import-class NSDate)
(define distantFuture (tell NSDate distantFuture))
(define eventspace-hook (lambda (e) #f))
(define (set-eventspace-hook! proc) (set! eventspace-hook proc))
(define front-hook (lambda () (values #f #f)))
(define (set-front-hook! proc) (set! front-hook proc))
(define in-menu-bar-range? (lambda (p) #f))
(define (set-menu-bar-hooks! r?)
(set! in-menu-bar-range? r?))
(define events-suspended? #f)
(define was-menu-bar #f)
(define avoid-mouse-key-until #f)
(define (check-menu-bar-click evt)
(if (and evt
(= 14 (tell #:type _NSUInteger evt type))
(= 7 (tell #:type _short evt subtype))
(not (tell evt window))
(in-menu-bar-range? (tell #:type _NSPoint evt locationInWindow)))
;; Mouse down in the menu bar:
(let-values ([(f e) (front-hook)])
(when e
;; Avoid spiral of on-demand calls:
(unless (and was-menu-bar
(eq? e (weak-box-value was-menu-bar)))
;; Don't handle further events until we've made an effort
;; at on-demand notifications.
(set! was-menu-bar (make-weak-box e))
(set! events-suspended? #t)
(let* ([c (make-custodian)]
[t (parameterize ([current-custodian c])
(thread (lambda ()
(sleep 2)
;; on-demand took too long, so wait
;; until the application can catch up
(set! events-suspended? #f))))])
(queue-event e (lambda ()
(send f on-menu-click)
(set! events-suspended? #f)
(custodian-shutdown-all c)))))))
(set! was-menu-bar #f)))
;; Call this function only in atomic mode:
(define (check-one-event wait? dequeue?)
(pre-event-sync wait?)
(clean-up-deleted)
(let ([pool (tell (tell NSAutoreleasePool alloc) init)])
(when (and events-suspended? wait?)
(set! was-menu-bar #f)
(set! events-suspended? #f))
(when (and avoid-mouse-key-until
((current-inexact-milliseconds) . > . avoid-mouse-key-until))
(set! avoid-mouse-key-until #f))
(begin0
(let ([evt (if events-suspended?
#f
(tell app nextEventMatchingMask: #:type _NSUInteger (if (and (not wait?)
avoid-mouse-key-until)
(- NSAnyEventMask
MouseAndKeyEventMask)
NSAnyEventMask)
untilDate: (if wait? distantFuture #f)
inMode: NSDefaultRunLoopMode
dequeue: #:type _BOOL dequeue?))])
(when evt (check-menu-bar-click evt))
(and evt
(or (not dequeue?)
(let ([e (eventspace-hook (tell evt window))])
(if e
(let ([mouse-or-key?
(bitwise-bit-set? MouseAndKeyEventMask
(tell #:type _NSInteger evt type))])
;; If it's a mouse or key event, delay further
;; dequeue of mouse and key events until this
;; one can be handled.
(when mouse-or-key?
(set! avoid-mouse-key-until
(+ (current-inexact-milliseconds) 200.0)))
(retain evt)
(queue-event e (lambda ()
(call-as-nonatomic-retry-point
(lambda ()
;; in atomic mode
(with-autorelease
(tellv app sendEvent: evt)
(release evt))))
(when mouse-or-key?
(set! avoid-mouse-key-until #f)))))
(tellv app sendEvent: evt)))
#t)))
(tellv pool release))))
;; Call this function only in atomic mode:
(define (dispatch-all-ready)
(when (check-one-event #f #t)
(dispatch-all-ready)))
(define (cocoa-start-event-pump)
(thread (lambda ()
(let loop ()
;; Wait 50 msecs between event polling, unless nothing
;; else is going on:
(sync/timeout 0.05 (system-idle-evt))
;; Wait until event is ready --- but waiting is implemented
;; by polling:
(sync queue-evt)
;; Something is ready, so dispatch:
(atomically (dispatch-all-ready))
;; Periodically free everything in the default allocation pool:
(queue-autorelease-flush)
(loop)))))
(set-check-queue!
;; Called through an atomic callback:
(lambda () (check-one-event #f #f)))
(define (try-to-sync-refresh)
;; atomically => outside of the event loop
(atomically
(pre-event-sync #t)))
;; ------------------------------------------------------------
;; Install an alternate "sleep" function (in the PLT Scheme core)
;; that wakes up if any Cocoa event is ready.
(define-mz scheme_start_sleeper_thread (_fun _fpointer _float _pointer _int -> _void))
(define-mz scheme_end_sleeper_thread (_fun -> _void))
(define-mz scheme_sleep _pointer)
;; Called through an atomic callback:
(define (sleep-until-event secs fds)
(set! sleeping? #t)
(set! already-exited? #f)
(scheme_start_sleeper_thread scheme_sleep secs fds write_sock)
(check-one-event #t #f) ; blocks until an event is ready
(scheme_end_sleeper_thread)
(set! sleeping? #f))
(define (cocoa-install-event-wakeup)
(post-dummy-event) ; why do we need this? 'nextEventMatchingMask:' seems to hang if we don't use it
(set-ffi-obj! 'scheme_sleep #f _pointer (function-ptr sleep-until-event
(_fun #:atomic? #t
_float _pointer -> _void))))

143
collects/mred/private/wx/cocoa/radio-box.rkt Normal file
View File

@ -0,0 +1,143 @@
#lang racket/base
(require racket/class
ffi/unsafe
ffi/unsafe/objc
"../../syntax.rkt"
"item.rkt"
"button.rkt"
"types.rkt"
"const.rkt"
"utils.rkt"
"window.rkt"
"../common/event.rkt"
"image.rkt")
(provide
(protect-out radio-box%))
;; ----------------------------------------
(import-class NSMatrix NSButtonCell)
(define NSRadioModeMatrix 0)
(define NSListModeMatrix 2)
(define-objc-class MyMatrix NSMatrix
#:mixins (FocusResponder KeyMouseResponder CursorDisplayer)
[wxb]
(-a _void (clicked: [_id sender])
(queue-window*-event wxb (lambda (wx) (send wx clicked)))))
(define-objc-class MyImageButtonCell NSButtonCell
[img]
[-a _NSSize (cellSize)
(let ([s (super-tell #:type _NSSize cellSize)])
(if img
(let ([s2 (tell #:type _NSSize img size)])
(make-NSSize (+ (NSSize-width s) (NSSize-width s2))
(max (NSSize-height s) (NSSize-height s2))))
s))]
[-a _void (drawInteriorWithFrame: [_NSRect f] inView: [_id view])
(super-tell #:type _void drawInteriorWithFrame: #:type _NSRect f inView: view)
(when img
(let ([size (tell #:type _NSSize img size)])
(tellv img
drawInRect: #:type _NSRect (make-NSRect
(make-NSPoint
(+ (NSPoint-x (NSRect-origin f))
(- (NSSize-width (NSRect-size f))
(NSSize-width size)))
(+ (NSPoint-y (NSRect-origin f))
(quotient (- (NSSize-height (NSRect-size f))
(NSSize-height size))
2)))
size)
fromRect: #:type _NSRect (make-NSRect (make-NSPoint 0 0) size)
operation: #:type _int 1
fraction: #:type _CGFloat 1.0)))])
(defclass radio-box% item%
(init parent cb label
x y w h
labels
val
style
font)
(inherit get-cocoa set-focus init-font register-as-child)
(define horiz? (and (memq 'horizontal style) #t))
(super-new [parent parent]
[cocoa
(let ([cocoa
(as-objc-allocation
(tell (tell MyMatrix alloc)
initWithFrame: #:type _NSRect (make-NSRect (make-init-point x y)
(make-NSSize w h))
mode: #:type _int NSRadioModeMatrix
cellClass: (if (andmap string? labels)
NSButtonCell
MyImageButtonCell)
numberOfRows: #:type _NSInteger (if horiz? 1 (length labels))
numberOfColumns: #:type _NSInteger (if horiz? (length labels) 1)))])
(for ([label (in-list labels)]
[i (in-naturals)])
(let ([button (tell cocoa
cellAtRow: #:type _NSInteger (if horiz? 0 i)
column: #:type _NSInteger (if horiz? i 0))])
(if (and (not (string? label))
(send label ok?))
(begin
(tellv button setTitle: #:type _NSString "")
(set-ivar! button img (bitmap->image label)))
(begin
(init-font button font)
(tellv button setTitleWithMnemonic: #:type _NSString (if (string? label)
label
"<bad>"))))
(tellv button setButtonType: #:type _int NSRadioButton)))
(tellv cocoa sizeToFit)
(tellv cocoa setTarget: cocoa)
(tellv cocoa setAction: #:type _SEL (selector clicked:))
cocoa)]
[callback cb]
[no-show? (memq 'deleted style)])
(define count (length labels))
(define callback cb)
(define/public (clicked)
(callback this (new control-event%
[event-type 'radio-box]
[time-stamp (current-milliseconds)])))
(define/public (button-focus i)
(if (= i -1)
0
(set-focus)))
(define/private (get-button i)
(tell (get-cocoa)
cellAtRow: #:type _NSUInteger (if horiz? 0 i)
column: #:type _NSUInteger (if horiz? i 0)))
(define/public (enable-button i on?)
(tellv (get-button i) setEnabled: #:type _BOOL on?))
(define/public (set-selection i)
(if (= i -1)
(begin
;; Need to change to NSListModeMatrix to disable all.
;; It seem that we don't have to change the mode back, for some reason.
(tellv (get-cocoa) setMode: #:type _int NSListModeMatrix)
(tellv (get-cocoa) deselectAllCells))
(tellv (get-cocoa) selectCellAtRow: #:type _NSInteger (if horiz? 0 i)
column: #:type _NSInteger (if horiz? i 0))))
(define/public (get-selection)
(if horiz?
(tell #:type _NSInteger (get-cocoa) selectedColumn)
(tell #:type _NSInteger (get-cocoa) selectedRow)))
(define/public (number) count)
(define/override (maybe-register-as-child parent on?)
(register-as-child parent on?)))

163
collects/mred/private/wx/cocoa/slider.rkt Normal file
View File

@ -0,0 +1,163 @@
#lang racket/base
(require racket/class
ffi/unsafe
ffi/unsafe/objc
"../../syntax.rkt"
"item.rkt"
"types.rkt"
"const.rkt"
"utils.rkt"
"window.rkt"
"../common/event.rkt"
"../common/queue.rkt"
"../common/freeze.rkt"
"../../lock.rkt")
(provide
(protect-out slider%))
;; ----------------------------------------
(import-class NSSlider NSTextField NSView)
(define-objc-class MySlider NSSlider
#:mixins (FocusResponder KeyMouseResponder CursorDisplayer)
[wxb]
(-a _void (changed: [_id sender])
(let ([wx (->wx wxb)])
(when wx
(send wx update-message)
(queue-window-event wx (lambda () (send wx changed)))
(constrained-reply
(send wx get-eventspace)
(lambda () (let loop () (pre-event-sync #t) (when (yield) (loop))))
(void))))))
(defclass slider% item%
(init parent cb
label
val lo hi
x y w
style
font)
(inherit get-cocoa register-as-child
init-font)
(define vert? (memq 'vertical style))
(define slider-cocoa
(let ([cocoa (as-objc-allocation
(tell (tell MySlider alloc) init))])
(tellv cocoa setMinValue: #:type _double* lo)
(tellv cocoa setMaxValue: #:type _double* hi)
(tellv cocoa setDoubleValue: #:type _double* val)
;; heuristic: show up to tick marks:
(when ((- hi lo) . < . 64)
(tellv cocoa setNumberOfTickMarks: #:type _NSUInteger (add1 (- hi lo)))
(tellv cocoa setAllowsTickMarkValuesOnly: #:type _BOOL #t))
(tellv cocoa setFrame: #:type _NSRect (make-NSRect
(make-NSPoint 0 0)
(make-NSSize (if vert? 24 32)
(if vert? 64 24))))
(tellv cocoa setContinuous: #:type _BOOL #t)
;; (tellv cocoa sizeToFit)
cocoa))
(define-values (message-cocoa message-w message-h)
(if (memq 'plain style)
(values #f #f #f)
(let ([cocoa (as-objc-allocation
(tell (tell NSTextField alloc) init))])
(init-font cocoa font)
(tellv cocoa setSelectable: #:type _BOOL #f)
(tellv cocoa setEditable: #:type _BOOL #f)
(tellv cocoa setBordered: #:type _BOOL #f)
(tellv cocoa setDrawsBackground: #:type _BOOL #f)
(tellv cocoa setTitleWithMnemonic: #:type _NSString (format "~a" hi))
(tellv cocoa sizeToFit)
(let ([r1 (tell #:type _NSRect cocoa frame)])
(tellv cocoa setTitleWithMnemonic: #:type _NSString (format "~a" lo))
(tellv cocoa sizeToFit)
(let ([r2 (tell #:type _NSRect cocoa frame)])
(tellv cocoa setTitleWithMnemonic: #:type _NSString (format "~a" val))
(values cocoa
(max (NSSize-width (NSRect-size r1))
(NSSize-width (NSRect-size r2)))
(max (NSSize-height (NSRect-size r1))
(NSSize-height (NSRect-size r2)))))))))
(define cocoa
(if message-cocoa
(let* ([f (tell #:type _NSRect slider-cocoa frame)]
[w (+ (if vert?
message-w
0)
(NSSize-width (NSRect-size f)))]
[h (+ (if vert?
0
message-h)
(NSSize-height (NSRect-size f)))])
(let ([cocoa (as-objc-allocation
(tell (tell NSView alloc)
initWithFrame: #:type _NSRect (make-NSRect
(make-init-point x y)
(make-NSSize w h))))])
(tellv cocoa addSubview: slider-cocoa)
(tellv cocoa addSubview: message-cocoa)
(arrange-parts w h)
cocoa))
slider-cocoa))
(define/private (arrange-parts w h)
(tellv slider-cocoa setFrame: #:type _NSRect (make-NSRect
(make-NSPoint 0
(if vert? 0 message-h))
(make-NSSize (- w (if vert? message-w 0))
(- h (if vert? 0 message-h)))))
(tellv message-cocoa setFrame: #:type _NSRect (make-NSRect
(make-NSPoint (if vert?
(- w message-w)
(/ (- w message-w) 2))
(if vert?
(/ (- h message-h) 2)
0))
(make-NSSize message-w message-h))))
(define/override (set-size x y w h)
(super set-size x y w h)
(when message-cocoa
(arrange-parts w h)))
(when message-cocoa
(set-ivar! slider-cocoa wxb (->wxb this)))
(super-new [parent parent]
[cocoa cocoa]
[callback cb]
[no-show? (memq 'deleted style)])
(define/override (get-cocoa-control) slider-cocoa)
(tellv slider-cocoa setTarget: slider-cocoa)
(tellv slider-cocoa setAction: #:type _SEL (selector changed:))
(define callback cb)
(define/public (changed)
(callback this (new control-event%
[event-type 'slider]
[time-stamp (current-milliseconds)])))
(define/public (set-value v)
(atomically
(tellv slider-cocoa setDoubleValue: #:type _double* v)
(update-message v)))
(define/public (get-value)
(inexact->exact (floor (tell #:type _double slider-cocoa doubleValue))))
(define/public (update-message [val (get-value)])
(tellv message-cocoa setTitleWithMnemonic: #:type _NSString (format "~a" val)))
(define/override (maybe-register-as-child parent on?)
(register-as-child parent on?)))

36
collects/mred/private/wx/cocoa/sound.rkt Normal file
View File

@ -0,0 +1,36 @@
#lang racket/base
(require ffi/unsafe
ffi/unsafe/objc
"utils.rkt"
"types.rkt")
(provide
(protect-out play-sound))
(import-class NSSound)
(define-objc-class MySound NSSound
[result
sema]
[-a _void (sound: [_id sound] didFinishPlaying: [_BOOL ok?])
(set! result ok?)
(semaphore-post sema)
(tellv self release)])
(define (play-sound path async?)
(let ([s (as-objc-allocation
(tell (tell MySound alloc)
initWithContentsOfFile: #:type _NSString (if (path? path)
(path->string path)
path)
byReference: #:type _BOOL #t))]
[sema (make-semaphore)])
(tellv s setDelegate: s)
(set-ivar! s sema sema)
(tellv s retain) ; don't use `retain', because we dont' want auto-release
(tellv s play)
(if async?
(begin
(semaphore-wait sema)
(get-ivar s result))
#t)))

188
collects/mred/private/wx/cocoa/tab-panel.rkt Normal file
View File

@ -0,0 +1,188 @@
#lang racket/base
(require racket/class
ffi/unsafe
ffi/unsafe/objc
racket/runtime-path
"../../syntax.rkt"
"types.rkt"
"utils.rkt"
"window.rkt"
"panel.rkt"
"queue.rkt"
"../common/event.rkt"
"../common/procs.rkt"
(for-syntax racket/base))
(provide
(protect-out tab-panel%))
(define-runtime-path psm-tab-bar-dir
'(so "PSMTabBarControl.framework"))
;; Load PSMTabBarControl:
(void (ffi-lib (build-path psm-tab-bar-dir "PSMTabBarControl")))
(define NSNoTabsNoBorder 6)
(define NSDefaultControlTint 0)
(define NSClearControlTint 7)
(import-class NSView NSTabView NSTabViewItem PSMTabBarControl)
(import-protocol NSTabViewDelegate)
(define NSOrderedAscending -1)
(define NSOrderedSame 0)
(define NSOrderedDescending 1)
(define (order-content-first a b data)
(cond
[(ptr-equal? a data) NSOrderedDescending]
[(ptr-equal? b data) NSOrderedAscending]
[else NSOrderedSame]))
(define order_content_first (function-ptr order-content-first
(_fun #:atomic? #t _id _id _id -> _int)))
(define-objc-class MyTabView NSTabView
#:mixins (FocusResponder KeyMouseResponder CursorDisplayer)
[wxb]
(-a _void (tabView: [_id cocoa] didSelectTabViewItem: [_id item-cocoa])
(queue-window*-event wxb (lambda (wx) (send wx do-callback)))))
(define-objc-class MyPSMTabBarControl PSMTabBarControl
#:mixins (FocusResponder KeyMouseResponder CursorDisplayer)
[wxb]
(-a _void (tabView: [_id cocoa] didSelectTabViewItem: [_id item-cocoa])
(super-tell #:type _void tabView: cocoa didSelectTabViewItem: item-cocoa)
(queue-window*-event wxb (lambda (wx) (send wx do-callback)))))
(defclass tab-panel% (panel-mixin window%)
(init parent
x y w h
style
labels)
(inherit get-cocoa register-as-child
is-window-enabled?
block-mouse-events)
(define tabv-cocoa (as-objc-allocation
(tell (tell MyTabView alloc) init)))
(define cocoa (if (not (memq 'border style))
(as-objc-allocation
(tell (tell NSView alloc) init))
tabv-cocoa))
(define control-cocoa
(and (not (memq 'border style))
(let ([i (as-objc-allocation
(tell (tell MyPSMTabBarControl alloc)
initWithFrame: #:type _NSRect (make-NSRect (make-NSPoint 0 0)
(make-NSSize 200 22))))])
(tellv cocoa addSubview: i)
(tellv cocoa addSubview: tabv-cocoa)
(tellv tabv-cocoa setDelegate: i)
(tellv tabv-cocoa setTabViewType: #:type _int NSNoTabsNoBorder)
(tellv i setTabView: tabv-cocoa)
(tellv i setStyleNamed: #:type _NSString "Aqua")
;;(tellv i setSizeCellsToFit: #:type _BOOL #t)
(tellv i setDisableTabClose: #:type _BOOL #t)
i)))
(define item-cocoas
(for/list ([lbl (in-list labels)])
(let ([item (as-objc-allocation
(tell (tell NSTabViewItem alloc) initWithIdentifier: #f))])
(tellv item setLabel: #:type _NSString (label->plain-label lbl))
(tellv tabv-cocoa addTabViewItem: item)
item)))
(if control-cocoa
(tellv cocoa setFrame: #:type _NSRect (make-NSRect (make-init-point x y)
(make-NSSize 50 22)))
(let ([sz (tell #:type _NSSize tabv-cocoa minimumSize)])
(tellv tabv-cocoa setFrame: #:type _NSRect (make-NSRect (make-init-point x y) sz))
(tellv tabv-cocoa setDelegate: tabv-cocoa)))
(define content-cocoa
(as-objc-allocation
(tell (tell NSView alloc)
initWithFrame: #:type _NSRect (tell #:type _NSRect tabv-cocoa contentRect))))
(tellv tabv-cocoa addSubview: content-cocoa)
(define/override (get-cocoa-content) content-cocoa)
(define/override (get-cocoa-cursor-content) tabv-cocoa)
(define/override (set-size x y w h)
(super set-size x y w h)
(when control-cocoa
(let ([r (tell #:type _NSRect cocoa frame)])
(tellv control-cocoa setFrame: #:type _NSRect (make-NSRect (make-NSPoint
0
(- (NSSize-height (NSRect-size r)) 22))
(make-NSSize
(NSSize-width (NSRect-size r))
22)))
(tellv tabv-cocoa setFrame: #:type _NSRect (make-NSRect (make-NSPoint 0 0)
(make-NSSize
(NSSize-width (NSRect-size r))
(- (NSSize-height (NSRect-size r)) 22))))))
(tellv content-cocoa setFrame: #:type _NSRect (tell #:type _NSRect tabv-cocoa contentRect)))
(define/public (set-label i str)
(tellv (list-ref item-cocoas i) setLabel: #:type _NSString (label->plain-label str)))
(define/public (set-selection i)
(tellv tabv-cocoa selectTabViewItem: (list-ref item-cocoas i)))
(define/public (get-selection)
(item->index (tell tabv-cocoa selectedTabViewItem)))
(define (item->index tv)
(for/or ([c (in-list item-cocoas)]
[i (in-naturals)])
(and (ptr-equal? c tv) i)))
(public [append* append])
(define (append* lbl)
(let ([item (as-objc-allocation
(tell (tell NSTabViewItem alloc) initWithIdentifier: #f))])
(tellv item setLabel: #:type _NSString (label->plain-label lbl))
(tellv tabv-cocoa addTabViewItem: item)
(set! item-cocoas (append item-cocoas (list item)))
;; Sometimes the sub-view for the tab buttons gets put in front
;; of the content view, so fix the order:
(tellv tabv-cocoa sortSubviewsUsingFunction: #:type _fpointer order_content_first
context: #:type _pointer content-cocoa)))
(define/public (delete i)
(let ([item-cocoa (list-ref item-cocoas i)])
(tellv tabv-cocoa removeTabViewItem: item-cocoa)
(set! item-cocoas (remq item-cocoa item-cocoas))))
(define/public (set choices)
(for ([item-cocoa (in-list item-cocoas)])
(tellv tabv-cocoa removeTabViewItem: item-cocoa))
(set! item-cocoas null)
(for ([lbl (in-list choices)])
(append* lbl)))
(define callback void)
(define/public (set-callback cb) (set! callback cb))
(define/public (do-callback)
(callback this (new control-event%
[event-type 'tab-panel]
[time-stamp (current-milliseconds)])))
(super-new [parent parent]
[cocoa cocoa]
[no-show? (memq 'deleted style)])
(when control-cocoa
(set-ivar! control-cocoa wxb (->wxb this)))
(define/override (enable-window on?)
(super enable-window on?)
(let ([on? (and on? (is-window-enabled?))])
(block-mouse-events (not on?))
(tellv tabv-cocoa setControlTint: #:type _int
(if on? NSDefaultControlTint NSClearControlTint))
(when control-cocoa
(tellv control-cocoa setEnabled: #:type _BOOL on?))))
(define/override (maybe-register-as-child parent on?)
(register-as-child parent on?)))

63
collects/mred/private/wx/cocoa/types.rkt Normal file
View File

@ -0,0 +1,63 @@
#lang racket/base
(require ffi/unsafe/objc
ffi/unsafe
"../../lock.rkt"
"utils.rkt")
(provide
(protect-out _NSInteger _NSUInteger _OSStatus
_CGFloat
_NSPoint _NSPoint-pointer (struct-out NSPoint)
_NSSize _NSSize-pointer (struct-out NSSize)
_NSRect _NSRect-pointer (struct-out NSRect)
_NSRange _NSRange-pointer (struct-out NSRange)
NSObject
NSString _NSString
NSNotFound))
(define _NSInteger _long)
(define _NSUInteger _ulong)
(define _OSStatus _sint32)
(define 64-bit? (= (ctype-sizeof _long) 8))
(define _CGFloat (make-ctype (if 64-bit? _double _float)
(lambda (v) (if (and (number? v)
(exact? v))
(exact->inexact v)
v))
#f))
(define-cstruct _NSPoint ([x _CGFloat]
[y _CGFloat]))
(define-cstruct _NSSize ([width _CGFloat]
[height _CGFloat]))
(define-cstruct _NSRect ([origin _NSPoint][size _NSSize]))
(define-cstruct _NSRange ([location _NSUInteger]
[length _NSUInteger]))
(import-class NSObject NSString)
(define strings (make-weak-hash))
(define _NSString (make-ctype _id
(lambda (v)
(or (hash-ref strings v #f)
(let ([s (as-objc-allocation
(tell (tell NSString alloc)
initWithUTF8String:
#:type _string
v))])
(hash-set! strings v s)
s)))
(lambda (v)
(atomically
(with-autorelease
(let ([s (tell #:type _bytes v UTF8String)])
(bytes->string/utf-8 s)))))))
(define NSNotFound (if 64-bit?
#x7fffffffffffffff
#x7fffffff))

89
collects/mred/private/wx/cocoa/utils.rkt Normal file
View File

@ -0,0 +1,89 @@
#lang racket/base
(require ffi/unsafe/objc
ffi/unsafe
ffi/unsafe/alloc
ffi/unsafe/define
"../common/utils.rkt"
"../../lock.rkt")
(provide
(protect-out cocoa-lib
cf-lib
define-cocoa
define-cf
define-appserv
define-appkit
as-objc-allocation
as-objc-allocation-with-retain
clean-up-deleted
retain release
with-autorelease
clean-menu-label
->wxb
->wx
old-cocoa?
version-10.6-or-later?)
define-mz)
(define cocoa-lib (ffi-lib (format "/System/Library/Frameworks/Cocoa.framework/Cocoa")))
(define cf-lib (ffi-lib (format "/System/Library/Frameworks/CoreFoundation.framework/CoreFoundation")))
(define appserv-lib (ffi-lib (format "/System/Library/Frameworks/ApplicationServices.framework/ApplicationServices")))
(define appkit-lib (ffi-lib (format "/System/Library/Frameworks/AppKit.framework/AppKit")))
(define-ffi-definer define-cocoa cocoa-lib)
(define-ffi-definer define-cf cf-lib)
(define-ffi-definer define-appserv appserv-lib)
(define-ffi-definer define-appkit appkit-lib)
(define delete-me null)
(define (objc-delete o)
(tellv o release))
(define (clean-up-deleted)
(free-remembered-now objc-delete))
(define objc-allocator (allocator remember-to-free-later))
(define-syntax-rule (as-objc-allocation expr)
((objc-allocator (lambda () expr))))
(define-syntax-rule (as-objc-allocation-with-retain expr)
((objc-allocator (lambda () (let ([v expr])
(tellv v retain)
v)))))
(define release ((deallocator) objc-delete))
(define retain ((retainer release car)
(lambda (obj)
(tellv obj retain))))
(import-class NSAutoreleasePool)
;; Use `with-autorelease' and `call-with-autorelease'
;; in atomic mode
(define-syntax-rule (with-autorelease expr ...)
(call-with-autorelease (lambda () expr ...)))
(define (call-with-autorelease thunk)
(let ([pool (tell (tell NSAutoreleasePool alloc) init)])
(begin0
(thunk)
(tellv pool release))))
(define (clean-menu-label str)
(regexp-replace* #rx"&(.)" str "\\1"))
(define (->wxb wx)
(make-weak-box wx))
(define (->wx wxb)
(and wxb
(weak-box-value wxb)))
(define-appkit NSAppKitVersionNumber _double)
(define old-cocoa?
; earlier than 10.5?
(NSAppKitVersionNumber . < . 949))
(define (version-10.6-or-later?)
(NSAppKitVersionNumber . >= . 1038))

835
collects/mred/private/wx/cocoa/window.rkt Normal file
View File

@ -0,0 +1,835 @@
#lang racket/base
(require ffi/unsafe/objc
ffi/unsafe
racket/class
"queue.rkt"
"utils.rkt"
"const.rkt"
"types.rkt"
"keycode.rkt"
"pool.rkt"
"cursor.rkt"
"../common/local.rkt"
"../../lock.rkt"
"../common/event.rkt"
"../common/queue.rkt"
"../common/delay.rkt"
"../../syntax.rkt"
"../common/freeze.rkt")
(provide
(protect-out window%
FocusResponder
KeyMouseResponder
KeyMouseTextResponder
CursorDisplayer
queue-window-event
queue-window-refresh-event
queue-window*-event
request-flush-delay
cancel-flush-delay
make-init-point
flush-display
special-control-key
special-option-key))
(define-local-member-name flip-client)
;; ----------------------------------------
(define special-control-key? #f)
(define special-control-key
(case-lambda
[() special-control-key?]
[(on?) (set! special-control-key? (and on? #t))]))
(define special-option-key? #f)
(define special-option-key
(case-lambda
[() special-option-key?]
[(on?) (set! special-option-key? (and on? #t))]))
;; ----------------------------------------
(define-objc-mixin (FocusResponder Superclass)
[wxb]
[-a _BOOL (acceptsFirstResponder)
(let ([wx (->wx wxb)])
(or (not wx)
(send wx can-be-responder?)))]
[-a _BOOL (becomeFirstResponder)
(and (super-tell becomeFirstResponder)
(let ([wx (->wx wxb)])
(when wx (send wx is-responder wx #t))
#t))]
[-a _BOOL (resignFirstResponder)
(and (super-tell resignFirstResponder)
(let ([wx (->wx wxb)])
(when wx (send wx is-responder wx #f))
#t))]
[-a _void (changeColor: [_id sender])
(let ([wx (->wx wxb)])
(when wx (send wx on-color-change)))])
(import-class NSArray)
(import-protocol NSTextInput)
(define current-insert-text (make-parameter #f))
(define current-set-mark (make-parameter #f))
(define NSDragOperationCopy 1)
(import-class NSAttributedString)
(define _NSStringOrAttributed
(make-ctype _id
(lambda (v)
(cast v _NSString _id))
(lambda (v)
(if (tell #:type _BOOL v isKindOfClass: (tell NSAttributedString class))
(tell #:type _NSString v string)
(cast v _id _NSString)))))
(define-objc-mixin (KeyMouseResponder Superclass)
[wxb]
[-a _void (mouseDown: [_id event])
(unless (do-mouse-event wxb event 'left-down #t #f #f 'right-down)
(super-tell #:type _void mouseDown: event))]
[-a _void (mouseUp: [_id event])
(unless (do-mouse-event wxb event 'left-up #f #f #f 'right-up)
(super-tell #:type _void mouseUp: event))]
[-a _void (mouseDragged: [_id event])
(unless (do-mouse-event wxb event 'motion #t #f #f)
(super-tell #:type _void mouseDragged: event))]
[-a _void (mouseMoved: [_id event])
;; This event is sent to the first responder, instead of the
;; view under the mouse.
(let* ([win (tell event window)]
[view (and win (tell win contentView))]
[hit (and view (tell view hitTest: #:type _NSPoint
(tell #:type _NSPoint event locationInWindow)))])
(let loop ([hit hit])
(when hit
(if (tell #:type _BOOL hit respondsToSelector: #:type _SEL (selector doMouseMoved:))
(unless (tell #:type _BOOL hit doMouseMoved: event)
(super-tell #:type _void mouseMoved: event))
(loop (tell hit superview))))))]
[-a _BOOL (doMouseMoved: [_id event])
;; called by mouseMoved:
(and
;; Make sure we're in the right eventspace:
(let ([wx (->wx wxb)])
(and wx
(eq? (current-eventspace)
(send wx get-eventspace))))
;; Right event space, so handle the event:
(do-mouse-event wxb event 'motion #f #f #f))]
[-a _void (mouseEntered: [_id event])
(unless (do-mouse-event wxb event 'enter 'check 'check 'check)
(super-tell #:type _void mouseEntered: event))]
[-a _void (mouseExited: [_id event])
(unless (do-mouse-event wxb event 'leave 'check 'check 'check)
(super-tell #:type _void mouseExited: event))]
[-a _void (rightMouseDown: [_id event])
(unless (do-mouse-event wxb event 'right-down #f #f #t)
(super-tell #:type _void rightMouseDown: event))]
[-a _void (rightMouseUp: [_id event])
(unless (do-mouse-event wxb event 'right-up #f #f #f)
(super-tell #:type _void rightMouseUp: event))]
[-a _void (rightMouseDragged: [_id event])
(unless (do-mouse-event wxb event 'motion #f #f #t)
(super-tell #:type _void rightMouseDragged: event))]
[-a _void (otherMouseDown: [_id event])
(unless (do-mouse-event wxb event 'middle-down #f #t #f)
(super-tell #:type _void otherMouseDown: event))]
[-a _void (otherMouseUp: [_id event])
(unless (do-mouse-event wxb event 'middle-up #f #f #f)
(super-tell #:type _void otherMouseUp: event))]
[-a _void (otherMouseDragged: [_id event])
(unless (do-mouse-event wxb event 'motion #f #t #f)
(super-tell #:type _void otherMouseDragged: event))]
[-a _void (scrollWheel: [_id event])
(unless (and (not (zero? (tell #:type _CGFloat event deltaY)))
(do-key-event wxb event self #f #t))
(super-tell #:type _void scrollWheel: event))]
[-a _void (keyDown: [_id event])
(unless (do-key-event wxb event self #t #f)
(super-tell #:type _void keyDown: event))]
[-a _void (keyUp: [_id event])
(unless (do-key-event wxb event self #f #f)
(super-tell #:type _void keyUp: event))]
[-a _void (insertText: [_NSStringOrAttributed str])
(let ([cit (current-insert-text)])
(if cit
(set-box! cit str)
(let ([wx (->wx wxb)])
(post-dummy-event) ;; to wake up in case of character palette insert
(when wx
(queue-window-event wx (lambda ()
(send wx key-event-as-string str)))))))]
;; for NSTextInput:
[-a _BOOL (hasMarkedText) (get-saved-marked wxb)]
[-a _id (validAttributesForMarkedText)
(tell NSArray array)]
[-a _void (unmarkText)
(set-saved-marked! wxb #f)]
[-a _NSRange (markedRange)
(let ([saved-marked (get-saved-marked wxb)])
(make-NSRange 0 (if saved-marked 0 (length saved-marked))))]
[-a _NSRange (selectedRange) (make-NSRange 0 0)]
[-a _void (setMarkedText: [_NSStringOrAttributed aString] selectedRange: [_NSRange selRange])
;; We interpreter a call to `setMarkedText:' as meaning that the
;; key is a dead key for composing some other character.
(let ([m (current-set-mark)]) (when m (set-box! m #t)))
;; At the same time, we need to remember the text:
(set-saved-marked! wxb (range-substring aString selRange))
(void)]
[-a _id (validAttributesForMarkedText) #f]
[-a _id (attributedSubstringFromRange: [_NSRange theRange])
(let ([saved-marked (get-saved-marked wxb)])
(and saved-marked
(let ([s (tell (tell NSAttributedString alloc)
initWithString: #:type _NSString
(range-substring saved-marked theRange))])
(tellv s autorelease)
s)))]
[-a _NSUInteger (characterIndexForPoint: [_NSPoint thePoint]) 0]
[-a _NSInteger (conversationIdentifier) 0]
[-a _void (doCommandBySelector: [_SEL aSelector]) (void)]
[-a _NSRect (firstRectForCharacterRange: [_NSRange r])
;; This location is used to place a window for multi-character
;; input, such as when typing Chinese with Pinyin
(let ([f (tell #:type _NSRect self frame)]
[pt (tell #:type _NSPoint (tell self window)
convertBaseToScreen:
#:type _NSPoint
(tell #:type _NSPoint self
convertPoint: #:type _NSPoint
(make-NSPoint 0 0)
toView: #f))])
(make-NSRect pt (NSRect-size f)))]
;; Dragging:
[-a _int (draggingEntered: [_id info])
NSDragOperationCopy]
[-a _BOOL (prepareForDragOperation: [_id info])
#t]
[-a _BOOL (performDragOperation: [_id info])
(let ([wx (->wx wxb)])
(when wx
(with-autorelease
(let ([pb (tell info draggingPasteboard)])
(let ([data (tell pb propertyListForType: NSFilenamesPboardType)])
(when data
(for ([i (in-range (tell #:type _NSUInteger data count))])
(let ([s (tell #:type _NSString data objectAtIndex: #:type _NSUInteger i)])
(queue-window-event wx
(lambda ()
(send wx do-on-drop-file s)))))))))))
#t])
(define (set-saved-marked! wxb str)
(let ([wx (->wx wxb)])
(when wx
(send wx set-saved-marked str))))
(define (get-saved-marked wxb)
(let ([wx (->wx wxb)])
(and wx
(send wx get-saved-marked))))
(define (range-substring s range)
(let ([start (min (max 0 (NSRange-location range)) (string-length s))])
(substring s start (max (min start (NSRange-length range)) (string-length s)))))
(define-objc-mixin (KeyMouseTextResponder Superclass)
#:mixins (KeyMouseResponder)
#:protocols (NSTextInput)
[wxb])
(define-objc-mixin (CursorDisplayer Superclass)
[wxb]
[-a _void (resetCursorRects)
(let ([wx (->wx wxb)])
(when wx
(send wx reset-cursor-rects)))])
(define (do-key-event wxb event self down? wheel?)
(let ([wx (->wx wxb)])
(and
wx
(let ([inserted-text (box #f)]
[set-mark (box #f)])
(unless wheel?
;; Calling `interpretKeyEvents:' allows key combinations to be
;; handled, such as option-e followed by e to produce é. The
;; call to `interpretKeyEvents:' typically calls `insertText:',
;; so we set `current-insert-text' to tell `insertText:' to just
;; give us back the text in the parameter. For now, we ignore the
;; text and handle the event as usual, though probably we should
;; be doing something with it.
(parameterize ([current-insert-text inserted-text]
[current-set-mark set-mark])
(let ([array (tell (tell NSArray alloc)
initWithObjects: #:type (_ptr i _id) event
count: #:type _NSUInteger 1)])
(tellv self interpretKeyEvents: array)
(tellv array release))))
(let* ([modifiers (tell #:type _NSUInteger event modifierFlags)]
[bit? (lambda (m b) (positive? (bitwise-and m b)))]
[pos (tell #:type _NSPoint event locationInWindow)]
[str (cond
[wheel? #f]
[(unbox set-mark) ""] ; => dead key for composing characters
[(unbox inserted-text)]
[else
(tell #:type _NSString event characters)])]
[control? (bit? modifiers NSControlKeyMask)]
[option? (bit? modifiers NSAlternateKeyMask)]
[delta-y (and wheel?
(tell #:type _CGFloat event deltaY))]
[codes (cond
[wheel? (if (positive? delta-y)
'(wheel-up)
'(wheel-down))]
[(map-key-code (tell #:type _ushort event keyCode))
=> list]
[(string=? "" str) '(#\nul)]
[(and (= 1 (string-length str))
(let ([c (string-ref str 0)])
(or (and control?
(char<=? #\u00 c #\u1F)
(let ([alt-str (tell #:type _NSString event charactersIgnoringModifiers)])
(and (string? alt-str)
(= 1 (string-length alt-str))
(string-ref alt-str 0)))))))
=> list]
[else str])])
(for/fold ([result #f]) ([one-code codes])
(or
;; Handle one key event
(let-values ([(x y) (send wx window-point-to-view pos)])
(let ([k (new key-event%
[key-code one-code]
[shift-down (bit? modifiers NSShiftKeyMask)]
[control-down control?]
[meta-down (bit? modifiers NSCommandKeyMask)]
[alt-down option?]
[x (->long x)]
[y (->long y)]
[time-stamp (->long (* (tell #:type _double event timestamp) 1000.0))]
[caps-down (bit? modifiers NSAlphaShiftKeyMask)])])
(unless wheel?
(let ([alt-str (tell #:type _NSString event charactersIgnoringModifiers)])
(when (and (string? alt-str)
(= 1 (string-length alt-str)))
(let ([alt-code (string-ref alt-str 0)])
(unless (equal? alt-code (send k get-key-code))
(send k set-other-altgr-key-code alt-code)))))
(when (and (or (and option?
special-option-key?)
(and control?
(equal? (send k get-key-code) #\u00)))
(send k get-other-altgr-key-code))
;; swap altenate with main
(let ([other (send k get-other-altgr-key-code)])
(send k set-other-altgr-key-code (send k get-key-code))
(send k set-key-code other)))
(unless down?
;; swap altenate with main
(send k set-key-release-code (send k get-key-code))
(send k set-key-code 'release)))
(if (send wx definitely-wants-event? k)
(begin
(queue-window-event wx (lambda ()
(send wx dispatch-on-char/sync k)))
#t)
(constrained-reply (send wx get-eventspace)
(lambda () (send wx dispatch-on-char k #t))
#t))))
result)))))))
(define (do-mouse-event wxb event kind l? m? r? [ctl-kind kind])
(let ([wx (->wx wxb)])
(and
wx
(let* ([modifiers (tell #:type _NSUInteger event modifierFlags)]
[bit? (lambda (m b) (positive? (bitwise-and m b)))]
[pos (tell #:type _NSPoint event locationInWindow)])
(let-values ([(x y) (send wx window-point-to-view pos)]
[(control-down) (bit? modifiers NSControlKeyMask)]
[(l?) (if (eq? l? 'check)
(send wx get-last-left-button)
l?)]
[(m?) (if (eq? m? 'check)
(send wx get-last-middle-button)
m?)]
[(r?) (if (eq? r? 'check)
(send wx get-last-right-button)
r?)])
(let ([l? (and l? (not control-down))]
[r? (or r? (and l? control-down))])
(send wx set-last-buttons l? m? r?)
(let ([m (new mouse-event%
[event-type (if control-down ctl-kind kind)]
[left-down l?]
[middle-down m?]
[right-down r?]
[x (->long x)]
[y (->long y)]
[shift-down (bit? modifiers NSShiftKeyMask)]
[meta-down (bit? modifiers NSCommandKeyMask)]
[alt-down (bit? modifiers NSAlternateKeyMask)]
[time-stamp (->long (* (tell #:type _double event timestamp) 1000.0))]
[caps-down (bit? modifiers NSAlphaShiftKeyMask)])])
(cond
[(send m dragging?) (void)]
[(send m button-down?)
(send wx set-sticky-cursor)
(send wx start-no-cursor-rects)]
[(or l? m? r?) (void)]
[else (send wx end-no-cursor-rects)])
(if (send wx definitely-wants-event? m)
(begin
(queue-window-event wx (lambda ()
(send wx dispatch-on-event/sync m)))
#t)
(constrained-reply (send wx get-eventspace)
(lambda () (send wx dispatch-on-event m #t))
#t)))))))))
(define-cocoa NSFilenamesPboardType _id)
(define window%
(class object%
(init-field parent
cocoa
[no-show? #f])
(super-new)
(queue-autorelease-flush)
(define eventspace (if parent
(send parent get-eventspace)
(current-eventspace)))
(when (eventspace-shutdown? eventspace)
(error '|GUI object initialization| "the eventspace has been shutdown"))
(set-ivar! cocoa wxb (->wxb this))
(unless no-show?
(show #t))
(define/public (focus-is-on on?)
(void))
(define is-responder? #f)
(define/public (is-responder wx on?)
(unless (eq? on? is-responder?)
(set! is-responder? (and on? #t))
(send parent is-responder wx on?)))
(define/public (hide-children)
(is-responder this #f)
(focus-is-on #f))
(define/public (show-children)
(void))
(define/public (fixup-locations-children)
(void))
(define/public (fix-dc)
(void))
(define/public (paint-children)
(void))
(define/public (get-cocoa) cocoa)
(define/public (get-cocoa-content) cocoa)
(define/public (get-cocoa-cursor-content) (get-cocoa-content))
(define/public (get-cocoa-window) (send parent get-cocoa-window))
(define/public (get-wx-window) (send parent get-wx-window))
(define/public (get-dialog-level)
;; called in event-pump thread
(send parent get-dialog-level))
(define/public (make-graphics-context)
(and parent
(send parent make-graphics-context)))
(define/public (get-parent)
parent)
(define/public (get-eventspace) eventspace)
(define is-on? #f)
(define/public (show on?)
(atomically
(unless (eq? (and on? #t) is-on?)
(if on?
(tellv (send parent get-cocoa-content) addSubview: cocoa)
(with-autorelease
(tellv cocoa removeFromSuperview)))
(set! is-on? (and on? #t))
(maybe-register-as-child parent on?)
(if on?
(show-children)
(begin
(hide-children)
(is-responder this #f))))))
(define/public (maybe-register-as-child parent on?)
;; override this to call register-as-child if the window
;; can have the focus or otherwise needs show-state notifications.
(void))
(define/public (register-as-child parent on?)
(send parent register-child this on?))
(define/public (register-child child on?)
(void))
(define/public (on-new-child child on?)
(if on?
(queue-window-event
child
(lambda ()
(atomically
(with-autorelease
(send child child-accept-drag (or accept-drag? accept-parent-drag?))))))
(send child child-accept-drag #f)))
(define/public (is-shown?)
(and (tell cocoa superview) #t))
(define/public (is-shown-to-root?)
(and (is-shown?)
(send parent is-shown-to-root?)))
(define/public (is-shown-to-before-root?)
(and (is-shown?)
(send parent is-shown-to-before-root?)))
(define enabled? #t)
(define/public (is-enabled-to-root?)
(and (is-window-enabled?) (is-parent-enabled-to-root?)))
(define/public (is-parent-enabled-to-root?)
(send parent is-enabled-to-root?))
(define/public (is-window-enabled?)
enabled?)
(define/public (enable on?)
(atomically
(set! enabled? on?)
(enable-window on?)))
(define/public (enable-window on?)
;; in atomic mode
(void))
(define block-all-mouse-events? #f)
(define/public (block-mouse-events block?)
(set! block-all-mouse-events? block?))
(define/private (get-frame)
(let ([v (tell #:type _NSRect cocoa frame)])
v))
(define/public (flip y h)
(if parent
(let ([b (tell #:type _NSRect (send parent get-cocoa-content) bounds)])
(- (NSSize-height (NSRect-size b)) (+ y h)))
y))
(define/public (flip-client y)
(if (tell #:type _BOOL (get-cocoa-content) isFlipped)
y
(let ([r (tell #:type _NSRect (get-cocoa-content) bounds)])
(- (NSSize-height (NSRect-size r))
(- y (client-y-offset))))))
(define/public (client-y-offset) 0)
(define/public (is-view?) #t)
(define/public (window-point-to-view pos)
(let ([pos (if (is-view?)
(tell #:type _NSPoint (get-cocoa-content)
convertPoint: #:type _NSPoint pos
fromView: #f)
pos)])
(values (NSPoint-x pos)
(flip-client (NSPoint-y pos)))))
(define/public (get-x)
(->long (NSPoint-x (NSRect-origin (get-frame)))))
(define/public (get-y)
(let ([r (get-frame)])
(->long (flip (NSPoint-y (NSRect-origin r))
(NSSize-height (NSRect-size r))))))
(define/public (get-width)
(->long (NSSize-width (NSRect-size (get-frame)))))
(define/public (get-height)
(->long (NSSize-height (NSRect-size (get-frame)))))
(define/public (get-position x y)
(let* ([r (get-frame)]
[p (NSRect-origin r)])
(set-box! x (->long (NSPoint-x p)))
(set-box! y (->long (flip (NSPoint-y p) (NSSize-height (NSRect-size r)))))))
(define/public (get-size w h)
(let ([s (NSRect-size (get-frame))])
(set-box! w (->long (NSSize-width s)))
(set-box! h (->long (NSSize-height s)))))
(define/public (get-client-size w h)
;; May be called in Cocoa event-handling mode
(let ([s (NSRect-size (tell #:type _NSRect (get-cocoa-content) bounds))])
(set-box! w (->long (NSSize-width s)))
(set-box! h (->long (NSSize-height s)))))
(define/public (set-size x y w h)
(let ([x (if (= x -11111) (get-x) x)]
[y (if (= y -11111) (get-y) y)])
(tellv cocoa setNeedsDisplay: #:type _BOOL #t)
(tellv cocoa setFrame: #:type _NSRect (make-NSRect (make-NSPoint x (flip y h))
(make-NSSize w h)))))
(define/public (internal-move x y)
(set-size x y (get-width) (get-height)))
(define/public (move x y)
(internal-move x y))
(define accept-drag? #f)
(define accept-parent-drag? #f)
(define/public (on-drop-file f) (void))
(define/public (do-on-drop-file f)
(if accept-drag?
(on-drop-file (string->path f))
(when parent
(send parent do-on-drop-file f))))
(define/public (drag-accept-files on?)
(unless (eq? (and on? #t) accept-drag?)
(atomically
(with-autorelease
(set! accept-drag? (and on? #t))
(accept-drags-everywhere (or accept-drag? accept-parent-drag?))))))
(define/public (accept-drags-everywhere on?)
(if on?
(tellv (get-cocoa-content) registerForDraggedTypes:
(let ([a (tell NSArray arrayWithObjects: #:type (_list i _id) (list NSFilenamesPboardType)
count: #:type _NSUInteger 1)])
a))
(tellv (get-cocoa-content) unregisterDraggedTypes))
(children-accept-drag on?))
(define/public (children-accept-drag on?)
(void))
(define/public (child-accept-drag on?)
(unless (eq? (and on? #t) accept-parent-drag?)
(set! accept-parent-drag? (and on? #t))
(accept-drags-everywhere (or accept-drag? accept-parent-drag?))))
(define/public (set-focus)
(when (and (gets-focus?)
(is-enabled-to-root?))
(let ([w (tell cocoa window)])
(when w
(tellv w makeFirstResponder: (get-cocoa-content))))))
(define/public (on-set-focus) (void))
(define/public (on-kill-focus) (void))
(define/public (definitely-wants-event? e)
;; Called in Cocoa event-handling mode
#f)
(define/private (pre-event-refresh key?)
;; Since we break the connection between the
;; Cocoa queue and event handling, we
;; re-sync the display in case a stream of
;; events (e.g., key repeat) have a corresponding
;; stream of screen updates.
(try-to-sync-refresh)
(flush))
(define/public (flush)
(let ([cocoa-win (get-cocoa-window)])
(when cocoa-win
(tellv cocoa-win displayIfNeeded)
(tellv cocoa-win flushWindowIfNeeded))))
(define/public (dispatch-on-char/sync e)
(pre-event-refresh #t)
(dispatch-on-char e #f))
(define/public (dispatch-on-char e just-pre?)
(cond
[(other-modal? this) #t]
[(call-pre-on-char this e) #t]
[just-pre? #f]
[else (when enabled? (on-char e)) #t]))
(define/public (dispatch-on-event/sync e)
(pre-event-refresh #f)
(dispatch-on-event e #f))
(define/public (dispatch-on-event e just-pre?)
(cond
[(other-modal? this) #t]
[(call-pre-on-event this e) #t]
[just-pre? block-all-mouse-events?]
[else (when enabled? (on-event e)) #t]))
(define/public (call-pre-on-event w e)
(or (send parent call-pre-on-event w e)
(pre-on-event w e)))
(define/public (call-pre-on-char w e)
(or (send parent call-pre-on-char w e)
(pre-on-char w e)))
(define/public (pre-on-event w e) #f)
(define/public (pre-on-char w e) #f)
(define/public (key-event-as-string s)
(dispatch-on-char (new key-event%
[key-code (string-ref s 0)]
[shift-down #f]
[control-down #f]
[meta-down #f]
[alt-down #f]
[x 0]
[y 0]
[time-stamp (current-milliseconds)] ; FIXME
[caps-down #f])
#f))
(define/public (on-char s) (void))
(define/public (on-event m) (void))
(define/public (on-size x y) (void))
(define last-l? #f)
(define last-m? #f)
(define last-r? #f)
(define/public (set-last-buttons l? m? r?)
(set! last-l? l?)
(set! last-m? m?)
(set! last-r? r?))
(define/public (get-last-left-button) last-l?)
(define/public (get-last-middle-button) last-m?)
(define/public (get-last-right-button) last-r?)
(define/public (set-sticky-cursor)
(set! sticky-cursor? #t))
(define/public (start-no-cursor-rects)
(send (get-parent) start-no-cursor-rects))
(define/public (end-no-cursor-rects)
(set! sticky-cursor? #f)
(send (get-parent) end-no-cursor-rects))
(define/public (get-handle) (get-cocoa))
(define/public (popup-menu m x y)
(send m do-popup (get-cocoa-content) (get-cocoa-window) x (flip-client y)
(lambda (thunk)
(queue-window-event this thunk))))
(define/public (center a b) (void))
(define/public (refresh) (void))
(define/public (screen-to-client xb yb)
(let ([p (tell #:type _NSPoint (get-cocoa-content)
convertPoint: #:type _NSPoint
(tell #:type _NSPoint (get-cocoa-window)
convertScreenToBase:
#:type _NSPoint (make-NSPoint (unbox xb)
(send (get-wx-window) flip-screen (unbox yb))))
fromView: #f)])
(set-box! xb (inexact->exact (floor (NSPoint-x p))))
(set-box! yb (inexact->exact (floor (flip-client (NSPoint-y p)))))))
(define/public (client-to-screen xb yb [flip-y? #t])
(let* ([p (tell #:type _NSPoint (get-cocoa-window)
convertBaseToScreen:
#:type _NSPoint
(tell #:type _NSPoint (get-cocoa-content)
convertPoint: #:type _NSPoint
(make-NSPoint (unbox xb) (flip-client (unbox yb)))
toView: #f))])
(let ([new-y (if flip-y?
(send (get-wx-window) flip-screen (NSPoint-y p))
(NSPoint-y p))])
(set-box! xb (inexact->exact (floor (NSPoint-x p))))
(set-box! yb (inexact->exact (floor new-y))))))
(define cursor-handle #f)
(define sticky-cursor? #f)
(define/public (set-cursor c)
(let ([h (if c
(send (send c get-driver) get-handle)
#f)])
(unless (eq? h cursor-handle)
(atomically
(set! cursor-handle h)
(when sticky-cursor? (tellv h set))
(tellv (get-cocoa-window) invalidateCursorRectsForView: (get-cocoa-cursor-content))))))
(define/public (reset-cursor-rects)
;; called in event-pump thread
(when cursor-handle
(let ([content (get-cocoa-cursor-content)])
(let* ([r (tell #:type _NSRect content frame)]
[r (make-NSRect (make-NSPoint 0 0)
(make-NSSize
(- (NSSize-width (NSRect-size r))
(get-cursor-width-delta))
(NSSize-height (NSRect-size r))))])
(tellv content addCursorRect: #:type _NSRect r cursor: cursor-handle)))))
(define/public (get-cursor-width-delta) 0)
(define/public (gets-focus?) #f)
(define/public (can-be-responder?) (is-enabled-to-root?))
(define/public (on-color-change)
(send parent on-color-change))
;; For multi-key character composition:
(define saved-marked #f)
(define/public (set-saved-marked v) (set! saved-marked v))
(define/public (get-saved-marked) saved-marked)))
;; ----------------------------------------
(define (queue-window-event wx thunk)
(queue-event (send wx get-eventspace) thunk))
(define (queue-window-refresh-event wx thunk)
(queue-refresh-event (send wx get-eventspace) thunk))
(define (queue-window*-event wxb proc)
(let ([wx (->wx wxb)])
(when wx
(queue-event (send wx get-eventspace) (lambda () (proc wx))))))
(define (request-flush-delay cocoa-win)
(do-request-flush-delay
cocoa-win
(lambda (cocoa-win)
(tellv cocoa-win disableFlushWindow)
#t)
(lambda (cocoa-win)
(tellv cocoa-win enableFlushWindow))))
(define (cancel-flush-delay req)
(do-cancel-flush-delay
req
(lambda (cocoa-win)
(tellv cocoa-win enableFlushWindow))))
(define (make-init-point x y)
(make-NSPoint (if (= x -11111)
0
x)
(if (= y -11111)
0
y)))
(define (flush-display)
(try-to-sync-refresh)
(for ([win (in-list (get-top-level-windows))])
(send win flush)))

157
collects/mred/private/wx/common/backing-dc.rkt Normal file
View File

@ -0,0 +1,157 @@
#lang racket/base
(require racket/class
racket/draw/private/dc
racket/draw/private/bitmap-dc
racket/draw/private/bitmap
racket/draw/private/local
"../../lock.rkt"
"queue.rkt")
(provide
(protect-out backing-dc%
;; scoped method names:
get-backing-size
queue-backing-flush
on-backing-flush
start-backing-retained
end-backing-retained
reset-backing-retained
make-backing-bitmap
request-delay
cancel-delay
end-delay))
(define-local-member-name
get-backing-size
queue-backing-flush
on-backing-flush
start-backing-retained
end-backing-retained
reset-backing-retained
make-backing-bitmap
request-delay
cancel-delay
end-delay)
(define backing-dc%
(class (dc-mixin bitmap-dc-backend%)
(inherit internal-get-bitmap
internal-set-bitmap
reset-cr)
(super-new)
(define/override (ok?) #t)
;; Override this method to get the right size
(define/public (get-backing-size xb yb)
(set-box! xb 1)
(set-box! yb 1))
;; override this method to set up a callback to
;; `on-backing-flush' when the backing store can be rendered
;; to the screen; called atomically (expecting no exceptions)
(define/public (queue-backing-flush)
(void))
(define retained-cr #f)
(define retained-counter 0)
(define needs-flush? #f)
(define nada? #t)
;; called with a procedure that is applied to a bitmap;
;; returns #f if there's nothing to flush
(define/public (on-backing-flush proc)
(cond
[(not retained-cr) #f]
[(positive? retained-counter)
(unless nada?
(proc (internal-get-bitmap)))
#t]
[else
(reset-backing-retained proc)
#t]))
(define/public (can-backing-flush?)
(and retained-cr #t))
(define/public (reset-backing-retained [proc void])
(let ([cr retained-cr])
(when cr
(let ([bm (internal-get-bitmap)])
(set! retained-cr #f)
(internal-set-bitmap #f #t)
(super release-cr retained-cr)
(proc bm)
(release-backing-bitmap bm)))))
(define/public (start-backing-retained)
(as-entry
(lambda ()
(set! retained-counter (add1 retained-counter)))))
(define/public (end-backing-retained)
(as-entry
(lambda ()
(if (zero? retained-counter)
(log-error "unbalanced end-on-paint")
(set! retained-counter (sub1 retained-counter))))))
(define/public (make-backing-bitmap w h)
(make-object bitmap% w h #f #t))
(define/public (ensure-ready) (get-cr))
(define/override (get-cr)
(or retained-cr
(let ([w (box 0)]
[h (box 0)])
(get-backing-size w h)
(let ([bm (get-backing-bitmap (lambda (w h) (make-backing-bitmap w h)) (unbox w) (unbox h))])
(internal-set-bitmap bm #t))
(let ([cr (super get-cr)])
(set! retained-cr cr)
(reset-cr cr)
cr))))
(define/override (release-cr cr)
(set! nada? #f)
(when (zero? flush-suspends)
(queue-backing-flush)))
(define/override (erase)
(super erase)
(set! nada? #t))
(define flush-suspends 0)
(define req #f)
(define/public (request-delay) (void))
(define/public (cancel-delay req) (void))
(define/override (suspend-flush)
(atomically
(when (zero? flush-suspends)
(when req (cancel-delay req))
(set! req (request-delay)))
(set! flush-suspends (add1 flush-suspends))))
(define/override (resume-flush)
(atomically
(unless (zero? flush-suspends)
(set! flush-suspends (sub1 flush-suspends))
(when (zero? flush-suspends)
(queue-backing-flush)))))
(define/public (end-delay)
;; call in atomic mode
(when (and (zero? flush-suspends) req)
(cancel-delay req)
(set! req #f)))))
(define (get-backing-bitmap make-bitmap w h)
(make-bitmap w h))
(define (release-backing-bitmap bm)
(send bm release-bitmap-storage))

200
collects/mred/private/wx/common/canvas-mixin.rkt Normal file
View File

@ -0,0 +1,200 @@
#lang racket/base
(require racket/class
racket/draw
"../common/queue.rkt"
"backing-dc.rkt")
(provide
(protect-out canvas-autoscroll-mixin
canvas-mixin
fix-bitmap-size))
;; Implements canvas autoscroll, applied *before* platform-specific canvas
;; methods:
(define (canvas-autoscroll-mixin %)
(class %
(super-new)
(inherit get-client-size
refresh)
(define auto-scroll? #f)
(define virtual-height #f)
(define virtual-width #f)
(define/public (is-auto-scroll?) auto-scroll?)
(define/public (get-virtual-height) virtual-height)
(define/public (get-virtual-width) virtual-width)
(define/public (set-scrollbars h-step v-step
h-len v-len
h-page v-page
h-pos v-pos
auto?)
(cond
[auto?
(set! auto-scroll? #t)
(set! virtual-width (and (positive? h-len) h-len))
(set! virtual-height (and (positive? v-len) v-len))
(reset-auto-scroll h-pos v-pos)
(refresh-for-autoscroll)]
[else
(let ([a? auto-scroll?])
(set! auto-scroll? #f)
(set! virtual-width #f)
(set! virtual-height #f)
(when a? (reset-dc-for-autoscroll))) ; disable scroll offsets
(do-set-scrollbars h-step v-step
h-len v-len
h-page v-page
h-pos v-pos)]))
;; To be overridden:
(define/public (do-set-scrollbars h-step v-step
h-len v-len
h-page v-page
h-pos v-pos)
(void))
(define/public (reset-auto-scroll h-pos v-pos)
(let ([xb (box 0)]
[yb (box 0)])
(get-client-size xb yb)
(let ([cw (unbox xb)]
[ch (unbox yb)])
(let ([h-len (if virtual-width
(max 0 (- virtual-width cw))
0)]
[v-len (if virtual-height
(max 0 (- virtual-height ch))
0)]
[h-page (if virtual-width
cw
0)]
[v-page (if virtual-height
ch
0)])
(do-set-scrollbars 1 1
h-len v-len
h-page v-page
h-pos v-pos)))))
;; To be overridden:
(define/public (reset-dc-for-autoscroll)
(void))
(define/public (refresh-for-autoscroll)
(reset-dc-for-autoscroll)
(refresh))
(define/public (view-start xb yb)
(if auto-scroll?
(begin
(set-box! xb (if virtual-width
(get-virtual-h-pos)
0))
(set-box! yb (if virtual-height
(get-virtual-v-pos)
0)))
(begin
(set-box! xb 0)
(set-box! yb 0))))
;; To be overridden:
(define/public (get-virtual-h-pos) 0)
(define/public (get-virtual-v-pos) 0)
(define/public (get-virtual-size xb yb)
(get-client-size xb yb)
(when virtual-width (set-box! xb virtual-width))
(when virtual-height (set-box! yb virtual-height)))))
;; Implements canvas refresh, applied *after* platform-specific canvas
;; methods:
(define (canvas-mixin %)
(class %
(super-new)
(inherit request-canvas-flush-delay
cancel-canvas-flush-delay
queue-canvas-refresh-event
is-shown-to-root?
on-paint
queue-backing-flush
get-dc
get-canvas-background-for-backing)
;; Avoid multiple queued paints, and also allow cancel
;; of queued paint:
(define paint-queued #f) ; #f or (box #t)
(define/override (queue-paint)
;; can be called from any thread, including the event-pump thread
(unless paint-queued
(let ([b (box #t)])
(set! paint-queued b)
(let ([req (request-canvas-flush-delay)])
(queue-canvas-refresh-event
(lambda () (do-on-paint req b)))))))
(define/private (do-on-paint req b)
;; only called in the handler thread
(when (or (not b) (unbox b))
(let ([pq paint-queued])
(when pq (set-box! pq #f)))
(set! paint-queued #f)
(when (or (not b) (is-shown-to-root?))
(let ([dc (get-dc)])
(send dc suspend-flush)
(send dc ensure-ready)
(send dc erase) ; start with a clean slate
(let ([bg (get-canvas-background-for-backing)])
(when bg
(let ([old-bg (send dc get-background)])
(send dc set-background bg)
(send dc clear)
(send dc set-background old-bg))))
(on-paint)
(send dc resume-flush)
(queue-backing-flush))))
(when req
(cancel-canvas-flush-delay req)))
(define/override (paint-children)
(when (or paint-queued
(not (send (get-dc) can-backing-flush?)))
(do-on-paint #f #f)))
(define flush-box #f)
;; Periodic flush is needed for Windows, where
;; updates otherwise happen only via the eventspace's queue
(define/override (schedule-periodic-backing-flush)
(unless flush-box
(set! flush-box (box #t))
(add-event-boundary-sometimes-callback!
flush-box
(lambda (b)
(when (unbox b)
(do-canvas-backing-flush #f))))))
(define/override (do-canvas-backing-flush ctx)
;; cancel scheduled flush, if any:
(when flush-box
(set-box! flush-box #f)
(set! flush-box #f))
(super do-canvas-backing-flush ctx))))
;; useful for fixing the size of a collecting blit:
(define (fix-bitmap-size on w h on-x on-y)
(if (and (zero? on-x)
(zero? on-y)
(= (send on get-width) w)
(= (send on get-height) h))
on
(let ([bm (make-object bitmap% w h)])
(let ([dc (make-object bitmap-dc% on)])
(send dc draw-bitmap-section on 0 0 on-x on-y w h)
(send dc set-bitmap #f)
bm))))

79
collects/mred/private/wx/common/clipboard.rkt Normal file
View File

@ -0,0 +1,79 @@
#lang racket/base
(require racket/class
"../../syntax.rkt"
"../platform.rkt"
"local.rkt"
"queue.rkt")
(provide
(protect-out clipboard<%>
clipboard-client%
get-the-clipboard
get-the-x-selection))
(defclass clipboard-client% object%
(define types null)
(define es (current-eventspace))
(define/public (get-client-eventspace) es)
(define/public (set-client-eventspace e) (set! es e))
(def/public (same-eventspace? [eventspace? e])
(eq? e es))
(def/public (get-types)
types)
(def/public (add-type [string? str])
(set! types (cons (string->immutable-string str) types)))
(def/public (get-data [string? format])
#f)
(def/public (on-replaced)
(void))
(super-new))
(define string-clipboard-client%
(class clipboard-client%
(init-field the-bytes)
(super-new)
(define/override (get-types) (list "TEXT"))
(define/override (get-data s)
(and (equal? s "TEXT") the-bytes))))
(defclass clipboard% object%
(init x-selection?)
(define driver (new clipboard-driver%
[x-selection? x-selection?]))
(def/public (same-clipboard-client? [clipboard-client% c])
(eq? c (send driver get-client)))
(def/public (get-clipboard-bitmap [exact-integer? timestamp])
(send driver get-bitmap-data))
(def/public-unimplemented set-clipboard-bitmap)
(def/public (get-clipboard-data [string? type]
[exact-integer? timestamp])
(send driver get-data type))
(def/public (get-clipboard-string [exact-integer? timestamp])
(send driver get-text-data))
(def/public (set-clipboard-client [clipboard-client% c]
[exact-integer? timestamp])
(send c set-client-eventspace (current-eventspace))
(send driver set-client c (send c get-types)))
(def/public (set-clipboard-string [string? str]
[exact-integer? timestamp])
(set-clipboard-client (make-object string-clipboard-client%
(string->bytes/utf-8 str))
timestamp))
(super-new))
(define clipboard<%> (class->interface clipboard%))
(define the-clipboard (new clipboard% [x-selection? #f]))
(define the-x-selection
(if has-x-selection?
(new clipboard% [x-selection? #t])
the-clipboard))
(define (get-the-clipboard)
the-clipboard)
(define (get-the-x-selection)
the-x-selection)

61
collects/mred/private/wx/common/cursor-draw.rkt Normal file
View File

@ -0,0 +1,61 @@
#lang racket/base
(require racket/class
racket/draw)
(provide make-cursor-image
draw-watch
draw-nw/se
draw-ne/sw
draw-bullseye)
(define (make-cursor-image draw-proc [smoothing 'aligned])
(let* ([bm (make-object bitmap% 16 16 #f #t)]
[dc (make-object bitmap-dc% bm)])
(send dc set-smoothing smoothing)
(draw-proc dc 16 16)
(send dc set-bitmap #f)
bm))
(define (draw-watch dc w h)
(send dc set-brush "black" 'solid)
(send dc draw-rectangle 5 0 6 4)
(send dc draw-rectangle 5 12 6 4)
(send dc set-brush "white" 'solid)
(send dc draw-ellipse 3 3 10 10)
(send dc draw-line 7 5 7 8)
(send dc draw-line 7 8 9 8))
(define (draw-nw/se dc w h)
(bolden
dc
(lambda ()
(send dc set-smoothing 'unsmoothed)
(send dc draw-line 0 16 16 0)
(send dc draw-line 0 0 16 16)
(send dc draw-line 1 4 1 1)
(send dc draw-line 1 1 4 1)
(send dc draw-line 12 15 15 15)
(send dc draw-line 15 15 15 12))))
(define (draw-ne/sw dc w h)
(bolden
dc
(lambda ()
(send dc set-smoothing 'unsmoothed)
(send dc draw-line 0 16 16 0)
(send dc draw-line 0 0 16 16)
(send dc draw-line 12 1 15 1)
(send dc draw-line 15 1 15 4)
(send dc draw-line 1 12 1 15)
(send dc draw-line 1 15 4 15))))
(define (draw-bullseye dc w h)
(send dc draw-ellipse 1 1 (- w 2) (- h 2))
(send dc draw-ellipse 4 4 (- w 8) (- h 8))
(send dc draw-ellipse 7 7 2 2))
(define (bolden dc draw)
(send dc set-pen "white" 4 'solid)
(draw)
(send dc set-pen "black" 2 'solid)
(draw))

48
collects/mred/private/wx/common/cursor.rkt Normal file
View File

@ -0,0 +1,48 @@
#lang racket/base
(require racket/class
racket/draw
"local.rkt"
(only-in "../platform.rkt" cursor-driver%)
"../../syntax.rkt")
(provide cursor%)
(define standards (make-hash))
(define (is-16x16? image)
(and (not (send image is-color?))
(= 16 (send image get-width))
(= 16 (send image get-height))))
(defclass cursor% object%
(init-rest args)
(define driver
(case-args
args
[([(symbol-in arrow bullseye cross hand ibeam watch blank
size-n/s size-e/w size-ne/sw size-nw/se
arrow+watch)
sym])
(or (hash-ref standards sym #f)
(let ([c (new cursor-driver%)])
(send c set-standard sym)
(hash-set! standards sym c)
c))]
[([bitmap% image]
[bitmap% mask]
[(integer-in 0 15) [hot-spot-x 0]]
[(integer-in 0 15) [hot-spot-y 0]])
(unless (is-16x16? image)
(raise-type-error (init-name 'cursor%) '|bitmap (16x16 monochrome)| image))
(unless (is-16x16? mask)
(raise-type-error (init-name 'cursor%) '|bitmap (16x16 monochrome)| mask))
(let ([c (new cursor-driver%)])
(send c set-image image mask hot-spot-x hot-spot-y)
c)]
(init-name 'cursor%)))
(define/public (get-driver) driver)
(def/public (ok?) (send driver ok?))
(super-new))

32
collects/mred/private/wx/common/default-procs.rkt Normal file
View File

@ -0,0 +1,32 @@
#lang racket/base
(require racket/class
racket/draw/private/color)
(provide special-control-key
special-option-key
file-creator-and-type
get-panel-background
fill-private-color)
(define special-control-key? #f)
(define special-control-key
(case-lambda
[() special-control-key?]
[(on?) (set! special-control-key? (and on? #t))]))
(define special-option-key? #f)
(define special-option-key
(case-lambda
[() special-option-key?]
[(on?) (set! special-option-key? (and on? #t))]))
(define file-creator-and-type
(case-lambda
[(path cr ty) (void)]
[(path) (values #"????" #"????")]))
(define (get-panel-background)
(make-object color% "gray"))
(define (fill-private-color dc col)
(send dc set-background col)
(send dc clear))

40
collects/mred/private/wx/common/delay.rkt Normal file
View File

@ -0,0 +1,40 @@
#lang racket/base
(require "../../lock.rkt"
"queue.rkt")
(provide
(protect-out do-request-flush-delay
do-cancel-flush-delay))
;; Auto-cancel schedules a cancel of a request flush
;; on event boundaries. It makes sense if you don't
;; trust a program to un-delay important refreshes,
;; but auto-cancel is currently disabled because
;; bad refresh-delay effects are confined to the enclosing
;; window on all platforms.
(define AUTO-CANCEL-DELAY? #f)
(define (do-request-flush-delay win disable enable)
(atomically
(let ([req (box win)])
(and
(disable win)
(begin
(when AUTO-CANCEL-DELAY?
(add-event-boundary-sometimes-callback!
req
(lambda (v)
;; in atomic mode
(when (unbox req)
(set-box! req #f)
(enable win)))))
req)))))
(define (do-cancel-flush-delay req enable)
(atomically
(let ([win (unbox req)])
(when win
(set-box! req #f)
(enable win)
(when AUTO-CANCEL-DELAY?
(remove-event-boundary-callback! req))))))

48
collects/mred/private/wx/common/dialog.rkt Normal file
View File

@ -0,0 +1,48 @@
#lang racket/base
(require racket/class
"../../lock.rkt"
"queue.rkt")
(provide (protect-out dialog-mixin))
(define dialog-level-counter 0)
(define (dialog-mixin %)
(class %
(super-new)
(define close-sema #f)
(define dialog-level 0)
(define/override (get-dialog-level) dialog-level)
(define/override (frame-relative-dialog-status win)
(let ([dl (send win get-dialog-level)])
(cond
[(= dl dialog-level) 'same]
[(dl . > . dialog-level) #f]
[else 'other])))
(define/override (direct-show on?)
;; atomic mode
(when on?
(set! dialog-level-counter (add1 dialog-level-counter))
(set! dialog-level dialog-level-counter))
(unless on?
(set! dialog-level 0))
(unless on?
(when close-sema
(semaphore-post close-sema)
(set! close-sema #f)))
(super direct-show on?))
(define/override (show on?)
(if on?
(let ([s (atomically
(let ([s (or close-sema (make-semaphore))])
(unless close-sema (set! close-sema s))
(semaphore-peek-evt s)))])
(super show on?)
(yield s)
(void))
(super show on?)))))

111
collects/mred/private/wx/common/event.rkt Normal file
View File

@ -0,0 +1,111 @@
#lang racket/base
(require racket/class
"../../syntax.rkt")
(provide event%
mouse-event%
key-event%
control-event%
scroll-event%
popup-event%)
(defclass event% object%
(init-properties [[exact-integer? time-stamp] 0])
(super-new))
(defclass mouse-event% event%
(init-properties [[(symbol-in enter leave left-down left-up
middle-down middle-up
right-down right-up motion)
event-type]]
[[bool? left-down] #f]
[[bool? middle-down] #f]
[[bool? right-down] #f]
[[exact-integer? x] 0]
[[exact-integer? y] 0]
[[bool? shift-down] #f]
[[bool? control-down] #f]
[[bool? meta-down] #f]
[[bool? alt-down] #f])
(init [time-stamp 0])
(init-properties [[bool? caps-down] #f])
(super-new [time-stamp time-stamp])
(def/public (button-changed? [(symbol-in left middle right any) [button 'any]])
(and (memq event-type
(case button
[(any) '(left-down left-up middle-down middle-up right-down right-up)]
[(left) '(left-down left-up)]
[(middle) '(middle-down middle-up)]
[(right) '(right-down right-up)]))
#t))
(def/public (button-down? [(symbol-in left middle right any) [button 'any]])
(and (memq event-type
(case button
[(any) '(left-down middle-down right-down)]
[(left) '(left-down)]
[(middle) '(middle-down)]
[(right) '(right-down)]))
#t))
(def/public (button-up? [(symbol-in left middle right any) [button 'any]])
(and (memq event-type
(case button
[(any) '(left-up middle-up right-up)]
[(left) '(left-up)]
[(middle) '(middle-up)]
[(right) '(right-up)]))
#t))
(def/public (dragging?)
(and (eq? event-type 'motion)
(or left-down middle-down right-down)))
(def/public (entering?)
(eq? event-type 'enter))
(def/public (leaving?)
(eq? event-type 'leave))
(def/public (moving?)
(eq? event-type 'motion)))
(defclass key-event% event%
(init-properties [[(make-alts symbol? char?) key-code] #\nul]
[[bool? shift-down] #f]
[[bool? control-down] #f]
[[bool? meta-down] #f]
[[bool? alt-down] #f]
[[exact-integer? x] 0]
[[exact-integer? y] 0])
(init [time-stamp 0])
(init-properties [[bool? caps-down] #f])
(properties [[(make-alts symbol? char?) key-release-code] 'down]
[[(make-or-false (make-alts symbol? char?)) other-shift-key-code] #f]
[[(make-or-false (make-alts symbol? char?)) other-altgr-key-code] #f]
[[(make-or-false (make-alts symbol? char?)) other-shift-altgr-key-code] #f]
[[(make-or-false (make-alts symbol? char?)) other-caps-key-code] #f])
(super-new [time-stamp time-stamp]))
(defclass control-event% event%
(init-properties [[(symbol-in button check-box choice
list-box list-box-dclick text-field
text-field-enter slider radio-box
menu-popdown menu-popdown-none tab-panel)
event-type]])
(init [time-stamp 0])
(super-new [time-stamp time-stamp]))
(defclass popup-event% control-event%
(properties [[any? menu-id] 0])
(super-new))
(defclass scroll-event% event%
(init-properties [[(symbol-in top bottom line-up line-down page-up page-down thumb) event-type]
'thumb]
[[(symbol-in horizontal vertical) direction] 'vertical]
[[(integer-in 0 10000) position] 0])
(init [time-stamp 0])
(super-new [time-stamp time-stamp]))

49
collects/mred/private/wx/common/freeze.rkt Normal file
View File

@ -0,0 +1,49 @@
#lang racket/base
(require ffi/unsafe/try-atomic
"queue.rkt")
(provide
call-as-nonatomic-retry-point
(protect-out constrained-reply))
(define (internal-error str)
(log-error
(apply string-append
(format "internal error: ~a" str)
(append
(for/list ([c (continuation-mark-set->context (current-continuation-marks))])
(let ([name (car c)]
[loc (cdr c)])
(cond
[loc
(string-append
"\n"
(cond
[(srcloc-line loc)
(format "~a:~a:~a"
(srcloc-source loc)
(srcloc-line loc)
(srcloc-column loc))]
[else
(format "~a::~a"
(srcloc-source loc)
(srcloc-position loc))])
(if name (format " ~a" name) ""))]
[else (format "\n ~a" name)])))
'("\n")))))
;; FIXME: waiting 200msec is not a good enough rule.
(define (constrained-reply es thunk default
#:fail-result [fail-result default])
(cond
[(not (can-try-atomic?))
;; Ideally, this would count as an error that we can fix. It seems that we
;; don't always have enough control to use the right eventspace with a
;; retry point, though, so just bail out with the default.
#;(internal-error (format "constrained-reply not within an unfreeze point for ~s" thunk))
fail-result]
[(not (eq? (current-thread) (eventspace-handler-thread es)))
(internal-error "wrong eventspace for constrained event handling\n")
fail-result]
[else
(try-atomic thunk default)]))

40
collects/mred/private/wx/common/handlers.rkt Normal file
View File

@ -0,0 +1,40 @@
#lang racket/base
(provide
(protect-out application-file-handler
application-quit-handler
application-about-handler
application-pref-handler
nothing-application-pref-handler))
(define saved-files null)
(define afh (lambda (f)
(set! saved-files (cons f saved-files))))
(define application-file-handler
(case-lambda
[(proc)
(set! afh proc)
(let ([sf saved-files])
(set! saved-files null)
(for-each proc (reverse sf)))]
[() afh]))
(define aqh void)
(define application-quit-handler
(case-lambda
[(proc) (set! aqh proc)]
[() aqh]))
(define aah void)
(define application-about-handler
(case-lambda
[(proc) (set! aah proc)]
[() aah]))
(define (nothing-application-pref-handler) (void))
(define aph nothing-application-pref-handler)
(define application-pref-handler
(case-lambda
[(proc) (set! aph proc)]
[() aph]))

13
collects/mred/private/wx/common/local.rkt Normal file
View File

@ -0,0 +1,13 @@
#lang racket/base
(require racket/class)
(provide (protect-out (all-defined-out)))
(define-local-member-name
;; clipboard-client%:
get-client-eventspace
set-client-eventspace
;; cursor%
get-driver)

14
collects/mred/private/wx/common/once.rkt Normal file
View File

@ -0,0 +1,14 @@
#lang racket/base
(require ffi/unsafe)
(provide (protect-out scheme_register_process_global))
;; This module must be instantiated only once:
(define scheme_register_process_global
(get-ffi-obj 'scheme_register_process_global #f (_fun _string _pointer -> _pointer)))
(let ([v (scheme_register_process_global "GRacket-support-initialized"
(cast 1 _scheme _pointer))])
(when v
(error "cannot instantiate `racket/gui/base' a second time in the same process")))

Some files were not shown because too many files have changed in this diff Show More