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

Some random tidyings.

Browse Source 
original commit: 1be26400cb15d234238af7958b97a79587c85f66
This commit is contained in:
Eli Barzilay 2011-02-16 15:26:11 -05:00
commit 17a8784314
58 changed files with 900 additions and 334 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/embedded-gui/doc.txt
View File

@ -257,7 +257,7 @@ alignment<%>.
_stretchable-editor-snip-mixin_ gives an editor snip the _stretchable-editor-snip-mixin_ gives an editor snip the
_stretchable-snip<%>_ interface allowing it to be stretched _stretchable-snip<%>_ interface allowing it to be stretched
to fit it's alignment-parent<%>'s alloted width. Stretchable to fit its alignment-parent<%>'s alloted width. Stretchable
snips are useful as the snip of a snip-wrapper%. snips are useful as the snip of a snip-wrapper%.
_stretchable-editor-snip%_ is (stretcable-editor-snip-mixin editor-snip%) _stretchable-editor-snip%_ is (stretcable-editor-snip-mixin editor-snip%)
@ -292,7 +292,7 @@ interface and gives it key bindings to tab ahead and back.
The _set-tabbing_ function sets the tabbing order of The _set-tabbing_ function sets the tabbing order of
tabbable-text<%>s by setting each text's set-ahead and tabbable-text<%>s by setting each text's set-ahead and
set-back thunks to point to it's neighbor in the argument set-back thunks to point to its neighbor in the argument
list. list.
> (set-tabbing a-text ...) > (set-tabbing a-text ...)

14
collects/embedded-gui/private/alignment.rkt
View File

