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

adjust text.rkt test suite to not use racy old way of doing things

Browse Source
This commit is contained in:
Robby Findler 2017-01-14 20:33:32 -06:00
parent 8396854c1a
commit 6b2ff36cc9
2 changed files with 521 additions and 637 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
gui-test/framework/tests/README
View File

@ -50,7 +50,7 @@ signal failures when there aren't any.
- frames: frame.rkt -- now runs directly via raco test. - frames: frame.rkt -- now runs directly via raco test.
- canvases: canvas.rkt -- now runs directly via raco test. - canvases: canvas.rkt -- now runs directly via raco test.
- texts: |# text.rkt #| - texts: text.rkt -- now runs directly via raco test.
- pasteboards: |# pasteboard.rkt #| - pasteboards: |# pasteboard.rkt #|
- keybindings: |# keys.rkt #| - keybindings: |# keys.rkt #|

576
gui-test/framework/tests/text.rkt
View File

@ -1,12 +1,10 @@
#lang racket/base #lang racket
(require racket/file (require "private/here-util.rkt"
"test-suite-utils.rkt") "private/gui.rkt"
rackunit
(module test racket/base) racket/gui/base
framework)
(define dummy-frame-title "dummy to avoid quitting")
(queue-sexp-to-mred `(send (make-object frame:basic% ,dummy-frame-title) show #t))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;;
@ -15,119 +13,89 @@
(test (check-equal?
'highlight-range1 (let ([t (new text:basic%)])
(lambda (x) (equal? x 1))
(λ ()
(queue-sexp-to-mred
`(let ([t (new text:basic%)])
(send t insert "abc") (send t insert "abc")
(send t highlight-range 1 2 "red") (send t highlight-range 1 2 "red")
(length (send t get-highlighted-ranges)))))) (length (send t get-highlighted-ranges)))
1)
(test (check-equal?
'highlight-range2 (let ([t (new text:basic%)])
(lambda (x) (equal? x 0))
(λ ()
(queue-sexp-to-mred
`(let ([t (new text:basic%)])
(send t insert "abc") (send t insert "abc")
((send t highlight-range 1 2 "red")) ((send t highlight-range 1 2 "red"))
(length (send t get-highlighted-ranges)))))) (length (send t get-highlighted-ranges)))
0)
(check-equal?
(test (let ([t (new text:basic%)])
'highlight-range3
(lambda (x) (equal? x 0))
(λ ()
(queue-sexp-to-mred
`(let ([t (new text:basic%)])
(send t insert "abc") (send t insert "abc")
(send t highlight-range 1 2 "red") (send t highlight-range 1 2 "red")
(send t unhighlight-range 1 2 "red") (send t unhighlight-range 1 2 "red")
(length (send t get-highlighted-ranges)))))) (length (send t get-highlighted-ranges)))
0)
(test (check-equal?
'highlight-range4 (let ([t (new text:basic%)])
(lambda (x) (equal? x 1))
(λ ()
(queue-sexp-to-mred
`(let ([t (new text:basic%)])
(send t insert "abc") (send t insert "abc")
(send t highlight-range 1 2 "red") (send t highlight-range 1 2 "red")
(send t highlight-range 1 2 "red") (send t highlight-range 1 2 "red")
(send t unhighlight-range 1 2 "red") (send t unhighlight-range 1 2 "red")
(length (send t get-highlighted-ranges)))))) (length (send t get-highlighted-ranges)))
1)
(check-equal?
(let ([t (new text:basic%)])
(test
'highlight-range5
(lambda (x) (equal? x 0))
(λ ()
(queue-sexp-to-mred
`(let ([t (new text:basic%)])
(send t insert "abc") (send t insert "abc")
(send t highlight-range 1 2 "red") (send t highlight-range 1 2 "red")
(send t highlight-range 1 2 "red") (send t highlight-range 1 2 "red")
(send t unhighlight-range 1 2 "red") (send t unhighlight-range 1 2 "red")
(send t unhighlight-range 1 2 "red") (send t unhighlight-range 1 2 "red")
(length (send t get-highlighted-ranges)))))) (length (send t get-highlighted-ranges)))
0)
(let ([tmp-file (path->string (make-temporary-file "fwtesttmp~a"))]) (let ([tmp-file (path->string (make-temporary-file "fwtesttmp~a"))])
(test (dynamic-wind
'highlight-range/revert void
(lambda (x)
(delete-file tmp-file)
(equal? x 0))
(λ () (λ ()
(queue-sexp-to-mred (check-equal?
`(let ([t (new text:basic%)]) (let ([t (new text:basic%)])
(send t insert "abc") (send t insert "abc")
(send t save-file ,tmp-file) (send t save-file tmp-file)
(send t highlight-range 0 3 "red") (send t highlight-range 0 3 "red")
(call-with-output-file ,tmp-file (call-with-output-file tmp-file
(lambda (port) (display "x\n" port)) (λ (port) (display "x\n" port))
#:exists 'truncate) #:exists 'truncate)
(send t load-file) (send t load-file)
(length (send t get-highlighted-ranges))))))) (length (send t get-highlighted-ranges)))
0))
(λ () (delete-file tmp-file))))
(test (check-equal?
'highlight-range-delegate-1 (let ([t (new text:delegate%)])
(lambda (x) (equal? x 0))
(λ ()
(queue-sexp-to-mred
`(let ([t (new text:delegate%)])
(send t insert "abc") (send t insert "abc")
(send t highlight-range 1 2 "red") (send t highlight-range 1 2 "red")
(send t unhighlight-range 1 2 "red") (send t unhighlight-range 1 2 "red")
(length (send t get-highlighted-ranges)))))) (length (send t get-highlighted-ranges)))
0)
(test (check-equal?
'highlight-range-delegate-1 (let ([t (new text:delegate%)])
(lambda (x) (equal? x 0))
(λ ()
(queue-sexp-to-mred
`(let ([t (new text:delegate%)])
(send t set-delegate (new text:basic%)) (send t set-delegate (new text:basic%))
(send t insert "abc") (send t insert "abc")
(send t highlight-range 1 2 "red") (send t highlight-range 1 2 "red")
(send t unhighlight-range 1 2 "red") (send t unhighlight-range 1 2 "red")
(length (send t get-highlighted-ranges)))))) (length (send t get-highlighted-ranges)))
0)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;;
;; testing get-pos/text method ;; testing get-pos/text method
;; ;;
(test (check-true
'get-pos/text-1 (let* ([f (new frame% [label "Test frame"])]
(λ (x) x)
(λ ()
(queue-sexp-to-mred
'(let* ([f (new frame% [label "Test frame"])]
[t (new text:basic%)] [t (new text:basic%)]
[c (new editor-canvas% [parent f] [editor t])] [c (new editor-canvas% [parent f] [editor t])]
[snip (make-object string-snip% "Test string")]) [snip (make-object string-snip% "Test string")])
@ -139,14 +107,10 @@
[x (add1 (unbox x-box))] [x (add1 (unbox x-box))]
[y (add1 (unbox y-box))])) [y (add1 (unbox y-box))]))
(let-values ([(pos edit) (send t get-pos/text event)]) (let-values ([(pos edit) (send t get-pos/text event)])
(and (real? (car p)) (is-a? (cdr p) text%))))))) (and (real? pos) (is-a? edit text%)))))
(test (check-true
'get-pos/text-2 (let* ([f (new frame% [label "Test frame"])]
(λ (x) x)
(λ ()
(queue-sexp-to-mred
'(let* ([f (new frame% [label "Test frame"])]
[t (new text:basic%)] [t (new text:basic%)]
[c (new editor-canvas% [parent f] [editor t])] [c (new editor-canvas% [parent f] [editor t])]
[snip (make-object string-snip% "Test string")]) [snip (make-object string-snip% "Test string")])
@ -158,14 +122,10 @@
[x (+ 9999 (unbox x-box))] [x (+ 9999 (unbox x-box))]
[y (+ 9999 (unbox y-box))])) [y (+ 9999 (unbox y-box))]))
(let-values ([(pos edit) (send t get-pos/text event)]) (let-values ([(pos edit) (send t get-pos/text event)])
(and (false? pos) (false? edit))))))) (and (false? pos) (false? edit)))))
(test (check-true
'get-pos/text-3 (let* ([f (new frame% [label "Test frame"])]
(λ (x) x)
(λ ()
(queue-sexp-to-mred
'(let* ([f (new frame% [label "Test frame"])]
[t (new text:basic%)] [t (new text:basic%)]
[c (new editor-canvas% [parent f] [editor t])] [c (new editor-canvas% [parent f] [editor t])]
[p (new pasteboard%)] [p (new pasteboard%)]
@ -180,7 +140,7 @@
[x (add1 (unbox x-box))] [x (add1 (unbox x-box))]
[y (add1 (unbox y-box))])) [y (add1 (unbox y-box))]))
(let-values ([(pos edit) (send t get-pos/text event)]) (let-values ([(pos edit) (send t get-pos/text event)])
(and (false? pos) (is-a? edit pasteboard%))))))) (and (false? pos) (is-a? edit pasteboard%)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -188,169 +148,133 @@
;; all-string-snips<%> ;; all-string-snips<%>
;; ;;
(test (check-true
'all-string-snips<%>.1 (let ()
(λ (x) (equal? x #t))
(λ ()
(queue-sexp-to-mred
'(let ()
(define t (new (text:all-string-snips-mixin text%))) (define t (new (text:all-string-snips-mixin text%)))
(send t all-string-snips?))))) (send t all-string-snips?)))
(test (check-true
'all-string-snips<%>.2 (let ()
(λ (x) (equal? x #t))
(λ ()
(queue-sexp-to-mred
'(let ()
(define t (new (text:all-string-snips-mixin text%))) (define t (new (text:all-string-snips-mixin text%)))
(send t insert "xx") (send t insert "xx")
(send t all-string-snips?))))) (send t all-string-snips?)))
(test (check-true
'all-string-snips<%>.3 (let ()
(λ (x) (equal? x #t))
(λ ()
(queue-sexp-to-mred
'(let ()
(define t (new (text:all-string-snips-mixin text%))) (define t (new (text:all-string-snips-mixin text%)))
(send t insert "xx") (send t insert "xx")
(send t delete 0 1) (send t delete 0 1)
(send t all-string-snips?))))) (send t all-string-snips?)))
(test (check-true
'all-string-snips<%>.4 (let ()
(λ (x) (equal? x #t))
(λ ()
(queue-sexp-to-mred
'(let ()
(define t (new (text:all-string-snips-mixin text%))) (define t (new (text:all-string-snips-mixin text%)))
(send t insert "xx") (send t insert "xx")
(send t delete 0 2) (send t delete 0 2)
(send t all-string-snips?))))) (send t all-string-snips?)))
(test (check-false
'all-string-snips<%>.5 (let ()
(λ (x) (equal? x #f))
(λ ()
(queue-sexp-to-mred
'(let ()
(define t (new (text:all-string-snips-mixin text%))) (define t (new (text:all-string-snips-mixin text%)))
(send t insert (new snip%)) (send t insert (new snip%))
(send t all-string-snips?))))) (send t all-string-snips?)))
(test (check-true
'all-string-snips<%>.6 (let ()
(λ (x) (equal? x #t))
(λ ()
(queue-sexp-to-mred
'(let ()
(define t (new (text:all-string-snips-mixin text%))) (define t (new (text:all-string-snips-mixin text%)))
(send t insert (new snip%)) (send t insert (new snip%))
(send t delete 0 1) (send t delete 0 1)
(send t all-string-snips?))))) (send t all-string-snips?)))
(test (check-false
'all-string-snips<%>.7 (let ()
(λ (x) (equal? x #f))
(λ ()
(queue-sexp-to-mred
'(let ()
(define t (new (text:all-string-snips-mixin text%))) (define t (new (text:all-string-snips-mixin text%)))
(send t insert (new snip%)) (send t insert (new snip%))
(send t insert (new snip%)) (send t insert (new snip%))
(send t delete 0 1) (send t delete 0 1)
(send t all-string-snips?))))) (send t all-string-snips?)))
(test (check-false
'all-string-snips<%>.8 (let ()
(λ (x) (equal? x #f))
(λ ()
(queue-sexp-to-mred
'(let ()
(define t (new (text:all-string-snips-mixin text%))) (define t (new (text:all-string-snips-mixin text%)))
(send t insert (new snip%)) (send t insert (new snip%))
(send t insert "abcdef") (send t insert "abcdef")
(send t insert (new snip%)) (send t insert (new snip%))
(send t delete 2 4) (send t delete 2 4)
(send t all-string-snips?))))) (send t all-string-snips?)))
(test (check-false
'all-string-snips<%>.9 (let ()
(λ (x) (equal? x #f))
(λ ()
(queue-sexp-to-mred
'(let ()
(define t (new (text:all-string-snips-mixin text%))) (define t (new (text:all-string-snips-mixin text%)))
(send t insert "abcdef\n") (send t insert "abcdef\n")
(send t insert (new snip%) (send t last-position)) (send t insert (new snip%) (send t last-position))
(send t all-string-snips?))))) (send t all-string-snips?)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;;
;; searching ;; searching
;; ;;
(define (search-test name setup-code expected-answer) (define (run-search-test setup-code)
(test
name
(λ (x) (equal? x expected-answer))
(λ ()
(send-sexp-to-mred/separate-thread
`(let ()
(define answer (make-channel)) (define answer (make-channel))
(parameterize ([current-eventspace (make-eventspace)])
(queue-callback (queue-callback
(λ () (λ ()
(define t (new text:searching%)) (define t (new text:searching%))
,setup-code (setup-code t)
(let loop () (let loop ()
(cond (cond
[(send t search-updates-pending?) [(send t search-updates-pending?)
(queue-callback (λ () (loop)) #f)] (queue-callback (λ () (loop)) #f)]
[else [else
(define-values (before total) (send t get-search-hit-count)) (define-values (before total) (send t get-search-hit-count))
(channel-put answer (list before total))])))) (channel-put answer (list before total))])))))
(channel-get answer)))))) (channel-get answer))
(search-test (check-equal?
'search.1 (run-search-test
`(begin (send t insert "abc") (λ (t)
(send t insert "abc")
(send t set-position 0 0) (send t set-position 0 0)
(send t set-searching-state "b" #f #f)) (send t set-searching-state "b" #f #f)))
(list 0 1)) (list 0 1))
(search-test (check-equal?
'search.2 (run-search-test
`(begin (send t insert "abc") (λ (t)
(send t insert "abc")
(send t set-position 3 3) (send t set-position 3 3)
(send t set-searching-state "b" #f #f)) (send t set-searching-state "b" #f #f)))
(list 1 1)) (list 1 1))
(search-test (check-equal?
'search.3 (run-search-test
`(begin (send t insert "abc") (λ (t)
(send t insert "abc")
(define t2 (new text%)) (define t2 (new text%))
(send t2 insert "abc") (send t2 insert "abc")
(send t insert (new editor-snip% [editor t2])) (send t insert (new editor-snip% [editor t2]))
(send t2 insert "abc") (send t2 insert "abc")
(send t set-position 0 0) (send t set-position 0 0)
(send t set-searching-state "b" #f #f)) (send t set-searching-state "b" #f #f)))
(list 0 3)) (list 0 3))
(search-test (check-equal?
'search.4 (run-search-test
`(begin (send t insert "abc") (λ (t)
(send t insert "abc")
(define t2 (new text%)) (define t2 (new text%))
(send t2 insert "abc") (send t2 insert "abc")
(send t insert (new editor-snip% [editor t2])) (send t insert (new editor-snip% [editor t2]))
(send t insert "abc") (send t insert "abc")
(send t set-position (send t last-position) (send t last-position)) (send t set-position (send t last-position) (send t last-position))
(send t set-searching-state "b" #f #f)) (send t set-searching-state "b" #f #f)))
(list 3 3)) (list 3 3))
(search-test (check-equal?
'search.5 (run-search-test
`(begin (send t insert "abc") (λ (t)
(send t insert "abc")
(define t2 (new text%)) (define t2 (new text%))
(send t2 insert "abc") (send t2 insert "abc")
(define t3 (new text%)) (define t3 (new text%))
@ -360,12 +284,13 @@
(send t insert (new editor-snip% [editor t2])) (send t insert (new editor-snip% [editor t2]))
(send t insert "abc") (send t insert "abc")
(send t set-position (send t last-position) (send t last-position)) (send t set-position (send t last-position) (send t last-position))
(send t set-searching-state "b" #f #f)) (send t set-searching-state "b" #f #f)))
(list 5 5)) (list 5 5))
(search-test (check-equal?
'search.6 (run-search-test
`(begin (send t insert "abc") (λ (t)
(send t insert "abc")
(define t2 (new text%)) (define t2 (new text%))
(send t2 insert "abc") (send t2 insert "abc")
(define t3 (new text%)) (define t3 (new text%))
@ -375,44 +300,38 @@
(send t insert (new editor-snip% [editor t2])) (send t insert (new editor-snip% [editor t2]))
(send t insert "abc") (send t insert "abc")
(send t set-position 0 0) (send t set-position 0 0)
(send t set-searching-state "b" #f #f)) (send t set-searching-state "b" #f #f)))
(list 0 5)) (list 0 5))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;;
;; print-to-dc ;; print-to-dc
;; ;;
(test (check-not-exn
'print-to-dc
(λ (x) (equal? x 'no-error))
(λ () (λ ()
(queue-sexp-to-mred (define t (new text:basic%))
'(let* ([t (new text:basic%)] (define bmp (make-object bitmap% 100 40))
[bmp (make-object bitmap% 100 40)] (define dc (new bitmap-dc% (bitmap bmp)))
[dc (new bitmap-dc% (bitmap bmp))])
(send t insert "Hello world") (send t insert "Hello world")
(send dc clear) (send dc clear)
(send t print-to-dc dc 1) (send t print-to-dc dc 1)))
'no-error))))
(test (check-not-exn
'print-to-dc2
(λ (x) (equal? x 'no-error))
(λ () (λ ()
(queue-sexp-to-mred (define f (new frame% [label ""]))
`(let* ([f (new frame% [label ""])] (define t (new text:basic%))
[t (new text:basic%)] (define ec (new editor-canvas% [parent f] [editor t]))
[ec (new editor-canvas% [parent f] [editor t])] (define bmp (make-object bitmap% 100 40))
[bmp (make-object bitmap% 100 40)] (define dc (new bitmap-dc% (bitmap bmp)))
[dc (new bitmap-dc% (bitmap bmp))])
(send t insert "Hello world") (send t insert "Hello world")
(send t highlight-range 2 5 "orange") (send t highlight-range 2 5 "orange")
(send f reflow-container) (send f reflow-container)
(send dc clear) (send dc clear)
(send t print-to-dc dc 1) (send t print-to-dc dc 1)))
'no-error))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;;
@ -426,75 +345,64 @@
(define big-str (define big-str
(build-string (* buffer-size 2) (λ (i) (integer->char (+ (modulo i 26) (char->integer #\a)))))) (build-string (* buffer-size 2) (λ (i) (integer->char (+ (modulo i 26) (char->integer #\a))))))
(define non-ascii-str "λαβ一二三四五") (define non-ascii-str "λαβ一二三四五")
(define (do/separate-thread str mtd) (define (do/separate-thread str mtd)
(queue-sexp-to-mred (let* ([t (new (text:ports-mixin text:wide-snip%))]
`(let* ([t (new (text:ports-mixin text:wide-snip%))] [op (case mtd
[op (send t ,mtd)] [(get-out-port) (send t get-out-port)]
[(get-err-port) (send t get-err-port)]
[(get-value-port) (send t get-value-port)])]
[exn #f]) [exn #f])
(yield (yield
(thread (thread
(λ () (λ ()
(with-handlers ((exn:fail? (λ (x) (set! exn x)))) (with-handlers ((exn:fail? (λ (x) (set! exn x))))
(display ,str op) (display str op)
(flush-output op))))) (flush-output op)))))
(when exn (raise exn)) (when exn (raise exn))
(send t get-text 0 (send t last-position))))) (send t get-text 0 (send t last-position))))
(test (check-equal?
'text:ports%.1 (do/separate-thread "abc" 'get-out-port)
(λ (x) (equal? x "abc")) "abc")
(λ () (do/separate-thread "abc" 'get-out-port)))
(test (check-equal?
'text:ports%.2 (do/separate-thread big-str 'get-out-port)
(λ (x) (equal? x big-str)) big-str)
(λ () (do/separate-thread big-str 'get-out-port)))
(test (check-equal?
'text:ports%.3 (do/separate-thread non-ascii-str 'get-out-port)
(λ (x) (equal? x non-ascii-str)) non-ascii-str)
(λ () (do/separate-thread non-ascii-str 'get-out-port)))
(test (check-equal?
'text:ports%.4 (do/separate-thread "abc" 'get-err-port)
(λ (x) (equal? x "abc")) "abc")
(λ () (do/separate-thread "abc" 'get-err-port)))
(test (check-equal?
'text:ports%.5 (do/separate-thread big-str 'get-err-port)
(λ (x) (equal? x big-str)) big-str)
(λ () (do/separate-thread big-str 'get-err-port)))
(test (check-equal?
'text:ports%.6 (do/separate-thread non-ascii-str 'get-err-port)
(λ (x) (equal? x non-ascii-str)) non-ascii-str)
(λ () (do/separate-thread non-ascii-str 'get-err-port)))
(check-equal?
(do/separate-thread "abc" 'get-value-port)
"abc")
(test (check-equal?
'text:ports%.7 (do/separate-thread big-str 'get-value-port)
(λ (x) (equal? x "abc")) big-str)
(λ () (do/separate-thread "abc" 'get-value-port)))
(test (check-equal?
'text:ports%.8 (do/separate-thread non-ascii-str 'get-value-port)
(λ (x) (equal? x big-str)) non-ascii-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 ;; display the big string, one char at a time
(test (check-equal?
'text:ports%.10 (let* ([t (new (text:ports-mixin text:wide-snip%))]
(λ (x) (equal? x big-str))
(λ ()
(queue-sexp-to-mred
`(let* ([t (new (text:ports-mixin text:wide-snip%))]
[op (send t get-out-port)] [op (send t get-out-port)]
[big-str ,big-str]
[exn #f]) [exn #f])
(yield (yield
(thread (thread
@ -506,108 +414,88 @@
(loop (+ i 1)))) (loop (+ i 1))))
(flush-output op))))) (flush-output op)))))
(when exn (raise exn)) (when exn (raise exn))
(send t get-text 0 (send t last-position)))))) (send t get-text 0 (send t last-position)))
big-str)
(let ([s "五"]) (let ([s "五"])
(test
'text:ports%.partial-encoding
(λ (x) (equal? x s))
(λ ()
(define bts (string->bytes/utf-8 s)) (define bts (string->bytes/utf-8 s))
(queue-sexp-to-mred (check-equal?
`(let () (let ()
(define t (new (text:ports-mixin text:wide-snip%))) (define t (new (text:ports-mixin text:wide-snip%)))
(define p (send t get-out-port)) (define p (send t get-out-port))
(void (write-bytes (bytes ,(bytes-ref bts 0)) p)) (write-bytes (bytes (bytes-ref bts 0)) p)
(flush-output p) (flush-output p)
(void (write-bytes ,(subbytes bts 1 (bytes-length bts)) p)) (void (write-bytes (subbytes bts 1 (bytes-length bts)) p))
(flush-output p) (flush-output p)
(send t get-text)))))) (send t get-text))
s))
(let ([b (bytes 195 195 (char->integer #\a))]) (let ([b (bytes 195 195 (char->integer #\a))])
(test (check-equal?
'text:ports%.broken-encoding (let ()
(λ (x)
(define c (bytes-open-converter "UTF-8-permissive" "UTF-8"))
(define-values (result-bytes src-read-amt termination) (bytes-convert c b))
(equal? x (bytes->string/utf-8 result-bytes)))
(λ ()
(queue-sexp-to-mred
`(let ()
(define t (new (text:ports-mixin text:wide-snip%))) (define t (new (text:ports-mixin text:wide-snip%)))
(define p (send t get-out-port)) (define p (send t get-out-port))
(yield (yield
(thread (thread
(λ () (λ ()
(write-bytes ,b p) (write-bytes b p)
(flush-output p)))) (flush-output p))))
(send t get-text)))))) (send t get-text))
(let ()
(define c (bytes-open-converter "UTF-8-permissive" "UTF-8"))
(define-values (result-bytes src-read-amt termination) (bytes-convert c b))
(bytes->string/utf-8 result-bytes))))
;; the next tests test the interaction when the current ;; the next tests test the interaction when the current
;; thread is the same as the handler thread of the eventspace ;; thread is the same as the handler thread of the eventspace
;; where the text was created ;; where the text was created
(test (check-equal?
'text:ports%.thd1 (let* ([t (new (text:ports-mixin text:wide-snip%))]
(λ (x) (equal? x "abc"))
(λ ()
(queue-sexp-to-mred
`(let* ([t (new (text:ports-mixin text:wide-snip%))]
[op (send t get-out-port)] [op (send t get-out-port)]
[exn #f]) [exn #f])
(display "abc" op) (display "abc" op)
(flush-output op) (flush-output op)
(send t get-text 0 (send t last-position)))))) (send t get-text 0 (send t last-position)))
"abc")
(test (check-equal?
'text:ports%.thd2 (let* ([t (new (text:ports-mixin text:wide-snip%))]
(λ (x) (equal? x big-str))
(λ ()
(queue-sexp-to-mred
`(let* ([t (new (text:ports-mixin text:wide-snip%))]
[op (send t get-out-port)]) [op (send t get-out-port)])
(display ,big-str op) (display big-str op)
(flush-output op) (flush-output op)
(send t get-text 0 (send t last-position)))))) (send t get-text 0 (send t last-position)))
big-str)
(test (check-equal?
'text:ports%.thd3 (let* ([t (new (text:ports-mixin text:wide-snip%))]
(λ (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)]) [op (send t get-out-port)])
(display ,non-ascii-str op) (display non-ascii-str op)
(flush-output op) (flush-output op)
(send t get-text 0 (send t last-position)))))) (send t get-text 0 (send t last-position)))
non-ascii-str)
(test (check-equal?
'text:ports%.thd4 (let* ([t (new (text:ports-mixin text:wide-snip%))]
(λ (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)]) [op (send t get-out-port)])
(display ,non-ascii-str op) (display non-ascii-str op)
(flush-output op) (flush-output op)
(send t get-text 0 (send t last-position)))))) (send t get-text 0 (send t last-position)))
non-ascii-str)
;; This test sends a lot of flushes from a separate thread and, ;; This test sends a lot of flushes from a separate thread and,
;; while doing that, sends a `clear-output-ports` from the ;; while doing that, sends a `clear-output-ports` from the
;; eventspace main thread where the text was created. The goal ;; eventspace main thread where the text was created. The goal
;; is to make sure there is no deadlock for this interaction. ;; is to make sure there is no deadlock for this interaction.
(test (check-pred
'text:ports%.flush-and-clear-output-ports-interaction
(λ (x) (λ (x)
;; we know we're going to get all 'a's, but some of ;; we know we're going to get all 'a's, but some of
;; the output could be discarded by `clear-output-ports` ;; the output could be discarded by `clear-output-ports`
(and (regexp-match #rx"^a*$" x) (and (regexp-match? #rx"^a*$" x)
(<= 100 (string-length x) 200))) (<= 100 (string-length x) 200)))
(λ () (let ()
(queue-sexp-to-mred
`(let ()
(define es (make-eventspace)) (define es (make-eventspace))
(define-values (text port) (define-values (text port)
(let () (let ()
@ -642,16 +530,13 @@
(display #\a port) (display #\a port)
(flush-output port)) (flush-output port))
(semaphore-wait clear-output-done) (semaphore-wait clear-output-done)
(send text get-text)))))) (send text get-text))))
(test (check-pred
'text:ports%.undo-does-not-remove-port-colors
(λ (x+y) (λ (x+y)
(equal? (list-ref x+y 0) (equal? (list-ref x+y 0)
(list-ref x+y 1))) (list-ref x+y 1)))
(λ () (let ()
(queue-sexp-to-mred
`(let ()
(define t (new (text:ports-mixin (define t (new (text:ports-mixin
(editor:standard-style-list-mixin (editor:standard-style-list-mixin
text:wide-snip%)))) text:wide-snip%))))
@ -684,35 +569,34 @@
(send t undo) (send t undo)
(loop))) (loop)))
(define after (get-colors)) (define after (get-colors))
(list before after))))) (list before after)))
(define (test-ascii-art-enlarge-boxes-mixin name before position overwrite? chars after) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(test ;;
name ;; ascii art boxes
(λ (got) (equal? got after)) ;;
(λ ()
(queue-sexp-to-mred (define (ascii-art-enlarge-boxes before position overwrite? chars)
`(let ([t (new (text:ascii-art-enlarge-boxes-mixin text%))]) (define t (new (text:ascii-art-enlarge-boxes-mixin text%)))
(send t set-ascii-art-enlarge #t) (send t set-ascii-art-enlarge #t)
(define f (new frame% [label ""])) (define f (new frame% [label ""]))
(define ec (new editor-canvas% [parent f] [editor t])) (define ec (new editor-canvas% [parent f] [editor t]))
(send t insert (send t insert before)
,before) (send t set-position position position)
(send t set-position ,position ,position) (when overwrite? (send t set-overwrite-mode #t))
,@(if overwrite? (list '(send t set-overwrite-mode #t)) '()) (for ([char (in-list chars)])
,@(for/list ([char (in-list chars)]) (send ec on-char (new key-event% [key-code char])))
`(send ec on-char (new key-event% [key-code ,char]))) (send t get-text))
(send t get-text))))))
(test-ascii-art-enlarge-boxes-mixin 'ascii-art-enlarge.1 (check-equal? (ascii-art-enlarge-boxes
(string-append (string-append
"╔═╦═╗\n" "╔═╦═╗\n"
"║ ║ ║\n" "║ ║ ║\n"
"╠═╬═╣\n" "╠═╬═╣\n"
"║ ║ ║\n" "║ ║ ║\n"
"╚═╩═╝\n") "╚═╩═╝\n")
7 #t '(#\a) 7 #t '(#\a))
(string-append (string-append
"╔═╦═╗\n" "╔═╦═╗\n"
"║a║ ║\n" "║a║ ║\n"
@ -720,14 +604,14 @@
"║ ║ ║\n" "║ ║ ║\n"
"╚═╩═╝\n")) "╚═╩═╝\n"))
(test-ascii-art-enlarge-boxes-mixin 'ascii-art-enlarge.2 (check-equal? (ascii-art-enlarge-boxes
(string-append (string-append
"╔═╦═╗\n" "╔═╦═╗\n"
"║ ║ ║\n" "║ ║ ║\n"
"╠═╬═╣\n" "╠═╬═╣\n"
"║ ║ ║\n" "║ ║ ║\n"
"╚═╩═╝\n") "╚═╩═╝\n")
7 #t'(#\a #\b) 7 #t'(#\a #\b))
(string-append (string-append
"╔══╦═╗\n" "╔══╦═╗\n"
"║ab║ ║\n" "║ab║ ║\n"
@ -735,14 +619,14 @@
"║ ║ ║\n" "║ ║ ║\n"
"╚══╩═╝\n")) "╚══╩═╝\n"))
(test-ascii-art-enlarge-boxes-mixin 'ascii-art-enlarge.3 (check-equal? (ascii-art-enlarge-boxes
(string-append (string-append
"╔═╦═╗\n" "╔═╦═╗\n"
"║ ║ ║\n" "║ ║ ║\n"
"╠═╬═╣\n" "╠═╬═╣\n"
"║ ║ ║\n" "║ ║ ║\n"
"╚═╩═╝\n") "╚═╩═╝\n")
7 #f '(#\a) 7 #f '(#\a))
(string-append (string-append
"╔══╦═╗\n" "╔══╦═╗\n"
"║a ║ ║\n" "║a ║ ║\n"
@ -750,7 +634,7 @@
"║ ║ ║\n" "║ ║ ║\n"
"╚══╩═╝\n")) "╚══╩═╝\n"))
(test-ascii-art-enlarge-boxes-mixin 'ascii-art-enlarge.4 (check-equal? (ascii-art-enlarge-boxes
(string-append (string-append
"╔═╦═╗\n" "╔═╦═╗\n"
"║ ║ ║\n" "║ ║ ║\n"
@ -758,7 +642,7 @@
"╠═╬═╣\n" "╠═╬═╣\n"
"║ ║ ║\n" "║ ║ ║\n"
"╚═╩═╝\n") "╚═╩═╝\n")
14 #f '(#\f) 14 #f '(#\f))
(string-append (string-append
"╔══╦═╗\n" "╔══╦═╗\n"
"║ ║ ║\n" "║ ║ ║\n"