@ -1,19 +1,19 @@
#| #|
This code computes the sizes for the rectangles in the space using the on dimention This code computes the sizes for the rectangles in the space using the on dimension
off dimention method of referencing sizes. This means for example instead of saying off dimension method of referencing sizes. This means for example instead of saying
width we say off dimention for vertical alignment. Inorder to consume and return width we say off dimension for vertical alignment. Inorder to consume and return
the values in terms of width and height manipulation had to be done. I chose to create the values in terms of width and height manipulation had to be done. I chose to create
a struct abs-rect (abstract rectangle) and have code map horizontal and vertical rect a struct abs-rect (abstract rectangle) and have code map horizontal and vertical rect
stucts on to them. This code is a bit long but more readable than the other two options stucts on to them. This code is a bit long but more readable than the other two options
I came up with. I came up with.
1) define all functions to be letrec bound functions inside align. align then take 1) define all functions to be letrec bound functions inside align. align then take
accessors for the rect struct. The caller of align swaps the order of ondimention accessors for the rect struct. The caller of align swaps the order of ondimension
and off dimention accessors for vertical or horizontal code. This method does not and off dimension accessors for vertical or horizontal code. This method does not
allow the use of the readable, short, consis pattern matching code. As some of the allow the use of the readable, short, consis pattern matching code. As some of the
matching code is easily removed this may be a good option but a large letrec matching code is easily removed this may be a good option but a large letrec
is harder to write tests for. is harder to write tests for.
2) define a pattern matcher syntax that will match the struct rect but swap the fields 2) define a pattern matcher syntax that will match the struct rect but swap the fields
based on wich on is the on or off dimention. This would have been shorter but much based on which on is the on or off dimension. This would have been shorter but much
more confusing. more confusing.
The current implementation requires align to map over the rects and allocate new stucts The current implementation requires align to map over the rects and allocate new stucts
for each one on both passing into and returning from stretch-to-fit; This is not a bottle for each one on both passing into and returning from stretch-to-fit; This is not a bottle
@ -138,7 +138,7 @@ neck and it is the most readable solution.
(loop rest-rects (+ onpos onsize))))])))) (loop rest-rects (+ onpos onsize))))]))))
#;(natural-number? . -> . (-> (union 1 0))) #;(natural-number? . -> . (-> (union 1 0)))
;; makes a thunk that returns 1 for it's first n applications, zero otherwise ;; makes a thunk that returns 1 for its first n applications, zero otherwise
(define (waner n) (define (waner n)
(lambda () (lambda ()
(if (zero? n) (if (zero? n)

2
collects/embedded-gui/scribblings/embedded-gui.scrbl
View File

@ -81,7 +81,7 @@ t hat are labeled from a particular set of strings.}
Sets the tabbing order of @scheme[tabbable-text<%>]s by setting each Sets the tabbing order of @scheme[tabbable-text<%>]s by setting each
text's @method[tabbable-text<%> set-ahead] and text's @method[tabbable-text<%> set-ahead] and
@method[tabbable-text<%> set-back] thunks to point to it's neighbor in @method[tabbable-text<%> set-back] thunks to point to its neighbor in
the argument list.} the argument list.}

2
collects/framework/main.rkt
View File

@ -802,7 +802,7 @@
@scheme[filename]. @scheme[filename].
@itemize[ @itemize[
@item{If a handler is found, it is applied to @item{If a handler is found, it is applied to
@scheme[filename] and it's result is the final @scheme[filename] and its result is the final
result.} result.}
@item{If not, @scheme[make-default] is used.}]}]} @item{If not, @scheme[make-default] is used.}]}]}
@item{If @scheme[filename] is @scheme[#f], @scheme[make-default] is @item{If @scheme[filename] is @scheme[#f], @scheme[make-default] is

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

@ -297,6 +297,14 @@ added get-regions
(get-token in in-start-pos in-lexer-mode) (get-token in in-start-pos in-lexer-mode)
(enable-suspend #t)))]) (enable-suspend #t)))])
(unless (eq? 'eof type) (unless (eq? 'eof type)
(unless (exact-nonnegative-integer? new-token-start)
(error 'color:text<%> "expected an exact nonnegative integer for the token start, got ~e" new-token-start))
(unless (exact-nonnegative-integer? new-token-end)
(error 'color:text<%> "expected an exact nonnegative integer for the token end, got ~e" new-token-end))
(unless (exact-nonnegative-integer? backup-delta)
(error 'color:text<%> "expected an exact nonnegative integer for the backup delta, got ~e" backup-delta))
(unless (0 . < . (- new-token-end new-token-start))
(error 'color:text<%> "expected the distance between the start and end position for each token to be positive, but start was ~e and end was ~e" new-token-start new-token-end))
(enable-suspend #f) (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))) (+ in-start-pos (sub1 new-token-end)))
@ -312,7 +320,7 @@ added get-regions
(sp (+ in-start-pos (sub1 new-token-start))) (sp (+ in-start-pos (sub1 new-token-start)))
(ep (+ in-start-pos (sub1 new-token-end)))) (ep (+ in-start-pos (sub1 new-token-end))))
(λ () (λ ()
(change-style color sp ep #f))) (change-style color sp ep #f)))
colors))) colors)))
;; Using the non-spec version takes 3 times as long as the spec ;; Using the non-spec version takes 3 times as long as the spec
;; version. In other words, the new greatly outweighs the tree ;; version. In other words, the new greatly outweighs the tree
@ -825,20 +833,23 @@ added get-regions
(define/public (get-token-range position) (define/public (get-token-range position)
(define-values (tokens ls) (get-tokens-at-position 'get-token-range position)) (define-values (tokens ls) (get-tokens-at-position 'get-token-range position))
(values (and tokens (+ (lexer-state-start-pos ls) (values (and tokens ls
(send tokens get-root-start-position))) (+ (lexer-state-start-pos ls)
(and tokens (+ (lexer-state-start-pos ls) (send tokens get-root-start-position)))
(send tokens get-root-end-position))))) (and tokens ls
(+ (lexer-state-start-pos ls)
(send tokens get-root-end-position)))))
(define/private (get-tokens-at-position who position) (define/private (get-tokens-at-position who position)
(when stopped? (when stopped?
(error who "called on a color:text<%> whose colorer is stopped.")) (error who "called on a color:text<%> whose colorer is stopped."))
(let ([ls (find-ls position)]) (let ([ls (find-ls position)])
(and ls (if ls
(let ([tokens (lexer-state-tokens ls)]) (let ([tokens (lexer-state-tokens ls)])
(tokenize-to-pos ls position) (tokenize-to-pos ls position)
(send tokens search! (- position (lexer-state-start-pos ls))) (send tokens search! (- position (lexer-state-start-pos ls)))
(values tokens ls))))) (values tokens ls))
(values #f #f))))
(define/private (tokenize-to-pos ls position) (define/private (tokenize-to-pos ls position)
(when (and (not (lexer-state-up-to-date? ls)) (when (and (not (lexer-state-up-to-date? ls))

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

@ -256,7 +256,7 @@
(define/public (locate-file name) (define/public (locate-file name)
(let* ([normalized (let* ([normalized
;; allow for the possiblity of filenames that are urls ;; allow for the possibility of filenames that are urls
(with-handlers ([(λ (x) #t) (with-handlers ([(λ (x) #t)
(λ (x) name)]) (λ (x) name)])
(normal-case-path (normal-case-path

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

@ -209,7 +209,7 @@
(let ([current-items (let ([current-items
(map (λ (x) (and (is-a? x labelled-menu-item<%>) (send x get-label))) (map (λ (x) (and (is-a? x labelled-menu-item<%>) (send x get-label)))
(send menu get-items))] (send menu get-items))]
;; the new-items variable shoudl match up to what install-recent-items actually does when it creates the menu ;; the new-items variable should match up to what install-recent-items actually does when it creates the menu
[new-items [new-items
(append (append
(for/list ([recent-list-item recently-opened-files]) (for/list ([recent-list-item recently-opened-files])

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

@ -1127,7 +1127,7 @@
(add "make-read-only" make-read-only) (add "make-read-only" make-read-only)
(add "beginning-of-line" beginning-of-line) (add "beginning-of-line" beginning-of-line)
(add "selec-to-beginning-of-line" select-to-beginning-of-line) (add "select-to-beginning-of-line" select-to-beginning-of-line)
; Map keys to functions ; Map keys to functions

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

@ -505,3 +505,119 @@
(define horizontal-dragable% (horizontal-dragable-mixin (dragable-mixin panel%))) (define horizontal-dragable% (horizontal-dragable-mixin (dragable-mixin panel%)))
(define splitter<%> (interface () split-horizontal split-vertical collapse))
;; we need a private interface so we can use `generic' because `generic'
;; doesn't work on mixins
(define splitter-private<%> (interface () self-vertical? self-horizontal?))
(define splitter-mixin
(mixin (area-container<%> dragable<%>) (splitter<%> splitter-private<%>)
(super-new)
(inherit get-children add-child
delete-child
change-children
begin-container-sequence
end-container-sequence)
(field [horizontal-panel% horizontal-dragable%]
[vertical-panel% vertical-dragable%])
(define/public (self-vertical?)
(send this get-vertical?))
(define/public (self-horizontal?)
(not (send this get-vertical?)))
;; insert an item into a list after some element
;; FIXME: this is probably a library function somewhere
(define/private (insert-after list before item)
(let loop ([so-far '()]
[list list])
(cond
[(null? list) (reverse so-far)]
[(eq? (car list) before) (loop (cons item (cons before so-far))
(cdr list))]
[else (loop (cons (car list) so-far) (cdr list))])))
;; replace an element with a list of stuff
;; FIXME: this is probably a library function somewhere
(define/private (replace list at stuff)
(let loop ([so-far '()]
[list list])
(cond
[(null? list) (reverse so-far)]
[(eq? (car list) at) (append (reverse so-far) stuff (cdr list))]
[else (loop (cons (car list) so-far) (cdr list))])))
;; remove a canvas and merge split panels if necessary
;; TODO: restore percentages
(define/public (collapse canvas)
(begin-container-sequence)
(for ([child (get-children)])
(cond
[(eq? child canvas)
(when (> (length (get-children)) 1)
(change-children
(lambda (old-children)
(remq canvas old-children))))]
[(is-a? child splitter<%>)
(send child collapse canvas)]))
(change-children
(lambda (old-children)
(for/list ([child old-children])
(if (and (is-a? child splitter<%>)
(= (length (send child get-children)) 1))
(let ()
(define single (car (send child get-children)))
(send single reparent this)
single)
child))))
(end-container-sequence))
;; split a canvas by creating a new editor and either
;; 1) adding it to the panel if the panel is already using the same
;; orientation as the split that is about to occur
;; 2) create a new panel with the orientation of the split about to
;; occur and add a new editor
;;
;; in both cases the new editor is returned
(define/private (do-split canvas maker orientation? orientation% split)
(define new-canvas #f)
(for ([child (get-children)])
(cond
[(eq? child canvas)
(begin-container-sequence)
(change-children
(lambda (old-children)
(if (send-generic this orientation?)
(let ([new (maker this)])
(set! new-canvas new)
(insert-after old-children child new))
(let ()
(define container (new (splitter-mixin orientation%)
[parent this]))
(send canvas reparent container)
(define created (maker container))
(set! new-canvas created)
;; this throws out the old child but we should probably
;; try to keep it
(replace old-children child (list container))))))
(end-container-sequence)]
[(is-a? child splitter<%>)
(let ([something (send-generic child split canvas maker)])
(when something
(set! new-canvas something)))]))
new-canvas)
;; canvas (widget -> editor) -> editor
(define/public (split-horizontal canvas maker)
(do-split canvas maker (generic splitter-private<%> self-horizontal?)
horizontal-panel% (generic splitter<%> split-horizontal)))
;; canvas (widget -> editor) -> editor
(define/public (split-vertical canvas maker)
(do-split canvas maker (generic splitter-private<%> self-vertical?)
vertical-panel% (generic splitter<%> split-vertical)))
))

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

@ -604,7 +604,7 @@
[(not contains) [(not contains)
;; Something went wrong matching. Should we get here? ;; Something went wrong matching. Should we get here?
(do-indent 0)] (do-indent 0)]
#; ;; disable this to accomodate PLAI programs; return to this when a #lang capability is set up. #; ;; disable this to accommodate PLAI programs; return to this when a #lang capability is set up.
[(curley-brace-sexp?) [(curley-brace-sexp?)
;; when we are directly inside an sexp that uses {}s, ;; when we are directly inside an sexp that uses {}s,
;; we indent in a more C-like fashion (to help Scribble) ;; we indent in a more C-like fashion (to help Scribble)

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

@ -57,7 +57,10 @@
horizontal-dragable<%> horizontal-dragable<%>
horizontal-dragable-mixin horizontal-dragable-mixin
horizontal-dragable%)) horizontal-dragable%
splitter<%>
splitter-mixin))
(define-signature panel^ extends panel-class^ (define-signature panel^ extends panel-class^
(dragable-container-size (dragable-container-size
dragable-place-children)) dragable-place-children))

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

@ -1825,6 +1825,9 @@
(define-struct committer (kr commit-peeker-evt done-evt resp-chan resp-nack)) (define-struct committer (kr commit-peeker-evt done-evt resp-chan resp-nack))
(define msec-timeout 500) (define msec-timeout 500)
;; this value (4096) is also mentioned in the test suite (collects/tests/framework/test.rkt)
;; so if you change it, be sure to change things over there too
(define output-buffer-full 4096) (define output-buffer-full 4096)
(define-local-member-name (define-local-member-name
@ -1873,6 +1876,17 @@
(send value-sd set-delta-foreground (make-object color% 0 0 175)) (send value-sd set-delta-foreground (make-object color% 0 0 175))
(create-style-name value-style-name value-sd))) (create-style-name value-style-name value-sd)))
;; data : any
;; to-insert-chan : (or/c #f channel)
;; if to-insert-chan is a channel, this means
;; the eventspace handler thread is the one that
;; is initiating the communication, so instead of
;; queueing a callback to do the update of the editor,
;; just send the work back directly and it will be done
;; syncronously there. If it is #f, then we queue a callback
;; to do the work
(define-struct data/chan (data to-insert-chan))
(define ports-mixin (define ports-mixin
(mixin (wide-snip<%>) (ports<%>) (mixin (wide-snip<%>) (ports<%>)
(inherit begin-edit-sequence (inherit begin-edit-sequence
@ -2160,7 +2174,7 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;;
;; output port syncronization code ;; output port synchronization code
;; ;;
;; flush-chan : (channel (evt void)) ;; flush-chan : (channel (evt void))
@ -2241,7 +2255,7 @@
(after-io-insertion)))) (after-io-insertion))))
(define/public (after-io-insertion) (void)) (define/public (after-io-insertion) (void))
(define output-buffer-thread (define output-buffer-thread
(let ([converter (bytes-open-converter "UTF-8-permissive" "UTF-8")]) (let ([converter (bytes-open-converter "UTF-8-permissive" "UTF-8")])
(thread (thread
@ -2257,13 +2271,16 @@
(alarm-evt (+ last-flush msec-timeout)) (alarm-evt (+ last-flush msec-timeout))
(λ (_) (λ (_)
(let-values ([(viable-bytes remaining-queue) (split-queue converter text-to-insert)]) (let-values ([(viable-bytes remaining-queue) (split-queue converter text-to-insert)])
;; we always queue the work here since the always event means no one waits for the callback
(queue-insertion viable-bytes always-evt) (queue-insertion viable-bytes always-evt)
(loop remaining-queue (current-inexact-milliseconds)))))) (loop remaining-queue (current-inexact-milliseconds))))))
(handle-evt (handle-evt
flush-chan flush-chan
(λ (return-evt) (λ (return-evt/to-insert-chan)
(let-values ([(viable-bytes remaining-queue) (split-queue converter text-to-insert)]) (let-values ([(viable-bytes remaining-queue) (split-queue converter text-to-insert)])
(queue-insertion viable-bytes return-evt) (if (channel? return-evt/to-insert-chan)
(channel-put return-evt/to-insert-chan viable-bytes)
(queue-insertion viable-bytes return-evt/to-insert-chan))
(loop remaining-queue (current-inexact-milliseconds))))) (loop remaining-queue (current-inexact-milliseconds)))))
(handle-evt (handle-evt
clear-output-chan clear-output-chan
@ -2271,16 +2288,22 @@
(loop (empty-queue) (current-inexact-milliseconds)))) (loop (empty-queue) (current-inexact-milliseconds))))
(handle-evt (handle-evt
write-chan write-chan
(λ (pr) (λ (pr-pr)
(define return-chan (car pr-pr))
(define pr (cdr pr-pr))
(let ([new-text-to-insert (enqueue pr text-to-insert)]) (let ([new-text-to-insert (enqueue pr text-to-insert)])
(cond (cond
[((queue-size text-to-insert) . < . output-buffer-full) [((queue-size text-to-insert) . < . output-buffer-full)
(when return-chan
(channel-put return-chan '()))
(loop new-text-to-insert last-flush)] (loop new-text-to-insert last-flush)]
[else [else
(let ([chan (make-channel)]) (let ([chan (make-channel)])
(let-values ([(viable-bytes remaining-queue) (let-values ([(viable-bytes remaining-queue)
(split-queue converter new-text-to-insert)]) (split-queue converter new-text-to-insert)])
(queue-insertion viable-bytes (channel-put-evt chan (void))) (if return-chan
(channel-put return-chan viable-bytes)
(queue-insertion viable-bytes (channel-put-evt chan (void))))
(channel-get chan) (channel-get chan)
(loop remaining-queue (current-inexact-milliseconds))))])))))))))) (loop remaining-queue (current-inexact-milliseconds))))]))))))))))
@ -2300,16 +2323,23 @@
(λ (to-write start end block/buffer? enable-breaks?) (λ (to-write start end block/buffer? enable-breaks?)
(cond (cond
[(= start end) (flush-proc)] [(= start end) (flush-proc)]
[(eq? (current-thread) (eventspace-handler-thread eventspace))
(error 'write-bytes-proc "cannot write to port on eventspace main thread")]
[else [else
(channel-put write-chan (cons (subbytes to-write start end) style))]) (define pair (cons (subbytes to-write start end) style))
(cond
[(eq? (current-thread) (eventspace-handler-thread eventspace))
(define return-channel (make-channel))
(thread (λ () (channel-put write-chan (cons return-channel pair))))
(do-insertion (channel-get return-channel) #f)]
[else
(channel-put write-chan (cons #f pair))])])
(- end start))) (- end start)))
(define (flush-proc) (define (flush-proc)
(cond (cond
[(eq? (current-thread) (eventspace-handler-thread eventspace)) [(eq? (current-thread) (eventspace-handler-thread eventspace))
(error 'flush-proc "cannot flush port on eventspace main thread")] (define to-insert-channel (make-channel))
(thread (λ () (channel-put flush-chan to-insert-channel)))
(do-insertion (channel-get to-insert-channel) #f)]
[else [else
(sync (sync
(nack-guard-evt (nack-guard-evt
@ -2327,17 +2357,18 @@
(define (make-write-special-proc style) (define (make-write-special-proc style)
(λ (special can-buffer? enable-breaks?) (λ (special can-buffer? enable-breaks?)
(define str/snp (cond
[(string? special) special]
[(is-a? special snip%) special]
[else (format "~s" special)]))
(define to-send (cons str/snp style))
(cond (cond
[(eq? (current-thread) (eventspace-handler-thread eventspace)) [(eq? (current-thread) (eventspace-handler-thread eventspace))
(error 'write-bytes-proc "cannot write to port on eventspace main thread")] (define return-chan (make-channel))
(thread (λ () (channel-put write-chan (cons return-chan to-send))))
(do-insertion (channel-get return-chan) #f)]
[else [else
(let ([str/snp (cond (channel-put write-chan (cons #f to-send))])
[(string? special) special]
[(is-a? special snip%) special]
[else (format "~s" special)])])
(channel-put
write-chan
(cons str/snp style)))])
#t)) #t))
(let* ([add-standard (let* ([add-standard
@ -3121,7 +3152,7 @@ designates the character that triggers autocompletion
(show-options word start-pos end-pos completion-cursor))))) (show-options word start-pos end-pos completion-cursor)))))
;; Number -> String ;; Number -> String
;; The word that ends at the current positon of the editor ;; The word that ends at the current position of the editor
(define/public (get-word-at current-pos) (define/public (get-word-at current-pos)
(let ([start-pos (box current-pos)]) (let ([start-pos (box current-pos)])
(find-wordbreak start-pos #f 'caret) (find-wordbreak start-pos #f 'caret)
@ -3720,7 +3751,7 @@ designates the character that triggers autocompletion
;; draws line numbers on the left hand side of a text% object ;; draws line numbers on the left hand side of a text% object
(define line-numbers-mixin (define line-numbers-mixin
(mixin ((class->interface text%)) (line-numbers<%>) (mixin ((class->interface text%) editor:standard-style-list<%>) (line-numbers<%>)
(inherit get-visible-line-range (inherit get-visible-line-range
get-visible-position-range get-visible-position-range
last-line last-line
@ -3732,7 +3763,7 @@ designates the character that triggers autocompletion
set-padding set-padding
get-padding) get-padding)
(init-field [line-numbers-color "black"]) (init-field [line-numbers-color #f])
(init-field [show-line-numbers? #t]) (init-field [show-line-numbers? #t])
;; whether the numbers are aligned on the left or right ;; whether the numbers are aligned on the left or right
;; only two values should be 'left or 'right ;; only two values should be 'left or 'right
@ -3774,9 +3805,12 @@ designates the character that triggers autocompletion
(define style-change-notify (define style-change-notify
(lambda (style) (unless style (setup-padding)))) (lambda (style) (unless style (setup-padding))))
(define/private (get-style-font) (define/private (get-style)
(let* ([style-list (send this get-style-list)] (let* ([style-list (editor:get-standard-style-list)]
[std (or (send style-list find-named-style "Standard") [std (or (send style-list
find-named-style
(editor:get-default-color-style-name))
(send style-list find-named-style "Standard")
(send style-list basic-style))]) (send style-list basic-style))])
;; If the style changes, we should re-check the width of ;; If the style changes, we should re-check the width of
;; drawn line numbers: ;; drawn line numbers:
@ -3785,8 +3819,13 @@ designates the character that triggers autocompletion
(send style-list notify-on-change style-change-notify) (send style-list notify-on-change style-change-notify)
;; Avoid registering multiple notifications: ;; Avoid registering multiple notifications:
(set! notify-registered-in-list style-list)) (set! notify-registered-in-list style-list))
;; Extract the font from the style: std))
(send std get-font)))
(define/private (get-style-foreground)
(send (get-style) get-foreground))
(define/private (get-style-font)
(send (get-style) get-font))
(define-struct saved-dc-state (pen font foreground-color)) (define-struct saved-dc-state (pen font foreground-color))
(define/private (save-dc-state dc) (define/private (save-dc-state dc)
@ -3799,11 +3838,16 @@ designates the character that triggers autocompletion
(send dc set-font (saved-dc-state-font dc-state)) (send dc set-font (saved-dc-state-font dc-state))
(send dc set-text-foreground (saved-dc-state-foreground-color dc-state))) (send dc set-text-foreground (saved-dc-state-foreground-color dc-state)))
(define/private (get-foreground)
(if line-numbers-color
(make-object color% line-numbers-color)
(get-style-foreground)))
;; set the dc stuff to values we want ;; set the dc stuff to values we want
(define/private (setup-dc dc) (define/private (setup-dc dc)
(send dc set-pen "black" 1 'solid) (send dc set-pen "black" 1 'solid)
(send dc set-font (get-style-font)) (send dc set-font (get-style-font))
(send dc set-text-foreground (make-object color% line-numbers-color))) (send dc set-text-foreground (get-foreground)))
(define/private (lighter-color color) (define/private (lighter-color color)
(define (integer number) (define (integer number)
@ -3914,7 +3958,7 @@ designates the character that triggers autocompletion
(begin (begin
(send dc set-text-foreground (lighter-color (send dc get-text-foreground))) (send dc set-text-foreground (lighter-color (send dc get-text-foreground)))
(draw-text view final-x final-y) (draw-text view final-x final-y)
(send dc set-text-foreground (make-object color% line-numbers-color))) (send dc set-text-foreground (get-foreground)))
(draw-text view final-x final-y))) (draw-text view final-x final-y)))
(set! last-paragraph (line-paragraph line)))) (set! last-paragraph (line-paragraph line))))

2
collects/mred/info.rkt
View File

@ -1,4 +1,4 @@
#lang setup/infotab #lang setup/infotab
(define version '(400)) (define version '(510))
(define post-install-collection "installer.rkt") (define post-install-collection "installer.rkt")

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

@ -91,6 +91,7 @@ get-panel-background
get-ps-setup-from-user get-ps-setup-from-user
get-highlight-background-color get-highlight-background-color
get-highlight-text-color get-highlight-text-color
get-resource
get-text-from-user get-text-from-user
get-the-editor-data-class-list get-the-editor-data-class-list
get-the-snip-class-list get-the-snip-class-list
@ -210,4 +211,5 @@ window<%>
write-editor-global-footer write-editor-global-footer
write-editor-global-header write-editor-global-header
write-editor-version write-editor-version
write-resource
yield yield

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

@ -48,7 +48,7 @@
;; the alarm is immediately ready. This makes `sleep/yield' ;; the alarm is immediately ready. This makes `sleep/yield'
;; more like `sleep': ;; more like `sleep':
(wx:yield) (wx:yield)
;; Now, realy sleep: ;; Now, really sleep:
(wx:yield evt)) (wx:yield evt))
(void)) (void))

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

@ -5,6 +5,7 @@
make-base-empty-namespace) make-base-empty-namespace)
scheme/class scheme/class
racket/draw racket/snip racket/draw racket/snip
file/resource
mzlib/etc mzlib/etc
(prefix wx: "kernel.ss") (prefix wx: "kernel.ss")
(prefix wx: "wxme/editor.ss") (prefix wx: "wxme/editor.ss")
@ -169,7 +170,8 @@
[else #f]))) [else #f])))
(provide (all-from racket/draw) (provide (all-from racket/draw)
(all-from racket/snip)) (all-from racket/snip)
(all-from file/resource))
(provide button% (provide button%
canvas% canvas%

6
collects/mred/private/seqcontract.rkt
View File

@ -410,13 +410,13 @@ Matthew
set-before ;SetBefore set-before ;SetBefore
set-after ;SetAfter set-after ;SetAfter
;ReallyCanEdit -- only when op != wxEDIT_COPY ;ReallyCanEdit -- only when op != wxEDIT_COPY
;Refresh has wierd code checking writeLocked -- what does < 0 mean? ;Refresh has weird code checking writeLocked -- what does < 0 mean?
do-paste ; DoPaste do-paste ; DoPaste
paste ; Paste paste ; Paste
insert-port ; InsertPort insert-port ; InsertPort
insert-file ; InsertFile insert-file ; InsertFile
read-from-file ; ReadFromFile read-from-file ; ReadFromFile
; BeginEditSequence ;; -- wierd flag check ; BeginEditSequence ;; -- weird flag check
; EndEditSequence ;; -- wierd flag check, like BeginEditSequence ; EndEditSequence ;; -- weird flag check, like BeginEditSequence
|# |#

2
collects/mred/private/wx/cocoa/frame.rkt
View File

@ -549,7 +549,7 @@
(define/public (on-activate on?) (void)) (define/public (on-activate on?) (void))
(define/public (set-icon bm1 bm2 [mode 'both]) (void)) ;; FIXME (define/public (set-icon bm1 [bm2 #f] [mode 'both]) (void)) ;; FIXME
(define/override (call-pre-on-event w e) (define/override (call-pre-on-event w e)
(pre-on-event w e)) (pre-on-event w e))

4
collects/mred/private/wx/cocoa/gauge.rkt
View File

@ -32,8 +32,8 @@
(super-new [parent parent] (super-new [parent parent]
[cocoa (let ([cocoa (as-objc-allocation [cocoa (let ([cocoa (as-objc-allocation
;; Beware that a guage may be finally deallocated in ;; Beware that a gauge may be finally deallocated in
;; a seperate OS-level thread ;; a separate OS-level thread
(tell (tell MyProgressIndicator alloc) init))]) (tell (tell MyProgressIndicator alloc) init))])
(tellv cocoa setIndeterminate: #:type _BOOL #f) (tellv cocoa setIndeterminate: #:type _BOOL #f)
(tellv cocoa setMaxValue: #:type _double* rng) (tellv cocoa setMaxValue: #:type _double* rng)

4
collects/mred/private/wx/cocoa/queue.rkt
View File

@ -49,7 +49,7 @@
(define-objc-class MyApplicationDelegate NSObject #:protocols (NSApplicationDelegate) (define-objc-class MyApplicationDelegate NSObject #:protocols (NSApplicationDelegate)
[] []
[-a _int (applicationShouldTerminate: [_id app]) [-a _NSUInteger (applicationShouldTerminate: [_id app])
(queue-quit-event) (queue-quit-event)
0] 0]
[-a _BOOL (openPreferences: [_id app]) [-a _BOOL (openPreferences: [_id app])
@ -120,7 +120,7 @@
(import-class NSEvent) (import-class NSEvent)
(define wake-evt (define wake-evt
(tell NSEvent (tell NSEvent
otherEventWithType: #:type _int NSApplicationDefined otherEventWithType: #:type _NSUInteger NSApplicationDefined
location: #:type _NSPoint (make-NSPoint 0.0 0.0) location: #:type _NSPoint (make-NSPoint 0.0 0.0)
modifierFlags: #:type _NSUInteger 0 modifierFlags: #:type _NSUInteger 0
timestamp: #:type _double 0.0 timestamp: #:type _double 0.0

24
collects/mred/private/wx/cocoa/radio-box.rkt
View File

@ -26,6 +26,9 @@
#:mixins (FocusResponder KeyMouseResponder CursorDisplayer) #:mixins (FocusResponder KeyMouseResponder CursorDisplayer)
[wxb] [wxb]
(-a _void (clicked: [_id sender]) (-a _void (clicked: [_id sender])
;; In case we were in 0-item mode, switch to Radio mode to
;; ensure that only one button is selected:
(tellv self setAllowsEmptySelection: #:type _BOOL #f)
(queue-window*-event wxb (lambda (wx) (send wx clicked))))) (queue-window*-event wxb (lambda (wx) (send wx clicked)))))
(define-objc-class MyImageButtonCell NSButtonCell (define-objc-class MyImageButtonCell NSButtonCell
@ -126,16 +129,21 @@
(define/public (set-selection i) (define/public (set-selection i)
(if (= i -1) (if (= i -1)
(begin (begin
;; Need to change to NSListModeMatrix to disable all. (tellv (get-cocoa) setAllowsEmptySelection: #:type _BOOL #t)
;; 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) deselectAllCells))
(tellv (get-cocoa) selectCellAtRow: #:type _NSInteger (if horiz? 0 i) (begin
column: #:type _NSInteger (if horiz? i 0)))) (tellv (get-cocoa) selectCellAtRow: #:type _NSInteger (if horiz? 0 i)
column: #:type _NSInteger (if horiz? i 0))
(tellv (get-cocoa) setAllowsEmptySelection: #:type _BOOL #f))))
(define/public (get-selection) (define/public (get-selection)
(if horiz? (let ([c (tell (get-cocoa) selectedCell)]
(tell #:type _NSInteger (get-cocoa) selectedColumn) [pos (if horiz?
(tell #:type _NSInteger (get-cocoa) selectedRow))) (tell #:type _NSInteger (get-cocoa) selectedColumn)
(tell #:type _NSInteger (get-cocoa) selectedRow))])
(if (and c
(positive? (tell #:type _NSInteger c state)))
pos
-1)))
(define/public (number) count) (define/public (number) count)
(define/override (maybe-register-as-child parent on?) (define/override (maybe-register-as-child parent on?)

7
collects/mred/private/wx/cocoa/slider.rkt
View File

@ -8,6 +8,7 @@
"const.rkt" "const.rkt"
"utils.rkt" "utils.rkt"
"window.rkt" "window.rkt"
"queue.rkt"
"../common/event.rkt" "../common/event.rkt"
"../common/queue.rkt" "../common/queue.rkt"
"../common/freeze.rkt" "../common/freeze.rkt"
@ -158,6 +159,12 @@
(define/public (update-message [val (get-value)]) (define/public (update-message [val (get-value)])
(tellv message-cocoa setTitleWithMnemonic: #:type _NSString (format "~a" val))) (tellv message-cocoa setTitleWithMnemonic: #:type _NSString (format "~a" val)))
(inherit get-cocoa-window)
(define/override (post-mouse-down)
;; For some reason, dragging a slider disabled mouse-moved
;; events for the window, so turn them back on:
(tellv (get-cocoa-window) setAcceptsMouseMovedEvents: #:type _BOOL #t))
(define/override (maybe-register-as-child parent on?) (define/override (maybe-register-as-child parent on?)
(register-as-child parent on?))) (register-as-child parent on?)))

7
collects/mred/private/wx/cocoa/window.rkt
View File

@ -98,7 +98,10 @@
[wxb] [wxb]
[-a _void (mouseDown: [_id event]) [-a _void (mouseDown: [_id event])
(unless (do-mouse-event wxb event 'left-down #t #f #f 'right-down) (unless (do-mouse-event wxb event 'left-down #t #f #f 'right-down)
(super-tell #:type _void mouseDown: event))] (super-tell #:type _void mouseDown: event)
(let ([wx (->wx wxb)])
(when wx
(send wx post-mouse-down))))]
[-a _void (mouseUp: [_id event]) [-a _void (mouseUp: [_id event])
(unless (do-mouse-event wxb event 'left-up #f #f #f 'right-up) (unless (do-mouse-event wxb event 'left-up #f #f #f 'right-up)
(super-tell #:type _void mouseUp: event))] (super-tell #:type _void mouseUp: event))]
@ -727,6 +730,8 @@
[caps-down #f]) [caps-down #f])
#f)) #f))
(define/public (post-mouse-down) (void))
(define/public (on-char s) (void)) (define/public (on-char s) (void))
(define/public (on-event m) (void)) (define/public (on-event m) (void))
(define/public (queue-on-size) (void)) (define/public (queue-on-size) (void))

2
collects/mred/private/wx/gtk/clipboard.rkt
View File

@ -25,7 +25,6 @@
(define _GtkClipboard (_cpointer 'GtkClipboard)) (define _GtkClipboard (_cpointer 'GtkClipboard))
(define _GtkDisplay _pointer) (define _GtkDisplay _pointer)
(define _GtkSelectionData (_cpointer 'GtkSelectionData))
;; Recent versions of Gtk provide function calls to ;; Recent versions of Gtk provide function calls to
;; access data, but use structure when the functions are ;; access data, but use structure when the functions are
@ -38,6 +37,7 @@
[length _int] [length _int]
[display _GtkDisplay])) [display _GtkDisplay]))
(define _GtkSelectionData _GtkSelectionDataT-pointer)
(define-gdk gdk_atom_intern (_fun _string _gboolean -> _GdkAtom)) (define-gdk gdk_atom_intern (_fun _string _gboolean -> _GdkAtom))

4
collects/mred/private/wx/gtk/frame.rkt
View File

@ -216,7 +216,7 @@
(adjust-client-delta 0 h)) (adjust-client-delta 0 h))
;; Hack: calls back into the mred layer to re-compute ;; Hack: calls back into the mred layer to re-compute
;; sizes. By calling this early enough, the frame won't ;; sizes. By calling this early enough, the frame won't
;; grow if it doesn't have to grow to accomodate the menu bar. ;; grow if it doesn't have to grow to accommodate the menu bar.
(send this resized)) (send this resized))
(define saved-enforcements (vector 0 0 -1 -1)) (define saved-enforcements (vector 0 0 -1 -1))
@ -334,7 +334,7 @@
(define big-icon #f) (define big-icon #f)
(define small-icon #f) (define small-icon #f)
(define/public (set-icon bm mask [mode 'both]) (define/public (set-icon bm [mask #f] [mode 'both])
(let ([bm (if mask (let ([bm (if mask
(let* ([nbm (make-object bitmap% (let* ([nbm (make-object bitmap%
(send bm get-width) (send bm get-width)

2
collects/mred/private/wx/win32/canvas.rkt
View File

@ -116,7 +116,7 @@
(if hscroll? WS_HSCROLL 0) (if hscroll? WS_HSCROLL 0)
(if vscroll? WS_VSCROLL 0)) (if vscroll? WS_VSCROLL 0))
0 0 w h 0 0 w h
(or panel-hwnd (send parent get-hwnd)) (or panel-hwnd (send parent get-client-hwnd))
#f #f
hInstance hInstance
#f)) #f))

2
collects/mred/private/wx/win32/frame.rkt
View File

@ -527,7 +527,7 @@
(define small-hicon #f) (define small-hicon #f)
(define big-hicon #f) (define big-hicon #f)
(define/public (set-icon bm mask [mode 'both]) (define/public (set-icon bm [mask #f] [mode 'both])
(let* ([bg-hbitmap (let* ([bg-hbitmap
(let* ([bm (make-object bitmap% (send bm get-width) (send bm get-height))] (let* ([bm (make-object bitmap% (send bm get-width) (send bm get-height))]
[dc (make-object bitmap-dc% bm)]) [dc (make-object bitmap-dc% bm)])

2
collects/mred/private/wx/win32/gl-context.rkt
View File

@ -137,7 +137,7 @@
PFD_SUPPORT_GDI) PFD_SUPPORT_GDI)
(bitwise-ior PFD_DRAW_TO_WINDOW))) (bitwise-ior PFD_DRAW_TO_WINDOW)))
PFD_TYPE_RGBA ; color type PFD_TYPE_RGBA ; color type
(if offscreen? 32 24) ; prefered color depth (if offscreen? 32 24) ; preferred color depth
0 0 0 0 0 0 ; color bits (ignored) 0 0 0 0 0 0 ; color bits (ignored)
0 ; no alpha buffer 0 ; no alpha buffer
0 ; alpha bits (ignored) 0 ; alpha bits (ignored)

77
collects/mred/private/wx/win32/radio-box.rkt
View File

@ -49,42 +49,47 @@
(define label-bitmaps null) (define label-bitmaps null)
(define radio-hwnds (define radio-hwnds
(let loop ([y 0] [w 0] [labels labels]) (let ([horiz? (memq 'horizontal style)])
(if (null? labels) (let loop ([y 0] [w 0] [labels labels])
(begin (if (null? labels)
(MoveWindow hwnd 0 0 w y #t) (begin
null) (MoveWindow hwnd 0 0 w y #t)
(let* ([label (car labels)] null)
[bitmap? (label . is-a? . bitmap%)] (let* ([label (car labels)]
[radio-hwnd [bitmap? (label . is-a? . bitmap%)]
(CreateWindowExW/control 0 [radio-hwnd
"PLTBUTTON" (CreateWindowExW/control 0
(if (string? label) "PLTBUTTON"
label (if (string? label)
"<image>") label
(bitwise-ior BS_RADIOBUTTON WS_CHILD WS_CLIPSIBLINGS "<image>")
(if bitmap? (bitwise-ior BS_RADIOBUTTON WS_CHILD WS_CLIPSIBLINGS
BS_BITMAP (if bitmap?
0)) BS_BITMAP
0 0 0 0 0))
hwnd 0 0 0 0
#f hwnd
hInstance #f
#f)]) hInstance
(when bitmap? #f)])
(let ([hbitmap (bitmap->hbitmap label)]) (when bitmap?
(set! label-bitmaps (cons hbitmap label-bitmaps)) (let ([hbitmap (bitmap->hbitmap label)])
(SendMessageW radio-hwnd BM_SETIMAGE IMAGE_BITMAP (set! label-bitmaps (cons hbitmap label-bitmaps))
(cast hbitmap _HBITMAP _LPARAM)))) (SendMessageW radio-hwnd BM_SETIMAGE IMAGE_BITMAP
(ShowWindow radio-hwnd SW_SHOW) (cast hbitmap _HBITMAP _LPARAM))))
(set-control-font font radio-hwnd) (ShowWindow radio-hwnd SW_SHOW)
(let-values ([(w1 h) (set-control-font font radio-hwnd)
(auto-size font label 0 0 20 4 (let-values ([(w1 h)
(lambda (w h) (auto-size font label 0 0 20 4
(MoveWindow radio-hwnd 0 (+ y SEP) w h #t) (lambda (w1 h1)
(values w h)))]) (if horiz?
(cons radio-hwnd (MoveWindow radio-hwnd (+ w SEP) 0 w1 h1 #t)
(loop (+ y SEP h) (max w1 w) (cdr labels)))))))) (MoveWindow radio-hwnd 0 (+ y SEP) w1 h1 #t))
(values w1 h1)))])
(cons radio-hwnd
(loop (if horiz? (max y h) (+ y SEP h))
(if horiz? (+ w SEP w1) (max w1 w))
(cdr labels)))))))))
(unless (= val -1) (unless (= val -1)
(SendMessageW (list-ref radio-hwnds val) BM_SETCHECK 1 0)) (SendMessageW (list-ref radio-hwnds val) BM_SETCHECK 1 0))

2
collects/mred/private/wxme/editor-snip.rkt
View File

@ -111,7 +111,7 @@
(when (and s-admin (when (and s-admin
(has-flag? s-flags USES-BUFFER-PATH)) (has-flag? s-flags USES-BUFFER-PATH))
;; propogate a filename change: ;; propagate a filename change:
(if (and editor (if (and editor
(no-permanent-filename? editor)) (no-permanent-filename? editor))
(let ([b (send s-admin get-editor)]) (let ([b (send s-admin get-editor)])

2
collects/mred/private/wxme/mline.rkt
View File

@ -1039,7 +1039,7 @@ Debugging tools:
[next (mline-next mline)]) [next (mline-next mline)])
(when (or (not (eq? (mline-snip next) asnip)) (when (or (not (eq? (mline-snip next) asnip))
(not (has-flag? (snip->flags (mline-last-snip next)) NEWLINE))) (not (has-flag? (snip->flags (mline-last-snip next)) NEWLINE)))
;; Effect can propogate to more lines, merging the ;; Effect can propagate to more lines, merging the
;; next several. (Handle prefixing the remains of the source of ;; next several. (Handle prefixing the remains of the source of
;; the extension to this line onto the next line. Implemented ;; the extension to this line onto the next line. Implemented
;; as the next line eating the next->next line.) ;; as the next line eating the next->next line.)

4
collects/mred/private/wxme/pasteboard.rkt
View File

@ -1729,10 +1729,10 @@
(set-box! h total-height)) (set-box! h total-height))
(send s-admin get-view x y w h #t)) (send s-admin get-view x y w h #t))
(let ([w (if (w . > . 1000.0) (let ([w (if (w . > . 1000.0)
500.0 ; don't belive it 500.0 ; don't believe it
w)] w)]
[h (if (h . > . 1000.0) [h (if (h . > . 1000.0)
500.0 ; don't belive it 500.0 ; don't believe it
h)]) h)])
(values (/ w 2) (values (/ w 2)
(/ h 2))))) (/ h 2)))))

4
collects/mred/private/wxme/text.rkt
View File

@ -2849,7 +2849,7 @@
(set! write-locked? #t) (set! write-locked? #t)
(set! flow-locked? #t) (set! flow-locked? #t)
;; linear seach for snip ;; linear search for snip
(let ([topy (mline-get-location line)]) (let ([topy (mline-get-location line)])
(let loop ([snip (mline-snip line)] (let loop ([snip (mline-snip line)]
[X X] [X X]
@ -3159,7 +3159,7 @@
(values (mline-last-snip line) (+ horiz (- (mline-w line) (mline-last-w line))) (values (mline-last-snip line) (+ horiz (- (mline-w line) (mline-last-w line)))
start #f)] start #f)]
[else [else
;; linear seach for snip ;; linear search for snip
(let loop ([snip (mline-snip line)] (let loop ([snip (mline-snip line)]
[start start] [start start]
[horiz horiz] [horiz horiz]

2
collects/mrlib/cache-image-snip.rkt
View File

@ -21,7 +21,7 @@
The true meaning of an image is a vector of rationals, The true meaning of an image is a vector of rationals,
between 0 & 255, representing color and alpha channel between 0 & 255, representing color and alpha channel
information. The vector's contents are analagous to information. The vector's contents are analogous to
the last argument to the get-argb-pixels method. That is, the last argument to the get-argb-pixels method. That is,
there are (* 4 w h) entries in the vector for an image there are (* 4 w h) entries in the vector for an image
of width w and height h, and the entries represent the of width w and height h, and the entries represent the

2
collects/mrlib/image-core.rkt
View File

@ -255,7 +255,7 @@ has been moved out).
(or (and (not (skip-image-equality-fast-path)) ;; this is here to make testing more effective (or (and (not (skip-image-equality-fast-path)) ;; this is here to make testing more effective
(equal? (get-normalized-shape) (send that get-normalized-shape))) (equal? (get-normalized-shape) (send that get-normalized-shape)))
(let ([w (+ 1 (round (inexact->exact (bb-right bb))))] ;; some shapes (ie, rectangles) draw 1 outside the bounding box (let ([w (+ 1 (round (inexact->exact (bb-right bb))))] ;; some shapes (ie, rectangles) draw 1 outside the bounding box
[h (+ 1 (round (inexact->exact (bb-bottom bb))))]) ;; so we make the bitmap slightly bigger to accomodate that. [h (+ 1 (round (inexact->exact (bb-bottom bb))))]) ;; so we make the bitmap slightly bigger to accommodate that.
(or ;(zero? w) (or ;(zero? w)
;(zero? h) ;(zero? h)
(let ([bm1 (make-bitmap w h #t)] (let ([bm1 (make-bitmap w h #t)]

2
collects/mrlib/name-message.rkt
View File

@ -255,7 +255,7 @@
(+ border-inset (+ border-inset
circle-spacer circle-spacer
button-label-inset button-label-inset
(if (eq? (system-type) 'windows) 1 0) ;; becuase "(define ...)" has the wrong size under windows (if (eq? (system-type) 'windows) 1 0) ;; because "(define ...)" has the wrong size under windows
(max 0 (inexact->exact (ceiling tw))) (max 0 (inexact->exact (ceiling tw)))
button-label-inset button-label-inset
triangle-width triangle-width

14
collects/mrlib/private/aligned-pasteboard/alignment.rkt
View File

@ -1,19 +1,19 @@
#| #|
This code computes the sizees for the rectangles in the space using the on dimention This code computes the sizees for the rectangles in the space using the on dimension
off dimention method of referencing sizes. This means for example instead of saying off dimension method of referencing sizes. This means for example instead of saying
width we say off dimention for vertical alignment. Inorder to consume and return width we say off dimension for vertical alignment. Inorder to consume and return
the values in terms of width and height manipulation had to be done. I chose to create the values in terms of width and height manipulation had to be done. I chose to create
a struct abs-rect (abstract rectangle) and have code map horizontal and vertical rect a struct abs-rect (abstract rectangle) and have code map horizontal and vertical rect
stucts on to them. This code is a bit long but more readable than the other two options stucts on to them. This code is a bit long but more readable than the other two options
I came up with. I came up with.
1) define all functions to be letrec bound functions inside align. align then take 1) define all functions to be letrec bound functions inside align. align then take
accessors for the rect struct. The caller of align swaps the order of ondimention accessors for the rect struct. The caller of align swaps the order of ondimension
and off dimention accessors for vertical or horizontal code. This method does not and off dimension accessors for vertical or horizontal code. This method does not
allow the use of the readable, short, consis pattern matching code. As some of the allow the use of the readable, short, consis pattern matching code. As some of the
matching code is easily removed this may be a good option but a large letrec matching code is easily removed this may be a good option but a large letrec
is harder to write tests for. is harder to write tests for.
2) define a pattern matcher syntax that will match the struct rect but swap the fields 2) define a pattern matcher syntax that will match the struct rect but swap the fields
based on wich on is the on or off dimention. This would have been shorter but much based on wich on is the on or off dimension. This would have been shorter but much
more confusing. more confusing.
The current implementation requires align to map over the rects and allocate new stucts The current implementation requires align to map over the rects and allocate new stucts
for each one on both passing into and returning from stretch-to-fit; This is not a bottle for each one on both passing into and returning from stretch-to-fit; This is not a bottle
@ -141,7 +141,7 @@ neck and it is the most readable solution.
(loop rest-rects (+ onpos onsize))))])))) (loop rest-rects (+ onpos onsize))))]))))
;; waner (natural-number? . -> . (-> (union 1 0))) ;; waner (natural-number? . -> . (-> (union 1 0)))
;; makes a thunk that returns 1 for it's first n applications, zero otherwise ;; makes a thunk that returns 1 for its first n applications, zero otherwise
(define (waner n) (define (waner n)
(lambda () (lambda ()
(if (zero? n) (if (zero? n)

2
collects/mrlib/private/aligned-pasteboard/geometry-managed-pasteboard.rkt
View File

@ -50,7 +50,7 @@
(get-aligned-min-sizes type (find-first-snip))))) (get-aligned-min-sizes type (find-first-snip)))))
;; set-algined-min-sizes (-> void?) ;; set-algined-min-sizes (-> void?)
;; set the aligned min width and height of the pasteboard based on it's children snips ;; set the aligned min width and height of the pasteboard based on its children snips
(inherit in-edit-sequence?) (inherit in-edit-sequence?)
(define/public (aligned-min-sizes-invalid) (define/public (aligned-min-sizes-invalid)
;; This in-edit-sequence? is not sound. It causes me to percollate invalidation ;; This in-edit-sequence? is not sound. It causes me to percollate invalidation

2
collects/mrlib/private/aligned-pasteboard/pasteboard-lib.rkt
View File

@ -27,7 +27,7 @@
[else pasteboard]))) [else pasteboard])))
;; gets the canvas or snip that the pasteboard is displayed in ;; gets the canvas or snip that the pasteboard is displayed in
;; status: what if there is more than one canvas? should this be allowed? probablly not. ;; status: what if there is more than one canvas? should this be allowed? probably not.
(define (pasteboard-parent pasteboard) (define (pasteboard-parent pasteboard)
(let ([admin (send pasteboard get-admin)]) (let ([admin (send pasteboard get-admin)])
(cond (cond

2
collects/mrlib/private/image-core-bitmap.rkt
View File

@ -27,7 +27,7 @@ instead of this scaling code, we use the dc<%>'s scaling code.
; bmbytes: a bytes which represents an image -- ; bmbytes: a bytes which represents an image --
; it's size is a multiple of 4, and each ; its size is a multiple of 4, and each
; four consecutive bytes represent alpha,r,g,b. ; four consecutive bytes represent alpha,r,g,b.

2
collects/mrlib/scribblings/tex-table.scrbl
View File

@ -14,7 +14,7 @@
(= (string-length x) (= (string-length x)
1)))))]{ 1)))))]{
This is an assocation list mapping the shortcut strings that This is an association list mapping the shortcut strings that
DrRacket uses with its @tt{control-\} (or @tt{command-\}) strings to DrRacket uses with its @tt{control-\} (or @tt{command-\}) strings to
their corresponding unicode characters. For example, it contains their corresponding unicode characters. For example, it contains
this mapping: this mapping:

2
collects/scribblings/framework/canvas.scrbl
View File

@ -53,7 +53,7 @@
Any Any
@scheme[canvas%] @scheme[canvas%]
that matches this interface will automatically that matches this interface will automatically
resize selected snips when it's size changes. Use resize selected snips when its size changes. Use
@method[canvas:wide-snip<%> add-tall-snip] @method[canvas:wide-snip<%> add-tall-snip]
and and
@method[canvas:wide-snip<%> add-wide-snip] @method[canvas:wide-snip<%> add-wide-snip]

18
collects/scribblings/framework/editor.scrbl
View File

@ -25,7 +25,7 @@
for more info about edit sequences. for more info about edit sequences.
} }
@defmethod*[(((run-after-edit-sequence (thunk (-> void)) (tag (union symbol? |#f|) |#f|)) void))]{ @defmethod*[(((run-after-edit-sequence (thunk (-> void)) (tag (union symbol? #f) #f)) void))]{
This method is used to install callbacks that will be run after any This method is used to install callbacks that will be run after any
edit-sequence completes. edit-sequence completes.
@ -40,7 +40,7 @@
@method[editor:basic<%> run-after-edit-sequence]'s argument will be called. @method[editor:basic<%> run-after-edit-sequence]'s argument will be called.
} }
@defmethod*[(((get-top-level-window) (union |#f| (is-a?/c top-level-window<%>))))]{ @defmethod*[(((get-top-level-window) (union #f (is-a?/c top-level-window<%>))))]{
Returns the Returns the
@scheme[top-level-window<%>] @scheme[top-level-window<%>]
currently associated with this buffer. currently associated with this buffer.
@ -53,7 +53,7 @@
Returns @scheme[#t] if the file on disk has been modified, by some other program. Returns @scheme[#t] if the file on disk has been modified, by some other program.
} }
@defmethod*[(((save-file/gui-error (filename (union path |#f|) |#f|) (format (union (quote guess) (quote standard) (quote text) (quote text-force-cr) same copy) (quote same)) (show-errors? boolean |#t|)) boolean?))]{ @defmethod*[(((save-file/gui-error (filename (union path #f) #f) (format (union (quote guess) (quote standard) (quote text) (quote text-force-cr) same copy) (quote same)) (show-errors? boolean |#t|)) boolean?))]{
This method is an alternative to This method is an alternative to
@method[editor<%> save-file]. Rather than showing errors via the original stdout, it @method[editor<%> save-file]. Rather than showing errors via the original stdout, it
opens a dialog with an error message showing the error. opens a dialog with an error message showing the error.
@ -63,7 +63,7 @@
no error occurred and @scheme[#f] if an error occurred. no error occurred and @scheme[#f] if an error occurred.
} }
@defmethod*[(((load-file/gui-error (filename (union string |#f|) |#f|) (format (union (quote guess) (quote standard) (quote text) (quote text-force-cr) (quote same) (quote copy)) (quote guess)) (show-errors? boolean |#t|)) boolean?))]{ @defmethod*[(((load-file/gui-error (filename (union string #f) #f) (format (union (quote guess) (quote standard) (quote text) (quote text-force-cr) (quote same) (quote copy)) (quote guess)) (show-errors? boolean |#t|)) boolean?))]{
This method is an alternative to This method is an alternative to
@method[editor<%> load-file]. Rather than showing errors via the original stdout, it @method[editor<%> load-file]. Rather than showing errors via the original stdout, it
opens a dialog with an error message showing the error. opens a dialog with an error message showing the error.
@ -346,8 +346,8 @@
the filesystem. the filesystem.
The class that this mixin produces uses the same initialization The class that this mixin produces uses the same initialization
arguments as it's input. arguments as its input.
@defmethod*[#:mode override (((set-filename (name string) (temp? boolean |#f|)) void))]{ @defmethod*[#:mode override (((set-filename (name string) (temp? boolean #f)) void))]{
Updates the filename on each frame displaying this editor, for each Updates the filename on each frame displaying this editor, for each
frame that matches frame that matches
@ -379,7 +379,7 @@
@definterface[editor:backup-autosave<%> (editor:basic<%>)]{ @definterface[editor:backup-autosave<%> (editor:basic<%>)]{
Classes matching this interface support backup files and autosaving. Classes matching this interface support backup files and autosaving.
@defmethod*[(((backup?) boolean?))]{ @defmethod*[(((backup?) boolean?))]{
Indicates weather this Indicates whether this
@scheme[editor<%>] @scheme[editor<%>]
should be backed up. should be backed up.
@ -392,14 +392,14 @@
} }
@defmethod*[(((autosave?) boolean?))]{ @defmethod*[(((autosave?) boolean?))]{
Indicates weather this Indicates whether this
@scheme[editor<%>] @scheme[editor<%>]
should be autosaved. should be autosaved.
Returns @scheme[#t]. Returns @scheme[#t].
} }
@defmethod*[(((do-autosave) (union |#f| string)))]{ @defmethod*[(((do-autosave) (union #f string)))]{
This method is called to perform the autosaving. This method is called to perform the autosaving.
See also See also
@scheme[autosave:register] @scheme[autosave:register]

34
collects/scribblings/framework/panel.scrbl
View File

@ -174,4 +174,38 @@
@defclass[panel:vertical-dragable% (panel:vertical-dragable-mixin (panel:dragable-mixin vertical-panel%)) ()]{} @defclass[panel:vertical-dragable% (panel:vertical-dragable-mixin (panel:dragable-mixin vertical-panel%)) ()]{}
@defclass[panel:horizontal-dragable% (panel:horizontal-dragable-mixin (panel:dragable-mixin horizontal-panel%)) ()]{} @defclass[panel:horizontal-dragable% (panel:horizontal-dragable-mixin (panel:dragable-mixin horizontal-panel%)) ()]{}
@definterface[panel:splitter<%> ()]{
A panel that implements @scheme[panel:splitter<%>]. Children can be split
horizonally or vertically.
}
@defmixin[panel:splitter-mixin (area-container<%> panel:dragable<%>) (splitter<%>)]{
This mixin allows panels to split their children either horizontally or
vertically. Children that are split can be further split independant of any
other splitting.
@defmethod[(split-vertical (canvas (instance-of (is-a?/c canvas<%>)))
(maker (-> (instance-of (is-a?/c splitter<%>))
(instance-of (is-a?/c canvas<%>)))))
(instance-of (is-a?/c canvas<%>))]{
Splits the @scheme[canvas] vertically by creating a new instance using
@scheme[maker]. This splitter object is passed as the argument to
@scheme[maker] and should be used as the @scheme[parent] field of the newly
created canvas.
}
@defmethod[(split-horizontal (canvas (instance-of (is-a?/c canvas<%>)))
(maker (-> (instance-of (is-a?/c splitter<%>))
(instance-of (is-a?/c canvas<%>)))))
(instance-of (is-a?/c canvas<%>))]{
Similar to @scheme[split-vertical] but splits horizontally.
}
@defmethod[(collapse (canvas (instance-of (is-a?/c canvas<%>)))) void]{
Removes the given @scheme[canvas] from the splitter hierarchy and collapses
any split panes as necessary.
}
}
@(include-previously-extracted "main-extracts.ss" #rx"^panel:") @(include-previously-extracted "main-extracts.ss" #rx"^panel:")

271
collects/scribblings/framework/scheme.scrbl
View File

@ -7,272 +7,251 @@
@definterface[scheme:sexp-snip<%> ()]{ @definterface[scheme:sexp-snip<%> ()]{
@defmethod*[(((get-saved-snips) (listof snip%)))]{ @defmethod*[(((get-saved-snips) (listof snip%)))]{
This returns the list of snips hidden by the sexp snip. This returns the list of snips hidden by the sexp snip.
} }
} }
@defclass[scheme:sexp-snip% snip% (scheme:sexp-snip<%> readable-snip<%>)]{ @defclass[scheme:sexp-snip% snip% (scheme:sexp-snip<%> readable-snip<%>)]{
@defmethod*[#:mode override
@defmethod*[#:mode override (((get-text (offset number) (num number) (flattened? boolean |#f|)) string))]{ (((get-text (offset number) (num number)
(flattened? boolean #f))
Returns the concatenation of the text for all of the hidden string))]{
snips. Returns the concatenation of the text for all of the hidden snips.
} }
@defmethod*[#:mode override (((copy) (is-a?/c scheme:sexp-snip%)))]{ @defmethod*[#:mode override (((copy) (is-a?/c scheme:sexp-snip%)))]{
Returns a copy of this snip that includes the hidden snips. Returns a copy of this snip that includes the hidden snips.
} }
@defmethod*[#:mode override (((write (stream-out editor-stream-out%)) void))]{ @defmethod*[#:mode override (((write (stream-out editor-stream-out%)) void))]{
Saves the embedded snips Saves the embedded snips
} }
@defmethod*[#:mode override (((draw (dc dc<%>) (x real) (y real) (left real) (top real) (right real) (bottom real) (dx real) (dy real) (draw-caret symbol?)) void))]{ @defmethod*[#:mode override
(((draw (dc dc<%>) (x real) (y real)
(left real) (top real) (right real) (bottom real)
(dx real) (dy real) (draw-caret symbol?))
void))]{
Draws brackets with a centered ellipses between them. Draws brackets with a centered ellipses between them.
} }
@defmethod*[#:mode override (((get-extent (dc (is-a?/c dc<%>)) (x real) (y real) (w boxed |#f|) (h boxed |#f|) (descent boxed |#f|) (space boxed |#f|) (lspace boxed |#f|) (rspace boxed |#f|)) void))]{ @defmethod*[#:mode override
(((get-extent (dc (is-a?/c dc<%>)) (x real) (y real)
(w boxed #f) (h boxed #f)
(descent boxed #f) (space boxed #f)
(lspace boxed #f) (rspace boxed #f))
void))]{
Returns a size corresponding to what this snip draws. Returns a size corresponding to what this snip draws.
} }
} }
@definterface[scheme:text<%> (text:basic<%> mode:host-text<%> color:text<%>)]{ @definterface[scheme:text<%> (text:basic<%> mode:host-text<%> color:text<%>)]{
Texts matching this interface support Racket mode operations. Texts matching this interface support Racket mode operations.
@defmethod*[(((get-limit (start exact-integer)) int))]{ @defmethod*[(((get-limit (start exact-integer)) int))]{
Returns a limit for backward-matching parenthesis starting at
Returns a limit for backward-matching parenthesis starting at position position @scheme[start].
@scheme[start].
} }
@defmethod*[(((balance-parens (key-event (instance key-event%))) void))]{ @defmethod*[(((balance-parens (key-event (instance key-event%))) void))]{
This function is called when the user types a close parenthesis in the This function is called when the user types a close parenthesis in
@scheme[text%]. If the close parenthesis that the user inserted does not match the the @scheme[text%]. If the close parenthesis that the user inserted
corresponding open parenthesis and the @scheme['framework:fixup-parens] preference is does not match the corresponding open parenthesis and the
@scheme[#t] (see @scheme['framework:fixup-parens] preference is @scheme[#t] (see
@scheme[preferences:get]) the correct closing parenthesis is inserted. @scheme[preferences:get]) the correct closing parenthesis is
If the @scheme['framework:paren-match] preference is inserted. If the @scheme['framework:paren-match] preference is
@scheme[#t] (see @scheme[#t] (see @scheme[preferences:get]) the matching open
@scheme[preferences:get]) the matching open parenthesis is flashed. parenthesis is flashed.
} }
@defmethod*[(((tabify-on-return?) boolean?))]{ @defmethod*[(((tabify-on-return?) boolean?))]{
The result of this method is used to determine if the return key The result of this method is used to determine if the return key
automatically tabs over to the correct position. automatically tabs over to the correct position.
Override it to change its behavior. Override it to change its behavior.
} }
@defmethod*[(((tabify (start-pos exact-integer (send this text get-start-position))) void))]{ @defmethod*[(((tabify (start-pos exact-integer
(send this text get-start-position)))
void))]{
Tabs the line containing by @scheme[start-pos] Tabs the line containing by @scheme[start-pos]
} }
@defmethod*[(((tabify-selection (start exact-integer) (end exact-integer)) void))]{ @defmethod*[(((tabify-selection (start exact-integer) (end exact-integer))
void))]{
Sets the tabbing for the lines containing positions @scheme[start] Sets the tabbing for the lines containing positions @scheme[start]
through @scheme[end]. through @scheme[end].
} }
@defmethod*[(((tabify-all) void))]{ @defmethod*[(((tabify-all) void))]{
Tabs all lines. Tabs all lines.
} }
@defmethod*[(((insert-return) void))]{ @defmethod*[(((insert-return) void))]{
Inserts a newline into the buffer. If
Inserts a newline into the buffer. If @method[scheme:text<%> tabify-on-return?] returns @scheme[#t], this
@method[scheme:text<%> tabify-on-return?] will tabify the new line.
returns @scheme[#t], this will tabify the new line.
} }
@defmethod*[(((box-comment-out-selection (start-pos (or/c (symbols 'start) exact-integer?)) (end-pos (or/c (symbols 'end) exact-integer?))) void))]{ @defmethod*[(((box-comment-out-selection
This method comments out a selection in the text by putting it into a comment box. (start-pos (or/c (symbols 'start) exact-integer?))
(end-pos (or/c (symbols 'end) exact-integer?)))
void))]{
This method comments out a selection in the text by putting it into
a comment box.
Removes the region from @scheme[start-pos] to @scheme[end-pos] from
the editor and inserts a comment box with that region of text
inserted into the box.
Removes the region from @scheme[start-pos] to @scheme[end-pos] If @scheme[start-pos] is @scheme['start], the starting point of the
from the editor and inserts a comment box with that region selection is used. If @scheme[end-pos] is @scheme['end], the ending
of text inserted into the box. point of the selection is used.
If @scheme[start-pos] is @scheme['start], the starting point of
the selection is used. If @scheme[end-pos] is @scheme['end],
the ending point of the selection is used.
} }
@defmethod*[(((comment-out-selection (start exact-integer) (end exact-integer)) void))]{ @defmethod*[(((comment-out-selection (start exact-integer)
(end exact-integer))
Comments the lines containing positions @scheme[start] through @scheme[end] void))]{
by inserting a semi-colon at the front of each line. Comments the lines containing positions @scheme[start] through
@scheme[end] by inserting a semi-colon at the front of each line.
} }
@defmethod*[(((uncomment-selection (start int) (end int)) void))]{ @defmethod*[(((uncomment-selection (start int) (end int)) void))]{
Uncomments the lines containing positions @scheme[start] through
Uncomments the lines containing positions @scheme[start] through @scheme[end]. @scheme[end].
} }
@defmethod*[(((get-forward-sexp (start exact-integer)) (union |#f| exact-integer)))]{ @defmethod*[(((get-forward-sexp (start exact-integer))
(union #f exact-integer)))]{
Returns the position of the end of next S-expression after position Returns the position of the end of next S-expression after position
@scheme[start], or @scheme[#f] if there is no appropriate answer. @scheme[start], or @scheme[#f] if there is no appropriate answer.
} }
@defmethod*[(((remove-sexp (start exact-integer)) void))]{ @defmethod*[(((remove-sexp (start exact-integer)) void))]{
Forward-deletes the S-expression starting after the position
Forward-deletes the S-expression starting after the position @scheme[start]. @scheme[start].
} }
@defmethod*[(((forward-sexp (start |#t|)) exact-integer))]{ @defmethod*[(((forward-sexp (start |#t|)) exact-integer))]{
Moves forward over the S-expression starting at position
Moves forward over the S-expression starting at position @scheme[start]. @scheme[start].
} }
@defmethod*[(((flash-forward-sexp (start-pos exact-integer)) void))]{ @defmethod*[(((flash-forward-sexp (start-pos exact-integer)) void))]{
Flashes the parenthesis that closes the sexpression at Flashes the parenthesis that closes the sexpression at
@scheme[start-pos]. @scheme[start-pos].
} }
@defmethod*[(((get-backward-sexp (start exact-integer)) (union exact-integer |#f|)))]{ @defmethod*[(((get-backward-sexp (start exact-integer))
(union exact-integer #f)))]{
Returns the position of the start of the S-expression before or Returns the position of the start of the S-expression before or
containing @scheme[start], or @scheme[#f] if there is no appropriate containing @scheme[start], or @scheme[#f] if there is no appropriate
answer. answer.
} }
@defmethod*[(((flash-backward-sexp (start-pos exact-integer)) void))]{ @defmethod*[(((flash-backward-sexp (start-pos exact-integer)) void))]{
Flashes the parenthesis that opens the sexpression at Flashes the parenthesis that opens the sexpression at
@scheme[start-pos]. @scheme[start-pos].
} }
@defmethod*[(((backward-sexp (start-pos exact-integer)) void))]{ @defmethod*[(((backward-sexp (start-pos exact-integer)) void))]{
Move the caret backwards one sexpression Move the caret backwards one sexpression
Moves the caret to the beginning of the sexpression that ends at Moves the caret to the beginning of the sexpression that ends at
@scheme[start-pos]. @scheme[start-pos].
} }
@defmethod*[(((find-up-sexp (start-pos exact-integer)) (union |#f| exact-integer)))]{ @defmethod*[(((find-up-sexp (start-pos exact-integer))
(union #f exact-integer)))]{
Returns the position of the beginning of the next sexpression outside Returns the position of the beginning of the next sexpression
the sexpression that contains @scheme[start-pos]. If there is no such outside the sexpression that contains @scheme[start-pos]. If there
sexpression, it returns @scheme[#f]. is no such sexpression, it returns @scheme[#f].
} }
@defmethod*[(((up-sexp (start exact-integer)) void))]{ @defmethod*[(((up-sexp (start exact-integer)) void))]{
Moves backward out of the S-expression containing the position
Moves backward out of the S-expression containing the position @scheme[start]. @scheme[start].
} }
@defmethod*[(((find-down-sexp (start-pos exact-integer)) (union |#f| exact-integer)))]{ @defmethod*[(((find-down-sexp (start-pos exact-integer))
(union #f exact-integer)))]{
Returns the position of the beginning of the next sexpression inside Returns the position of the beginning of the next sexpression inside
the sexpression that contains @scheme[start-pos]. If there is no such the sexpression that contains @scheme[start-pos]. If there is no
sexpression, it returns @scheme[#f]. such sexpression, it returns @scheme[#f].
} }
@defmethod*[(((down-sexp (start exact-integer)) void))]{ @defmethod*[(((down-sexp (start exact-integer)) void))]{
Moves forward into the next S-expression after the position
Moves forward into the next S-expression after the position @scheme[start]. @scheme[start].
} }
@defmethod*[(((remove-parens-forward (start exact-integer)) void))]{ @defmethod*[(((remove-parens-forward (start exact-integer)) void))]{
Removes the parentheses from the S-expression starting after the Removes the parentheses from the S-expression starting after the
position @scheme[start]. position @scheme[start].
} }
@defmethod*[(((select-forward-sexp (start exact-integer)) |#t|))]{ @defmethod*[(((select-forward-sexp (start exact-integer)) |#t|))]{
Selects the next S-expression, starting at position @scheme[start]. Selects the next S-expression, starting at position @scheme[start].
} }
@defmethod*[(((select-backward-sexp (start exact-integer)) |#t|))]{ @defmethod*[(((select-backward-sexp (start exact-integer)) |#t|))]{
Selects the previous S-expression, starting at position
Selects the previous S-expression, starting at position @scheme[start]. @scheme[start].
} }
@defmethod*[(((select-up-sexp (start exact-integer)) |#t|))]{ @defmethod*[(((select-up-sexp (start exact-integer)) |#t|))]{
Selects the region to the enclosing S-expression, starting at
Selects the region to the enclosing S-expression, starting at position @scheme[start]. position @scheme[start].
} }
@defmethod*[(((select-down-sexp (start exact-integer)) |#t|))]{ @defmethod*[(((select-down-sexp (start exact-integer)) |#t|))]{
Selects the region to the next contained S-expression, starting at
Selects the region to the next contained S-expression, starting at position @scheme[start]. position @scheme[start].
} }
@defmethod*[(((transpose-sexp (start exact-integer)) void))]{ @defmethod*[(((transpose-sexp (start exact-integer)) void))]{
Swaps the S-expression beginning before the position @scheme[start]
Swaps the S-expression beginning before the position @scheme[start] with with the next S-expression following @scheme[start].
the next S-expression following @scheme[start].
} }
@defmethod*[(((mark-matching-parenthesis (pos exact-positive-integer)) void))]{ @defmethod*[(((mark-matching-parenthesis (pos exact-positive-integer))
If the paren after @scheme[pos] is matched, this method void))]{
highlights it and its matching counterpart in dark green. If the paren after @scheme[pos] is matched, this method highlights
it and its matching counterpart in dark green.
} }
@defmethod*[(((get-tab-size) exact-integer))]{ @defmethod*[(((get-tab-size) exact-integer))]{
This method returns the current size of the tabs for scheme mode. This method returns the current size of the tabs for scheme mode.
See also See also @method[scheme:text<%> set-tab-size].
@method[scheme:text<%> set-tab-size].
} }
@defmethod*[(((set-tab-size (new-size exact-integer)) void))]{ @defmethod*[(((set-tab-size (new-size exact-integer)) void))]{
This method sets the tab size for this This method sets the tab size for this text.
text.
} }
@defmethod*[(((introduce-let-ans) void))]{ @defmethod*[(((introduce-let-ans) void))]{
Adds a let around the current s-expression and a printf into the body Adds a let around the current s-expression and a printf into the
of the let. body of the let.
} }
@defmethod*[(((move-sexp-out) void))]{ @defmethod*[(((move-sexp-out) void))]{
Replaces the sexpression surrounding the insertion point with the Replaces the sexpression surrounding the insertion point with the
sexpression following the insertion point. sexpression following the insertion point.
} }
} }
@defmixin[scheme:text-mixin (text:basic<%> mode:host-text<%> color:text<%> text:autocomplete<%>) (scheme:text<%>)]{ @defmixin[scheme:text-mixin
(text:basic<%> mode:host-text<%> color:text<%> text:autocomplete<%>)
(scheme:text<%>)]{
This mixin adds functionality for editing Racket files. This mixin adds functionality for editing Racket files.
The result of this mixin uses the same initialization arguments as the The result of this mixin uses the same initialization arguments as the
mixin's argument. mixin's argument.
@defmethod*[#:mode override (((get-word-at (pos positive-exact-integer)) string))]{
Returns the word just before @scheme[pos], which is then used
as the prefix for auto-completion.
@defmethod*[#:mode override
(((get-word-at (pos positive-exact-integer)) string))]{
Returns the word just before @scheme[pos], which is then used as the
prefix for auto-completion.
} }
@defmethod[#:mode override (get-start-of-line [pos exact-nonnegative-integer?]) exact-nonnegative-integer?]{ @defmethod[#:mode override
Returns the first non-whitespace character in the paragraph containing @racket[pos], (get-start-of-line [pos exact-nonnegative-integer?])
unless the position is already there, in which case it returns the first position of the paragraph. exact-nonnegative-integer?]{
Returns the first non-whitespace character in the paragraph
containing @racket[pos], unless the position is already there, in
which case it returns the first position of the paragraph.
} }
} }
@definterface[scheme:text-mode<%> ()]{ @definterface[scheme:text-mode<%> ()]{
The result of The result of @scheme[scheme:text-mode-mixin] implements this
@scheme[scheme:text-mode-mixin] interface.
implements this interface.
} }
@defmixin[scheme:text-mode-mixin (color:text-mode<%> mode:surrogate-text<%>) (scheme:text-mode<%>)]{ @defmixin[scheme:text-mode-mixin
This mixin adds Racket mode functionality (color:text-mode<%> mode:surrogate-text<%>)
to the mode that it is mixed into. The resulting (scheme:text-mode<%>)]{
mode assumes that it is only set to an editor This mixin adds Racket mode functionality to the mode that it is mixed
that is the result of into. The resulting mode assumes that it is only set to an editor
@scheme[scheme:text-mixin]. that is the result of @scheme[scheme:text-mixin].
@defmethod*[#:mode override (((on-disable-surrogate) void))]{
Removes the scheme keymap (see also @defmethod*[#:mode override (((on-disable-surrogate) void))]{
@scheme[scheme:get-keymap]) and disables any parenthesis Removes the scheme keymap (see also @scheme[scheme:get-keymap]) and
highlighting in the host editor. disables any parenthesis highlighting in the host editor.
} }
@defmethod*[#:mode override (((on-enable-surrogate) void))]{ @defmethod*[#:mode override (((on-enable-surrogate) void))]{
Adds the scheme keymap (see also @scheme[scheme:get-keymap]) and
Adds the scheme keymap (see also enables a parenthesis highlighting in the host editor.
@scheme[scheme:get-keymap]) and enables a parenthesis
highlighting in the host editor.
} }
} }
@defmixin[scheme:set-mode-mixin (scheme:text<%> mode:host-text<%>) ()]{ @defmixin[scheme:set-mode-mixin (scheme:text<%> mode:host-text<%>) ()]{
This mixin creates a new instance of This mixin creates a new instance of @scheme[scheme:text-mode%] and
@scheme[scheme:text-mode%] installs it, by calling its own @method[mode:host-text<%>
and installs it, by calling its own set-surrogate] method with the object.
@method[mode:host-text<%> set-surrogate]
method with the object.
} }
@defclass[scheme:text% (scheme:set-mode-mixin (scheme:text-mixin (text:autocomplete-mixin (mode:host-text-mixin color:text%)))) ()]{} @defclass[scheme:text%
(scheme:set-mode-mixin
(scheme:text-mixin
(text:autocomplete-mixin (mode:host-text-mixin color:text%))))
()]{}
@defclass[scheme:text-mode% (scheme:text-mode-mixin color:text-mode%) ()]{} @defclass[scheme:text-mode% (scheme:text-mode-mixin color:text-mode%) ()]{}
@(include-previously-extracted "main-extracts.ss" #rx"^scheme:") @(include-previously-extracted "main-extracts.ss" #rx"^scheme:")

31
collects/scribblings/framework/text.scrbl
View File

@ -107,7 +107,7 @@
moved. A snip may refuse to be moved by returning @scheme[#f] from moved. A snip may refuse to be moved by returning @scheme[#f] from
@method[snip% release-from-owner]. @method[snip% release-from-owner].
} }
@defmethod*[(((initial-autowrap-bitmap) (union |#f| (instance bitmap%))))]{ @defmethod*[(((initial-autowrap-bitmap) (union #f (instance bitmap%))))]{
The result of this method is used as the initial autowrap The result of this method is used as the initial autowrap
bitmap. Override this method to change the initial bitmap. Override this method to change the initial
@scheme[bitmap%]. See also @scheme[bitmap%]. See also
@ -135,7 +135,7 @@
} }
@defmethod[(get-edition-number) exact-nonnegative-integer?]{ @defmethod[(get-edition-number) exact-nonnegative-integer?]{
Returns a number that increments everytime something in Returns a number that increments every time something in
the editor changes. the editor changes.
The number is updated in @xmethod[text% after-insert] and The number is updated in @xmethod[text% after-insert] and
@ -156,7 +156,7 @@
objects in the framework. objects in the framework.
The class that this mixin produces uses the same initialization The class that this mixin produces uses the same initialization
arguments as it's input. arguments as its input.
@defmethod*[#:mode override (((on-paint (before? any/c) (dc (is-a?/c dc<%>)) (left real?) (top real?) (right real?) (bottom real?) (dx real?) (dy real?) (draw-caret (one-of/c (quote no-caret) (quote show-inactive-caret) (quote show-caret)))) void))]{ @defmethod*[#:mode override (((on-paint (before? any/c) (dc (is-a?/c dc<%>)) (left real?) (top real?) (right real?) (bottom real?) (dx real?) (dy real?) (draw-caret (one-of/c (quote no-caret) (quote show-inactive-caret) (quote show-caret)))) void))]{
Draws the rectangles installed by Draws the rectangles installed by
@ -488,13 +488,13 @@
The contents of the two The contents of the two
editor are kept in sync, as modifications editor are kept in sync, as modifications
to this object happen. to this object happen.
@defmethod*[(((get-delegate) (union |#f| (instanceof text%))))]{ @defmethod*[(((get-delegate) (union #f (instanceof text%))))]{
The result of this method is the @scheme[text%] object The result of this method is the @scheme[text%] object
that the contents of this editor are being delegated to, or that the contents of this editor are being delegated to, or
@scheme[#f], if there is none. @scheme[#f], if there is none.
} }
@defmethod*[(((set-delegate (delegate (union |#f| (instanceof text%)))) void))]{ @defmethod*[(((set-delegate (delegate (union #f (instanceof text%)))) void))]{
This method sets the current delegate. This method sets the current delegate.
@ -531,7 +531,17 @@
Creates and returns an instance of Creates and returns an instance of
@scheme[text:1-pixel-string-snip%]. @scheme[text:1-pixel-string-snip%].
} }
@defmethod*[#:mode override (((get-extent (dc (instanceof dc<%>)) (x real) (y real) (w (box (union non-negative-real-number |#f|)) |#f|) (h (box (union non-negative-real-number |#f|)) |#f|) (descent (box (union non-negative-real-number |#f|)) |#f|) (space (box (union non-negative-real-number |#f|)) |#f|) (lspace (box (union non-negative-real-number |#f|)) |#f|) (rspace (box (union non-negative-real-number |#f|)) |#f|)) void))]{ @defmethod*[#:mode override
(((get-extent
(dc (instanceof dc<%>))
(x real) (y real)
(w (box (union non-negative-real-number #f)) #f)
(h (box (union non-negative-real-number #f)) #f)
(descent (box (union non-negative-real-number #f)) #f)
(space (box (union non-negative-real-number #f)) #f)
(lspace (box (union non-negative-real-number #f)) #f)
(rspace (box (union non-negative-real-number #f)) #f))
void))]{
Sets the descent, space, lspace, and rspace to zero. Sets Sets the descent, space, lspace, and rspace to zero. Sets
the height to 1. Sets the width to the number of characters the height to 1. Sets the width to the number of characters
@ -573,7 +583,7 @@
Creates and returns an instance of Creates and returns an instance of
@scheme[text:1-pixel-tab-snip%]. @scheme[text:1-pixel-tab-snip%].
} }
@defmethod*[#:mode override (((get-extent (dc (instanceof dc<%>)) (x real) (y real) (w (box (union non-negative-real-number |#f|)) |#f|) (h (box (union non-negative-real-number |#f|)) |#f|) (descent (box (union non-negative-real-number |#f|)) |#f|) (space (box (union non-negative-real-number |#f|)) |#f|) (lspace (box (union non-negative-real-number |#f|)) |#f|) (rspace (box (union non-negative-real-number |#f|)) |#f|)) void))]{ @defmethod*[#:mode override (((get-extent (dc (instanceof dc<%>)) (x real) (y real) (w (box (union non-negative-real-number #f)) #f) (h (box (union non-negative-real-number #f)) #f) (descent (box (union non-negative-real-number #f)) #f) (space (box (union non-negative-real-number #f)) #f) (lspace (box (union non-negative-real-number #f)) #f) (rspace (box (union non-negative-real-number #f)) #f)) void))]{
Sets the descent, space, lspace, and rspace to zero. Sets Sets the descent, space, lspace, and rspace to zero. Sets
the height to 1. Sets the width to the width of tabs as the height to 1. Sets the width to the width of tabs as
@ -818,7 +828,7 @@
} }
@definterface[text:ports<%> ()]{ @definterface[text:ports<%> ()]{
Classes implementing this interface (via the associated Classes implementing this interface (via the associated
mixin) support input and output ports that read from the mixin) support input and output ports that read from and to the
editor. editor.
There are two input ports: the normal input port just reads There are two input ports: the normal input port just reads
@ -826,6 +836,11 @@
inserts an editor snip into this text and uses input typed inserts an editor snip into this text and uses input typed
into the box as input into the port. into the box as input into the port.
There are three output ports, designed to match stdout, stderr,
and a special port for printing values. The only difference
between them is the output is rendered in different colors
when it comes in via the different ports.
They create three threads to mediate access to the input and They create three threads to mediate access to the input and
output ports (one for each input port and one for all of the output ports (one for each input port and one for all of the
output ports). output ports).

3
collects/scribblings/gui/gui.scrbl
View File

@ -10,7 +10,8 @@
@defmodule*/no-declare[(racket/gui/base)]{The @defmodule*/no-declare[(racket/gui/base)]{The
@racketmodname[racket/gui/base] library provides all of the class, @racketmodname[racket/gui/base] library provides all of the class,
interface, and procedure bindings defined in this manual, in addition interface, and procedure bindings defined in this manual, in addition
to the bindings of @racketmodname[racket/draw].} to the bindings of @racketmodname[racket/draw] and
@racketmodname[file/resource].}
@defmodulelang*/no-declare[(racket/gui)]{The @defmodulelang*/no-declare[(racket/gui)]{The
@racketmodname[racket/gui] language combines all bindings of the @racketmodname[racket/gui] language combines all bindings of the

18
collects/scribblings/gui/window-intf.scrbl
View File

@ -374,6 +374,14 @@ Called when this window or a child window receives a keyboard event.
@method[window<%> on-subwindow-char] method returns @scheme[#f], the event is passed on to the receiver's @method[window<%> on-subwindow-char] method returns @scheme[#f], the event is passed on to the receiver's
normal key-handling mechanism. normal key-handling mechanism.
The @scheme[event] argument is the event that was generated for the
@scheme[receiver] window.
The atomicity limitation @method[window<%> on-subwindow-event] applies
to @method[window<%> on-subwindow-char] as well. That is, an insufficiently cooperative
@method[window<%> on-subwindow-char] method can effectively disable
a control's handling of key events, even when it returns @racket[#f]
BEWARE: The default BEWARE: The default
@xmethod[frame% on-subwindow-char] and @xmethod[frame% on-subwindow-char] and
@xmethod[dialog% on-subwindow-char] methods consume certain keyboard events (e.g., arrow keys, Enter) used @xmethod[dialog% on-subwindow-char] methods consume certain keyboard events (e.g., arrow keys, Enter) used
@ -382,9 +390,6 @@ BEWARE: The default
reach the ``receiver'' child unless the default frame or dialog reach the ``receiver'' child unless the default frame or dialog
method is overridden. method is overridden.
The @scheme[event] argument is the event that was generated for the
@scheme[receiver] window.
} }
@methimpl{ @methimpl{
@ -409,6 +414,13 @@ Called when this window or a child window receives a mouse event.
The @scheme[event] argument is the event that was generated for the The @scheme[event] argument is the event that was generated for the
@scheme[receiver] window. @scheme[receiver] window.
If the @method[window<%> on-subwindow-event] method chain does not complete
atomically (i.e., without requiring other threads to run) or does not complete
fast enough, then the corresponding event may not be delivered to a target
control, such as a button. In other words, an insufficiently cooperative
@method[window<%> on-subwindow-event] method can effectively disable a
control's handling of mouse events, even when it returns @racket[#f].
} }
@methimpl{ @methimpl{

20
collects/scribblings/gui/wxme.scrbl
View File

@ -3,6 +3,7 @@
(for-label wxme (for-label wxme
wxme/editor wxme/editor
wxme/image wxme/image
racket/snip
(except-in wxme/comment reader) (except-in wxme/comment reader)
(except-in wxme/xml reader) (except-in wxme/xml reader)
(except-in wxme/scheme reader) (except-in wxme/scheme reader)
@ -302,7 +303,7 @@ Several compatibility mappings are installed automatically for the
@racketmodname[wxme] library. They correspond to popular graphical @racketmodname[wxme] library. They correspond to popular graphical
elements supported by various versions of DrRacket, including comment elements supported by various versions of DrRacket, including comment
boxes, fractions, XML boxes, Racket boxes, text boxes, and images boxes, fractions, XML boxes, Racket boxes, text boxes, and images
generated by the ``world'' and ``image'' teachpacks (or, more generated by the @racketmodname[htdp/image] teachpack (or, more
generally, from @racketmodname[mrlib/cache-image-snip]), and test-case generally, from @racketmodname[mrlib/cache-image-snip]), and test-case
boxes. boxes.
@ -323,7 +324,8 @@ special-comment content is the readable instance. XML, Racket, and
text boxes similarly produce instances of @racket[editor%] and text boxes similarly produce instances of @racket[editor%] and
@racket[readable<%>] that expand in the usual way; see @racket[readable<%>] that expand in the usual way; see
@racketmodname[wxme/xml], @racketmodname[wxme/scheme], and @racketmodname[wxme/xml], @racketmodname[wxme/scheme], and
@racket[wxme/text]. Images from the ``world'' and ``image'' teachpacks @racket[wxme/text]. Images from the
@racketmodname[htdp/image] teachpack
are packaged as instances of @racket[cache-image%] from the are packaged as instances of @racket[cache-image%] from the
@racketmodname[wxme/cache-image] library. Test-case boxes are packaged @racketmodname[wxme/cache-image] library. Test-case boxes are packaged
as instances of @racket[test-case%] from the as instances of @racket[test-case%] from the
@ -353,14 +355,14 @@ editor's content.}
@defmodule[wxme/image] @defmodule[wxme/image]
@defclass[image% object% ()]{ @defclass[image% image-snip% ()]{
Instantiated for images in a @tech{WXME} stream in text mode. Instantiated for images in a @tech{WXME} stream in text mode.
This class can just be treated like @racket[image-snip%] and should
@defmethod[(get-filename) (or/c bytes? false/c)]{ behave just like it, except it has the methods below in addition
in case old code still needs them. In other words, the methods
Returns a filename as bytes, or @racket[#f] if data is available below are provided for backwards compatibility with earlier
instead.} verisons of Racket.
@defmethod[(get-data) (or/c bytes? false/c)]{ @defmethod[(get-data) (or/c bytes? false/c)]{
@ -543,7 +545,7 @@ rational numbers.}]
@defthing[reader (is-a?/c snip-reader<%>)]{ @defthing[reader (is-a?/c snip-reader<%>)]{
A text-mode reader for images in a WXME stream generated by the A text-mode reader for images in a WXME stream generated by the
``image'' and ``world'' teachpacks---or, more generally, by @racketmodname[htdp/image] teachpack---or, more generally, by
@racketmodname[mrlib/cache-image-snip].}] @racketmodname[mrlib/cache-image-snip].}]

4
collects/tests/framework/README
View File

@ -1,7 +1,7 @@
(#| (#|
Framework Test Suite Overview Framework Test Suite Overview
Each test will rely on the sucessfully completion of all of the ones Each test will rely on the successfully completion of all of the ones
before it. In addition, all test suites rely on the sucessful before it. In addition, all test suites rely on the sucessful
completion of the engine test suites and the mzscheme test suites. completion of the engine test suites and the mzscheme test suites.
@ -29,7 +29,7 @@ signal failures when there aren't any.
- load: |# load.rkt #| - load: |# load.rkt #|
| This tests that the advertised ways of loading the framework at | This tests that the advertised ways of loading the framework at
| it's components all work. | its components all work.
- exit: |# exit.rkt #| - exit: |# exit.rkt #|

14
collects/tests/framework/main.rkt
View File

@ -58,12 +58,12 @@
`("Names of the tests; defaults to all non-interactive tests")) `("Names of the tests; defaults to all non-interactive tests"))
(when (file-exists? preferences-file) (when (file-exists? preferences-file)
(debug-printf admin " saving preferences file ~s\n" preferences-file) (debug-printf admin " saving prefs file ~a\n" preferences-file)
(debug-printf admin " to ~s\n" old-preferences-file) (debug-printf admin " to ~a\n" old-preferences-file)
(if (file-exists? old-preferences-file) (if (file-exists? old-preferences-file)
(debug-printf admin " backup preferences file exists, using that one\n") (debug-printf admin " backup prefs file exists, using that one\n")
(begin (copy-file preferences-file old-preferences-file) (begin (copy-file preferences-file old-preferences-file)
(debug-printf admin " saved preferences file\n")))) (debug-printf admin " saved prefs file\n"))))
(define jumped-out-tests '()) (define jumped-out-tests '())
@ -96,12 +96,12 @@
(debug-printf schedule "ran ~a test~a\n" number-of-tests (if (= 1 number-of-tests) "" "s")) (debug-printf schedule "ran ~a test~a\n" number-of-tests (if (= 1 number-of-tests) "" "s"))
(when (file-exists? old-preferences-file) (when (file-exists? old-preferences-file)
(debug-printf admin " restoring preferences file ~s\n" old-preferences-file) (debug-printf admin " restoring prefs file ~a\n" old-preferences-file)
(debug-printf admin " to ~s\n" preferences-file) (debug-printf admin " to ~a\n" preferences-file)
(delete-file preferences-file) (delete-file preferences-file)
(copy-file old-preferences-file preferences-file) (copy-file old-preferences-file preferences-file)
(delete-file old-preferences-file) (delete-file old-preferences-file)
(debug-printf admin " restored preferences file\n")) (debug-printf admin " restored prefs file\n"))
(shutdown-listener) (shutdown-listener)

7
collects/tests/framework/test-suite-utils.rkt
View File

@ -144,8 +144,11 @@
(send-sexp-to-mred (send-sexp-to-mred
`(let ([thunk (lambda () ,sexp)] ;; low tech hygiene `(let ([thunk (lambda () ,sexp)] ;; low tech hygiene
[c (make-channel)]) [c (make-channel)])
(queue-callback (lambda () (channel-put c (thunk)))) (queue-callback (lambda () (channel-put c (with-handlers ((exn:fail? (λ (x) (list 'exn x)))) (list 'normal (thunk))))))
(channel-get c))))) (let ([res (channel-get c)])
(if (eq? (list-ref res 0) 'normal)
(list-ref res 1)
(raise (list-ref res 1))))))))
(define re:tcp-read-error (regexp "tcp-read:")) (define re:tcp-read-error (regexp "tcp-read:"))
(define re:tcp-write-error (regexp "tcp-write:")) (define re:tcp-write-error (regexp "tcp-write:"))

142
collects/tests/framework/text.rkt
View File

@ -196,3 +196,145 @@
(send dc clear) (send dc clear)
(send t print-to-dc dc 1) (send t print-to-dc dc 1)
'no-error)))) 'no-error))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; text:ports
;;
;; there is an internal buffer of this size, so writes that are larger and smaller are interesting
(define buffer-size 4096)
(let ([big-str (build-string (* buffer-size 2) (λ (i) (integer->char (+ (modulo i 26) (char->integer #\a)))))]
[non-ascii-str "λαβ一二三四五"])
(define (do/separate-thread str mtd)
(queue-sexp-to-mred
`(let* ([t (new (text:ports-mixin text:wide-snip%))]
[op (send t ,mtd)]
[exn #f])
(yield
(thread
(λ ()
(with-handlers ((exn:fail? (λ (x) (set! exn x))))
(display ,str op)
(flush-output op)))))
(when exn (raise exn))
(send t get-text 0 (send t last-position)))))
(test
'text:ports%.1
(λ (x) (equal? x "abc"))
(λ () (do/separate-thread "abc" 'get-out-port)))
(test
'text:ports%.2
(λ (x) (equal? x big-str))
(λ () (do/separate-thread big-str 'get-out-port)))
(test
'text:ports%.3
(λ (x) (equal? x non-ascii-str))
(λ () (do/separate-thread non-ascii-str 'get-out-port)))
(test
'text:ports%.4
(λ (x) (equal? x "abc"))
(λ () (do/separate-thread "abc" 'get-err-port)))
(test
'text:ports%.5
(λ (x) (equal? x big-str))
(λ () (do/separate-thread big-str 'get-err-port)))
(test
'text:ports%.6
(λ (x) (equal? x non-ascii-str))
(λ () (do/separate-thread non-ascii-str 'get-err-port)))
(test
'text:ports%.7
(λ (x) (equal? x "abc"))
(λ () (do/separate-thread "abc" 'get-value-port)))
(test
'text:ports%.8
(λ (x) (equal? x big-str))
(λ () (do/separate-thread big-str 'get-value-port)))
(test
'text:ports%.9
(λ (x) (equal? x non-ascii-str))
(λ () (do/separate-thread non-ascii-str 'get-value-port)))
;; display the big string, one char at a time
(test
'text:ports%.10
(λ (x) (equal? x big-str))
(λ ()
(queue-sexp-to-mred
`(let* ([t (new (text:ports-mixin text:wide-snip%))]
[op (send t get-out-port)]
[big-str ,big-str]
[exn #f])
(yield
(thread
(λ ()
(with-handlers ((exn:fail? (λ (x) (set! exn x))))
(let loop ([i 0])
(when (< i (string-length big-str))
(display (string-ref big-str i) op)
(loop (+ i 1))))
(flush-output op)))))
(when exn (raise exn))
(send t get-text 0 (send t last-position))))))
;; the next tests test the interaction when the current
;; thread is the same as the handler thread of the eventspace
;; where the text was created
(test
'text:ports%.thd1
(λ (x) (equal? x "abc"))
(λ ()
(queue-sexp-to-mred
`(let* ([t (new (text:ports-mixin text:wide-snip%))]
[op (send t get-out-port)]
[exn #f])
(display "abc" op)
(flush-output op)
(send t get-text 0 (send t last-position))))))
(test
'text:ports%.thd2
(λ (x) (equal? x big-str))
(λ ()
(queue-sexp-to-mred
`(let* ([t (new (text:ports-mixin text:wide-snip%))]
[op (send t get-out-port)])
(display ,big-str op)
(flush-output op)
(send t get-text 0 (send t last-position))))))
(test
'text:ports%.thd3
(λ (x) (equal? x non-ascii-str))
(λ ()
(queue-sexp-to-mred
`(let* ([t (new (text:ports-mixin text:wide-snip%))]
[op (send t get-out-port)])
(display ,non-ascii-str op)
(flush-output op)
(send t get-text 0 (send t last-position))))))
(test
'text:ports%.thd4
(λ (x) (equal? x non-ascii-str))
(λ ()
(queue-sexp-to-mred
`(let* ([t (new (text:ports-mixin text:wide-snip%))]
[op (send t get-out-port)])
(display ,non-ascii-str op)
(flush-output op)
(send t get-text 0 (send t last-position)))))))

142
collects/tests/gracket/image-snip-unmarshalling.rkt Normal file
View File

@ -0,0 +1,142 @@
#lang racket/gui
(require wxme
wxme/image)
#|
This file tests the wxme image-snip reader against the normal
image-snip reader (ie image-snip-class%'s read method)
It creates a bunch of different image-snip% objects
(the try-perms and below functions)
and then feeds them thru both paths to get two new image snips
(in the beginning of test-wxme-image-snip-reader/proc)
and compares a bunch of properties of them
(the end of that function).
|#
(define-syntax (test-wxme-image-snip-reader stx)
(syntax-case stx ()
[(_ is)
(with-syntax ([line (syntax-line stx)])
#'(test-wxme-image-snip-reader/proc line is))]))
(define tests 0)
(define (test-wxme-image-snip-reader/proc line is)
(set! tests (+ tests 1))
(define t (new text%))
(send t insert is)
(define sp (open-output-string))
(void (send t save-port sp))
(define wp (wxme-port->port (open-input-string (get-output-string sp))))
(define wxme-is (read-char-or-special wp))
(define t2 (new text%))
(send t2 insert-port (open-input-string (get-output-string sp)))
(define copy-is (send t2 find-first-snip))
(define (warn . args)
(fprintf (current-error-port)
(string-append (format "FAILED test-wxme-image-snip-reader.rkt line ~a: " line)
(apply format args))))
(define-syntax-rule (cmp mtd) (cmp/proc (λ (x) (send x mtd)) 'mtd))
(define (cmp/proc call-mtd mtd)
(let ([is-ans (call-mtd is)]
[wxme-is-ans (call-mtd wxme-is)]
[copy-is-ans (call-mtd copy-is)])
(unless (same? copy-is-ans wxme-is-ans)
(warn "~a returned different results; copy-is: ~s wxme-is: ~s\n"
mtd
copy-is-ans
wxme-is-ans))
#;
(unless (same? is-ans copy-is-ans)
(warn "~a returned different results; is: ~s copy-is: ~s\n"
mtd
is-ans
copy-is-ans))))
(when (is-a? is image%)
(warn "the input image-snip% is an image%\n"))
(unless (is-a? wxme-is image%)
(warn "new image snip is not an image%\n"))
(cmp get-filename)
(cmp get-filetype)
(cmp get-bitmap)
(cmp get-bitmap-mask))
(define (same? x y)
(cond
[(and (is-a? x bitmap%)
(is-a? y bitmap%))
(and (= (send x get-width)
(send y get-width))
(= (send x get-height)
(send y get-height))
(= (send x get-depth)
(send y get-depth))
(check? (bitmap->bytes x #f)
(bitmap->bytes y #f)
'bitmap/#f)
(check? (bitmap->bytes x #t)
(bitmap->bytes y #t)
'bitmap/#t))]
[else (equal? x y)]))
(define (check? a b what)
(cond
[(equal? a b) #t]
[else
;(fprintf (current-error-port) "checking ~s, doesn't match\n~s\nvs\n~s\n\n" what a b)
#f]))
(define (bitmap->bytes bmp alpha?)
(define w (send bmp get-width))
(define h (send bmp get-height))
(define bytes (make-bytes (* 4 w h) 0))
(send bmp get-argb-pixels 0 0 w h bytes alpha?)
bytes)
(define (try-perms files kinds relative-path?s inline?s)
(for* ([file (in-list files)]
[kind (in-list kinds)]
[relative-path? (in-list relative-path?s)]
[inline? (in-list inline?s)])
(test-wxme-image-snip-reader (make-object image-snip% file kind relative-path? inline?))))
(try-perms (list (collection-file-path "b-run.png" "icons"))
'(unknown unknown/mask unknown/alpha
png png/mask png/alpha)
'(#f)
'(#f #t))
(parameterize ([current-directory (collection-path "icons")])
(try-perms (list "b-run.png")
'(unknown unknown/mask unknown/alpha
png png/mask png/alpha)
'(#f)
'(#f #t)))
(define (draw-circle bm)
(define bdc (make-object bitmap-dc% bm))
(send bdc set-smoothing 'smoothed)
(send bdc set-brush "red" 'solid)
(send bdc draw-ellipse 1 1 8 8)
(send bdc set-bitmap #f))
(let ([bm (make-bitmap 10 10 #f)])
(draw-circle bm)
(test-wxme-image-snip-reader (make-object image-snip% bm))
(test-wxme-image-snip-reader (make-object image-snip% bm #f))
(test-wxme-image-snip-reader (make-object image-snip% bm bm)))
(let ([bm (make-bitmap 10 10)])
(draw-circle bm)
(test-wxme-image-snip-reader (make-object image-snip% bm)))
(printf "ran ~a tests\n" tests)

19
collects/tests/gracket/wxme.rkt
View File

@ -1347,4 +1347,23 @@
;; ---------------------------------------- ;; ----------------------------------------
(let ()
(define (mk) (make-object image-snip% (collection-file-path "b-run.png" "icons") 'unknown #f #f))
(define is (mk))
(define copy-is
(let ()
(define sp (open-output-string))
(define t (new text%))
(send t insert (mk))
(send t save-port sp)
(define t2 (new text%))
(send t2 insert-port (open-input-string (get-output-string sp)))
(send t2 find-first-snip)))
(expect (send (mk) get-filename)
(send copy-is get-filename)))
;; ----------------------------------------
(done) (done)

6
doc/release-notes/gracket/HISTORY.txt
View File

@ -373,7 +373,7 @@ Version 206p1, February 2004
Fixed printing scale for Windows NT/2000/XP Fixed printing scale for Windows NT/2000/XP
Version 206, Janurary 2004 Version 206, January 2004
Drawing: Drawing:
Changed get-argb-pixels and set-argb-pixels to row-major order: Changed get-argb-pixels and set-argb-pixels to row-major order:
@ -1285,7 +1285,7 @@ System:
Changed force-redraw to ignore refresh requests when the Changed force-redraw to ignore refresh requests when the
redraw-requesting window is not shown. Redraw requests are now redraw-requesting window is not shown. Redraw requests are now
propogated to the top-level frame or dialog via child-redraw-request. propagated to the top-level frame or dialog via child-redraw-request.
- if your application is unititized, then you need to change the - if your application is unititized, then you need to change the
startup procedure. See the application startup section in the startup procedure. See the application startup section in the
toolbox manual. toolbox manual.
@ -1655,7 +1655,7 @@ Bug fixes, especially Motif and memory bugs
Rewrote editor line-maintenance Rewrote editor line-maintenance
Faster caret updating Faster caret updating
Upgraded garbage collector Upgraded garbage collector
File format changed to accomodate nested buffers with File format changed to accommodate nested buffers with
separate style lists separate style lists
Standard system standardized Standard system standardized
Code changes for compiling on MSWindows (almost works...) Code changes for compiling on MSWindows (almost works...)

4
doc/release-notes/gracket/MrEd_100_Framework.txt
View File

@ -115,7 +115,7 @@ The moved functions and classes are:
mred:graph-pasteboard% mred:graph-pasteboard%
mred:node-snip% mred:node-snip%
The remaining existant classes: The remaining existent classes:
frame:empty% = (frame:make-empty% frame%) frame:empty% = (frame:make-empty% frame%)
frame:standard-menus% = (frame:make-standard-menus% frame:empty%) frame:standard-menus% = (frame:make-standard-menus% frame:empty%)
@ -294,4 +294,4 @@ NOTE: some used but non-existant interfaces from mred engine:
snip:make-basic-style% : snip<%> -> snip<%> snip:make-basic-style% : snip<%> -> snip<%>
scheme:make-text% : text:basic<%> -> scheme:text<%> scheme:make-text% : text:basic<%> -> scheme:text<%>

28
doc/release-notes/racket/Draw_and_GUI_5_1.txt
View File

@ -17,7 +17,7 @@ API:
Racket. Racket.
The GRacket executable still offers some additional GUI-specific The GRacket executable still offers some additional GUI-specific
functiontality however. Most notably, GRacket is a GUI application functionality however. Most notably, GRacket is a GUI application
under Windows (as opposed to a console application, which is under Windows (as opposed to a console application, which is
launched slightly differently by the OS), GRacket is a bundle under launched slightly differently by the OS), GRacket is a bundle under
Mac OS X (so the dock icon is the Racket logo, for example), and Mac OS X (so the dock icon is the Racket logo, for example), and
@ -91,8 +91,8 @@ The old translation and scaling transformations apply after the
initial matrix. The new rotation transformation applies after the initial matrix. The new rotation transformation applies after the
other transformations. This layering is redundant, since all other transformations. This layering is redundant, since all
transformations can be expressed in a single matrix, but it is transformations can be expressed in a single matrix, but it is
backward-compatibile. Methods like `get-translation', backward-compatible. Methods like `get-translation',
`set-translation', `scale', etc. help hide the reundancy. `set-translation', `scale', etc. help hide the redundancy.
PostScript, PDF, and SVG Drawing Contexts PostScript, PDF, and SVG Drawing Contexts
@ -150,18 +150,32 @@ into the control.
Event callbacks are delimited by a continuation prompt using the Event callbacks are delimited by a continuation prompt using the
default continuation prompt tag. As a result, continuations can be default continuation prompt tag. As a result, continuations can be
usufully captured during one event callback and applied during other usefully captured during one event callback and applied during other
callbacks or outside of an even callback. The continuation barrier and callbacks or outside of an even callback. The continuation barrier and
jump-defeating `dynamic-wind' that formerly guarded callbacks has been jump-defeating `dynamic-wind' that formerly guarded callbacks has been
removed. removed.
The `on-subwindow-char' and `on-subwindow-event' methods for controls
are somewhat more restricted in the actions they can take without
disabling the control's handling of key and mouse events. See the
documentation for more information.
Registry Functions
-----------------
The `get-resource' and `write-resource' functions have moved to a
`file/resource' library that is re-exported by `racket/gui/base'.
These function now work only for reading and writing the Windows
registry or ".ini" files; they report failure for other platforms.
Removed Functions Removed Functions
----------------- -----------------
The `write-resource, `get-reource', and `send-event' functions have The `send-event' function has been removed from `racket/gui/base'. If
been removed from `racket/gui/base'. If there is any demand for the there is any demand for the removed functionality, it will be
removed functionality, it will be implemented in a new library. implemented in a new library.
The `current-ps-afm-file-paths' and `current-ps-cmap-file-paths' The `current-ps-afm-file-paths' and `current-ps-cmap-file-paths'
functions have been removed, because they no longer apply. PostScript functions have been removed, because they no longer apply. PostScript