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

port keys.rkt to avoid separate mred process and racy frame

Browse Source 
top-level window stuff that drdr doesn't like
This commit is contained in:
Robby Findler 2017-01-14 21:45:29 -06:00
parent 6b2ff36cc9
commit 757a3c2463
2 changed files with 439 additions and 466 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -53,7 +53,7 @@ signal failures when there aren't any.
- texts: text.rkt -- now runs directly via raco test. - texts: text.rkt -- now runs directly via raco test.
- pasteboards: |# pasteboard.rkt #| - pasteboards: |# pasteboard.rkt #|
- keybindings: |# keys.rkt #| - keybindings: keys.rkt -- now runs directly via raco test.
| This tests the misc (non-scheme) keybindings | This tests the misc (non-scheme) keybindings

853
gui-test/framework/tests/keys.rkt
View File

@ -1,236 +1,195 @@
#lang racket/base #lang racket/gui
(require framework rackunit)
(require "test-suite-utils.rkt") (check-equal?
(let ([k (make-object keymap:aug-keymap%)])
(send k add-function "abc" void)
(send k map-function "c:k" "abc")
(hash-map (send k get-map-function-table) list))
'((c:k "abc")))
(module test racket/base) (check-equal?
(let ([k (make-object keymap:aug-keymap%)]
[ht (make-hasheq)])
(send k add-function "abc" void)
(send k map-function "c:k" "abc")
(hash-set! ht 'c:k "def")
(hash-map (send k get-map-function-table/ht ht) list))
'((c:k "def")))
(test (check-equal?
'keymap:aug-keymap%/get-table (let ([k (make-object keymap:aug-keymap%)]
(lambda (x) [k1 (make-object keymap:aug-keymap%)]
(equal? '((c:k "abc")) x)) [k2 (make-object keymap:aug-keymap%)])
(lambda () (send k1 add-function "abc-k1" void)
(queue-sexp-to-mred (send k1 map-function "c:k" "abc-k1")
'(let ([k (make-object keymap:aug-keymap%)]) (send k2 add-function "abc-k2" void)
(send k add-function "abc" void) (send k2 map-function "c:k" "abc-k2")
(send k map-function "c:k" "abc") (send k chain-to-keymap k1 #t)
(hash-map (send k get-map-function-table) list))))) (send k chain-to-keymap k2 #t)
(hash-map (send k get-map-function-table) list))
'((c:k "abc-k2")))
(test (check-equal?
'keymap:aug-keymap%/get-table/ht (let ([k (make-object keymap:aug-keymap%)]
(lambda (x) [k1 (make-object keymap:aug-keymap%)])
(equal? x '((c:k "def")))) (send k1 add-function "abc-k1" void)
(lambda () (send k1 map-function "c:k" "abc-k1")
(queue-sexp-to-mred (send k add-function "abc-k" void)
'(let ([k (make-object keymap:aug-keymap%)] (send k map-function "c:k" "abc-k")
[ht (make-hasheq)]) (send k chain-to-keymap k1 #t)
(send k add-function "abc" void) (hash-map (send k get-map-function-table) list))
(send k map-function "c:k" "abc") '((c:k "abc-k")))
(hash-set! ht 'c:k "def")
(hash-map (send k get-map-function-table/ht ht) list)))))
(test (check-equal?
'keymap:aug-keymap%/get-table/chain1 (let ([k (make-object keymap:aug-keymap%)]
(lambda (x) [k1 (make-object keymap:aug-keymap%)])
(equal? x '((c:k "abc-k2")))) (send k1 add-function "abc-k1" void)
(lambda () (send k1 map-function "esc;p" "abc-k1")
(queue-sexp-to-mred (send k add-function "abc-k2" void)
'(let ([k (make-object keymap:aug-keymap%)] (send k map-function "ESC;p" "abc-k2")
[k1 (make-object keymap:aug-keymap%)] (send k chain-to-keymap k1 #t)
[k2 (make-object keymap:aug-keymap%)]) (hash-map (send k get-map-function-table) list))
(send k1 add-function "abc-k1" void) '((|esc;p| "abc-k2")))
(send k1 map-function "c:k" "abc-k1")
(send k2 add-function "abc-k2" void)
(send k2 map-function "c:k" "abc-k2")
(send k chain-to-keymap k1 #t)
(send k chain-to-keymap k2 #t)
(hash-map (send k get-map-function-table) list)))))
(test (check-equal?
'keymap:aug-keymap%/get-table/chain/2 (let ([k (make-object keymap:aug-keymap%)])
(lambda (x) (send k add-function "shift-em" void)
(equal? x '((c:k "abc-k")))) (send k add-function "shift-ah" void)
(lambda () (send k map-function "s:m" "shift-em")
(queue-sexp-to-mred (send k map-function "s:a" "shift-ah")
'(let ([k (make-object keymap:aug-keymap%)] (sort (hash-map (send k get-map-function-table) list)
[k1 (make-object keymap:aug-keymap%)]) string<?
(send k1 add-function "abc-k1" void) #:key (lambda (x) (format "~s" x))))
(send k1 map-function "c:k" "abc-k1") '((s:a "shift-ah") (s:m "shift-em")))
(send k add-function "abc-k" void)
(send k map-function "c:k" "abc-k")
(send k chain-to-keymap k1 #t)
(hash-map (send k get-map-function-table) list)))))
(test (check-equal?
'keymap:aug-keymap%/get-table/normalize-case (let ()
(lambda (x) (define k0 (new keymap:aug-keymap%))
(equal? x '((|esc;p| "abc-k2")))) (define k1 (new keymap:aug-keymap%))
(lambda () (define k2 (new keymap:aug-keymap%))
(queue-sexp-to-mred (send k1 add-function "rectangle" void)
'(let ([k (make-object keymap:aug-keymap%)] (send k1 map-function "c:x;r;a" "rectangle")
[k1 (make-object keymap:aug-keymap%)]) (send k2 add-function "swap if branches" void)
(send k1 add-function "abc-k1" void) (send k2 map-function "c:x;r" "swap if branches")
(send k1 map-function "esc;p" "abc-k1") (send k0 chain-to-keymap k1 #t)
(send k add-function "abc-k2" void) (send k0 chain-to-keymap k2 #t)
(send k map-function "ESC;p" "abc-k2") (sort (hash-map (send k0 get-map-function-table) list)
(send k chain-to-keymap k1 #t) string<?
(hash-map (send k get-map-function-table) list))))) #:key (lambda (x) (format "~s" x))))
'((|c:x;r| "swap if branches")))
(test (check-equal? (keymap:canonicalize-keybinding-string "c:a") "c:a")
'keymap:aug-keymap%/all-but-last-bug (check-equal? (keymap:canonicalize-keybinding-string "d:a") "d:a")
(lambda (x) (check-equal? (keymap:canonicalize-keybinding-string "m:a") "m:a")
(equal? x '((s:a "shift-ah") (s:m "shift-em")))) (check-equal? (keymap:canonicalize-keybinding-string "a:a") "a:a")
(lambda () (check-equal? (keymap:canonicalize-keybinding-string "s:a") "s:a")
(queue-sexp-to-mred (check-equal? (keymap:canonicalize-keybinding-string "c:a") "c:a")
'(let ([k (make-object keymap:aug-keymap%)]) (check-equal? (keymap:canonicalize-keybinding-string "s:m:d:c:a:a") "a:c:d:m:s:a")
(send k add-function "shift-em" void) (check-equal? (keymap:canonicalize-keybinding-string "~s:~m:~d:~c:~a:a") "~a:~c:~d:~m:~s:a")
(send k add-function "shift-ah" void) (check-equal? (keymap:canonicalize-keybinding-string ":a") "~a:~c:~d:~m:~s:a")
(send k map-function "s:m" "shift-em") (check-equal? (keymap:canonicalize-keybinding-string ":d:a") "~a:~c:d:~m:~s:a")
(send k map-function "s:a" "shift-ah") (check-equal? (keymap:canonicalize-keybinding-string "esc;s:a") "esc;s:a")
(sort (hash-map (send k get-map-function-table) list) (check-equal? (keymap:canonicalize-keybinding-string "s:a;esc") "s:a;esc")
string<? (check-equal? (keymap:canonicalize-keybinding-string "ESC;p") "esc;p")
#:key (lambda (x) (format "~s" x))))))) (check-equal? (keymap:canonicalize-keybinding-string "?:a:v") "?:a:v")
(check-equal? (keymap:canonicalize-keybinding-string "a:?:v") "?:a:v")
(check-equal? (keymap:canonicalize-keybinding-string "l:v") "l:v")
(check-equal? (keymap:canonicalize-keybinding-string "c:l:v") "c:l:v")
(test ;; a key-spec is (make-key-spec buff-spec buff-spec (listof ?) (listof ?) (listof ?))
'keymap:aug-keymap%/longer-name ;; a key-spec represents a test case for a key; 'before' contains the
(lambda (x) ;; content of a buffer, and 'after' represents the desired content of the
(equal? x '((|c:x;r| "swap if branches")))) ;; buffer after the keypress. The keypress(es) in question are specified
(lambda () ;; independently for the three platforms by the respective 'macos', 'unix',
(queue-sexp-to-mred ;; and 'windows' fields.
'(let () (define-struct key-spec (before after macos unix windows) #:prefab)
(define k0 (new keymap:aug-keymap%))
(define k1 (new keymap:aug-keymap%))
(define k2 (new keymap:aug-keymap%))
(send k1 add-function "rectangle" void)
(send k1 map-function "c:x;r;a" "rectangle")
(send k2 add-function "swap if branches" void)
(send k2 map-function "c:x;r" "swap if branches")
(send k0 chain-to-keymap k1 #t)
(send k0 chain-to-keymap k2 #t)
(sort (hash-map (send k0 get-map-function-table) list)
string<?
#:key (lambda (x) (format "~s" x)))))))
(define (test-canonicalize name str1 str2) ;; an abstraction to use when all platforms have the same sequence of keys
(test (define (make-key-spec/allplatforms before after keys)
(string->symbol (format "keymap:canonicalize-keybinding-string/~a" name)) (make-key-spec before after keys keys keys))
(lambda (x)
(string=? x str2))
(lambda ()
(queue-sexp-to-mred
`(keymap:canonicalize-keybinding-string ,str1)))))
(test-canonicalize 1 "c:a" "c:a") ;; a buff-spec is (make-buff-spec string nat nat)
(test-canonicalize 2 "d:a" "d:a") ;; a buff-spec represents a buffer state; the content of the buffer,
(test-canonicalize 3 "m:a" "m:a") ;; and the start and end of the highlighted region.
(test-canonicalize 4 "a:a" "a:a") ;; the overwrite? field specifies if the overwrite mode is enabled during the test
(test-canonicalize 5 "s:a" "s:a") ;; (its value is ignored for the result checking)
(test-canonicalize 6 "c:a" "c:a") (define-struct buff-spec (string start end overwrite?) #:prefab)
(test-canonicalize 7 "s:m:d:c:a:a" "a:c:d:m:s:a")
(test-canonicalize 8 "~s:~m:~d:~c:~a:a" "~a:~c:~d:~m:~s:a")
(test-canonicalize 9 ":a" "~a:~c:~d:~m:~s:a")
(test-canonicalize 10 ":d:a" "~a:~c:d:~m:~s:a")
(test-canonicalize 11 "esc;s:a" "esc;s:a")
(test-canonicalize 12 "s:a;esc" "s:a;esc")
(test-canonicalize 13 "ESC;p" "esc;p")
(test-canonicalize 14 "?:a:v" "?:a:v")
(test-canonicalize 15 "a:?:v" "?:a:v")
(test-canonicalize 16 "l:v" "l:v")
(test-canonicalize 17 "c:l:v" "c:l:v")
(define (build-buff-spec string start end #:overwrite? [overwrite? #f])
(make-buff-spec string start end overwrite?))
;; a key-spec is (make-key-spec buff-spec buff-spec (listof ?) (listof ?) (listof ?)) ;; the keybindings test cases applied to frame:text% editors
;; a key-spec represents a test case for a key; 'before' contains the (define global-specs
;; content of a buffer, and 'after' represents the desired content of the (list
;; buffer after the keypress. The keypress(es) in question are specified (make-key-spec (build-buff-spec "abc" 1 1)
;; independently for the three platforms by the respective 'macos', 'unix', (build-buff-spec "abc" 2 2)
;; and 'windows' fields. (list '((#\f control)) '((right)))
(define-struct key-spec (before after macos unix windows) #:prefab) (list '((#\f control)) '((right)))
(list '((#\f control)) '((right))))
;; an abstraction to use when all platforms have the same sequence of keys (make-key-spec/allplatforms (build-buff-spec "\n\n\n\n" 2 2)
(define (make-key-spec/allplatforms before after keys) (build-buff-spec "\n" 0 0)
(make-key-spec before after keys keys keys)) '(((#\x control) (#\o control))))
(make-key-spec/allplatforms (build-buff-spec " \n \n \n \n" 7 7)
(build-buff-spec " \n" 1 1)
'(((#\x control) (#\o control))))
(make-key-spec/allplatforms (build-buff-spec "\n\n\n\n" 0 0)
(build-buff-spec "\n" 0 0)
'(((#\x control) (#\o control))))
(make-key-spec/allplatforms (build-buff-spec "abcdef\n\n\n\nxyzpdq\n" 8 8)
(build-buff-spec "abcdef\n\nxyzpdq\n" 7 7)
'(((#\x control) (#\o control))))
;; a buff-spec is (make-buff-spec string nat nat) ;; TeX-compress tests
;; a buff-spec represents a buffer state; the content of the buffer, (make-key-spec/allplatforms
;; and the start and end of the highlighted region. (build-buff-spec "\\ome" 4 4)
;; the overwrite? field specifies if the overwrite mode is enabled during the test (build-buff-spec "ω" 1 1)
;; (its value is ignored for the result checking) '(((#\\ control))))
(define-struct buff-spec (string start end overwrite?) #:prefab) (make-key-spec/allplatforms
(build-buff-spec "\\sub" 4 4)
(build-buff-spec "\\subset" 7 7)
'(((#\\ control))))
(make-key-spec/allplatforms
(build-buff-spec "\\subset" 7 7)
(build-buff-spec "⊂" 1 1)
'(((#\\ control))))
(make-key-spec/allplatforms
(build-buff-spec "\\sub" 4 4)
(build-buff-spec "⊆" 1 1)
'(((#\\ control) (#\e) (#\\ control))))))
(define (build-buff-spec string start end #:overwrite? [overwrite? #f]) (define (build-open-bracket-spec str pos char)
(make-buff-spec string start end overwrite?)) (make-key-spec (build-buff-spec str pos pos)
(build-buff-spec
(string-append (substring str 0 pos)
(string char)
(substring str pos (string-length str)))
(+ pos 1)
(+ pos 1))
(list (list (list #\[)))
(list (list (list #\[)))
(list (list (list #\[)))))
;; the keybindings test cases applied to frame:text% editors (define (ascii-art-box-spec before after)
(define global-specs (make-key-spec/allplatforms (build-buff-spec before 0 0)
(list (build-buff-spec after 0 0)
(make-key-spec (build-buff-spec "abc" 1 1) (list '((#\x control) (#\r) (#\a)))))
(build-buff-spec "abc" 2 2)
(list '((#\f control)) '((right)))
(list '((#\f control)) '((right)))
(list '((#\f control)) '((right))))
(make-key-spec/allplatforms (build-buff-spec "\n\n\n\n" 2 2) ;; the keybindings test cases applied to racket:text% editors
(build-buff-spec "\n" 0 0) (define scheme-specs
'(((#\x control) (#\o control)))) (list
(make-key-spec/allplatforms (build-buff-spec " \n \n \n \n" 7 7) (make-key-spec (build-buff-spec "(abc (def))" 4 4)
(build-buff-spec " \n" 1 1) (build-buff-spec "(abc (def))" 10 10)
'(((#\x control) (#\o control)))) (list '((right alt)))
(make-key-spec/allplatforms (build-buff-spec "\n\n\n\n" 0 0) (list '((right alt)))
(build-buff-spec "\n" 0 0) (list '((right alt))))
'(((#\x control) (#\o control)))) (make-key-spec (build-buff-spec "'(abc (def))" 1 1)
(make-key-spec/allplatforms (build-buff-spec "abcdef\n\n\n\nxyzpdq\n" 8 8) (build-buff-spec "'(abc (def))" 12 12)
(build-buff-spec "abcdef\n\nxyzpdq\n" 7 7) (list '((right alt)))
'(((#\x control) (#\o control)))) (list '((right alt)))
(list '((right alt))))
;; TeX-compress tests #|
(make-key-spec/allplatforms
(build-buff-spec "\\ome" 4 4)
(build-buff-spec "ω" 1 1)
'(((#\\ control))))
(make-key-spec/allplatforms
(build-buff-spec "\\sub" 4 4)
(build-buff-spec "\\subset" 7 7)
'(((#\\ control))))
(make-key-spec/allplatforms
(build-buff-spec "\\subset" 7 7)
(build-buff-spec "⊂" 1 1)
'(((#\\ control))))
(make-key-spec/allplatforms
(build-buff-spec "\\sub" 4 4)
(build-buff-spec "⊆" 1 1)
'(((#\\ control) (#\e) (#\\ control))))))
(define (build-open-bracket-spec str pos char)
(make-key-spec (build-buff-spec str pos pos)
(build-buff-spec
(string-append (substring str 0 pos)
(string char)
(substring str pos (string-length str)))
(+ pos 1)
(+ pos 1))
(list (list (list #\[)))
(list (list (list #\[)))
(list (list (list #\[)))))
(define (ascii-art-box-spec before after)
(make-key-spec/allplatforms (build-buff-spec before 0 0)
(build-buff-spec after 0 0)
(list '((#\x control) (#\r) (#\a)))))
;; the keybindings test cases applied to racket:text% editors
(define scheme-specs
(list
(make-key-spec (build-buff-spec "(abc (def))" 4 4)
(build-buff-spec "(abc (def))" 10 10)
(list '((right alt)))
(list '((right alt)))
(list '((right alt))))
(make-key-spec (build-buff-spec "'(abc (def))" 1 1)
(build-buff-spec "'(abc (def))" 12 12)
(list '((right alt)))
(list '((right alt)))
(list '((right alt))))
#|
(make-key-spec (build-buff-spec "'(abc (def))" 0 0) (make-key-spec (build-buff-spec "'(abc (def))" 0 0)
(build-buff-spec "'(abc (def))" 12 12) (build-buff-spec "'(abc (def))" 12 12)
(list '(right alt)) (list '(right alt))
@ -242,243 +201,257 @@
(list '(left alt)) (list '(left alt))
(list '(left alt))) (list '(left alt)))
|# |#
(build-open-bracket-spec "" 0 #\() (build-open-bracket-spec "" 0 #\()
(build-open-bracket-spec "(f cond " 8 #\() (build-open-bracket-spec "(f cond " 8 #\()
(build-open-bracket-spec "(f let (" 8 #\() (build-open-bracket-spec "(f let (" 8 #\()
(build-open-bracket-spec "(let (" 6 #\[) (build-open-bracket-spec "(let (" 6 #\[)
(build-open-bracket-spec "(let (" 5 #\() (build-open-bracket-spec "(let (" 5 #\()
(build-open-bracket-spec "(provide/contract " 18 #\[) (build-open-bracket-spec "(provide/contract " 18 #\[)
(build-open-bracket-spec "(kond " 5 #\() (build-open-bracket-spec "(kond " 5 #\()
(build-open-bracket-spec "(cond " 5 #\[) (build-open-bracket-spec "(cond " 5 #\[)
(build-open-bracket-spec "(case-lambda " 13 #\[) (build-open-bracket-spec "(case-lambda " 13 #\[)
(build-open-bracket-spec "(let ([]" 8 #\[) (build-open-bracket-spec "(let ([]" 8 #\[)
(build-open-bracket-spec "(let ({}" 8 #\{) (build-open-bracket-spec "(let ({}" 8 #\{)
(build-open-bracket-spec "()" 2 #\() (build-open-bracket-spec "()" 2 #\()
(build-open-bracket-spec "(let (;;" 8 #\[) (build-open-bracket-spec "(let (;;" 8 #\[)
(build-open-bracket-spec ";" 1 #\[) (build-open-bracket-spec ";" 1 #\[)
(build-open-bracket-spec "\"" 1 #\[) (build-open-bracket-spec "\"" 1 #\[)
(build-open-bracket-spec "\"\"" 1 #\[) (build-open-bracket-spec "\"\"" 1 #\[)
(build-open-bracket-spec "||" 1 #\[) (build-open-bracket-spec "||" 1 #\[)
(build-open-bracket-spec "" 0 #\() (build-open-bracket-spec "" 0 #\()
(build-open-bracket-spec "(let (" 6 #\[) (build-open-bracket-spec "(let (" 6 #\[)
(build-open-bracket-spec "(new x% " 8 #\[) (build-open-bracket-spec "(new x% " 8 #\[)
(build-open-bracket-spec "#\\" 2 #\[) (build-open-bracket-spec "#\\" 2 #\[)
(build-open-bracket-spec "#\\a" 2 #\[) (build-open-bracket-spec "#\\a" 2 #\[)
(build-open-bracket-spec "(let ([let (" 12 #\() (build-open-bracket-spec "(let ([let (" 12 #\()
(build-open-bracket-spec "ab" 1 #\() (build-open-bracket-spec "ab" 1 #\()
(build-open-bracket-spec "|ab|" 2 #\[) (build-open-bracket-spec "|ab|" 2 #\[)
(build-open-bracket-spec "(let loop " 10 #\() (build-open-bracket-spec "(let loop " 10 #\()
(build-open-bracket-spec "(let loop (" 11 #\[) (build-open-bracket-spec "(let loop (" 11 #\[)
(build-open-bracket-spec "(case x " 8 #\[) (build-open-bracket-spec "(case x " 8 #\[)
(build-open-bracket-spec "(case x [" 9 #\() (build-open-bracket-spec "(case x [" 9 #\()
(build-open-bracket-spec "(let ([])(" 10 #\() (build-open-bracket-spec "(let ([])(" 10 #\()
(build-open-bracket-spec "(local " 7 #\[) (build-open-bracket-spec "(local " 7 #\[)
(build-open-bracket-spec "(local []" 9 #\() (build-open-bracket-spec "(local []" 9 #\()
;; test to show that multi-keystrokes works: ;; test to show that multi-keystrokes works:
(make-key-spec/allplatforms (make-key-spec/allplatforms
(build-buff-spec "" 0 0) (build-buff-spec "" 0 0)
(build-buff-spec "zx" 2 2) (build-buff-spec "zx" 2 2)
(list '((#\z) (#\x)))) (list '((#\z) (#\x))))
;; remove-enclosing-parens : ;; remove-enclosing-parens :
(make-key-spec/allplatforms (make-key-spec/allplatforms
(build-buff-spec "(abc def)" 1 1) (build-buff-spec "(abc def)" 1 1)
(build-buff-spec "abc" 0 0) (build-buff-spec "abc" 0 0)
(list '((#\c control) (#\o control)))) (list '((#\c control) (#\o control))))
;; (is this the desired behavior?): ;; (is this the desired behavior?):
(make-key-spec/allplatforms (make-key-spec/allplatforms
(build-buff-spec "(abc def)" 2 3) (build-buff-spec "(abc def)" 2 3)
(build-buff-spec "bc" 0 0) (build-buff-spec "bc" 0 0)
(list '((#\c control) (#\o control)))) (list '((#\c control) (#\o control))))
;; insert-()-pair : ;; insert-()-pair :
(make-key-spec (make-key-spec
(build-buff-spec "abc" 0 0) (build-buff-spec "abc" 0 0)
(build-buff-spec "()abc" 1 1) (build-buff-spec "()abc" 1 1)
(list '((escape) (#\())) (list '((escape) (#\()))
(list '((#\( meta))) (list '((#\( meta)))
(list '((escape) (#\()))) (list '((escape) (#\())))
(make-key-spec (make-key-spec
(build-buff-spec "abc" 0 2) (build-buff-spec "abc" 0 2)
(build-buff-spec "(ab)c" 1 1) (build-buff-spec "(ab)c" 1 1)
(list '((escape) (#\())) (list '((escape) (#\()))
(list '((#\( meta))) (list '((#\( meta)))
(list '((escape) (#\()))) (list '((escape) (#\())))
;; toggle-square-round-parens : ;; toggle-square-round-parens :
; () -> [] ; () -> []
(make-key-spec/allplatforms (make-key-spec/allplatforms
(build-buff-spec "(a)" 0 0) (build-buff-spec "(a)" 0 0)
(build-buff-spec "[a]" 0 0) (build-buff-spec "[a]" 0 0)
(list '((#\c control) (#\[ control)))) (list '((#\c control) (#\[ control))))
; [] -> () ; [] -> ()
(make-key-spec/allplatforms (make-key-spec/allplatforms
(build-buff-spec "[a]" 0 0) (build-buff-spec "[a]" 0 0)
(build-buff-spec "(a)" 0 0) (build-buff-spec "(a)" 0 0)
(list '((#\c control) (#\[ control)))) (list '((#\c control) (#\[ control))))
; enclosed sexps ; enclosed sexps
(make-key-spec/allplatforms (make-key-spec/allplatforms
(build-buff-spec "[a (def )b]" 0 0) (build-buff-spec "[a (def )b]" 0 0)
(build-buff-spec "(a (def )b)" 0 0) (build-buff-spec "(a (def )b)" 0 0)
(list '((#\c control) (#\[ control)))) (list '((#\c control) (#\[ control))))
; extra preceding whitespace ; extra preceding whitespace
(make-key-spec/allplatforms (make-key-spec/allplatforms
(build-buff-spec " \n [a (def )b]" 0 0) (build-buff-spec " \n [a (def )b]" 0 0)
(build-buff-spec " \n (a (def )b)" 0 0) (build-buff-spec " \n (a (def )b)" 0 0)
(list '((#\c control) (#\[ control)))) (list '((#\c control) (#\[ control))))
; cursor not at beginning of buffer ; cursor not at beginning of buffer
(make-key-spec/allplatforms (make-key-spec/allplatforms
(build-buff-spec " \n [a (def )b]" 1 1) (build-buff-spec " \n [a (def )b]" 1 1)
(build-buff-spec " \n (a (def )b)" 1 1) (build-buff-spec " \n (a (def )b)" 1 1)
(list '((#\c control) (#\[ control)))) (list '((#\c control) (#\[ control))))
; intervening non-paren sexp ; intervening non-paren sexp
(make-key-spec/allplatforms (make-key-spec/allplatforms
(build-buff-spec " \nf [a (def )b]" 1 1) (build-buff-spec " \nf [a (def )b]" 1 1)
(build-buff-spec " \nf [a (def )b]" 1 1) (build-buff-spec " \nf [a (def )b]" 1 1)
(list '((#\c control) (#\[ control)))) (list '((#\c control) (#\[ control))))
;; at end of buffer (hence sexp-forward returns #f): ;; at end of buffer (hence sexp-forward returns #f):
(make-key-spec/allplatforms (make-key-spec/allplatforms
(build-buff-spec "[a]" 3 3) (build-buff-spec "[a]" 3 3)
(build-buff-spec "[a]" 3 3) (build-buff-spec "[a]" 3 3)
(list '((#\c control) (#\[ control)))) (list '((#\c control) (#\[ control))))
(make-key-spec/allplatforms (make-key-spec/allplatforms
(build-buff-spec "a" 0 0 #:overwrite? #t) (build-buff-spec "a" 0 0 #:overwrite? #t)
(build-buff-spec "b" 1 1) (build-buff-spec "b" 1 1)
(list '((#\b)))) (list '((#\b))))
(make-key-spec/allplatforms (make-key-spec/allplatforms
(build-buff-spec "a" 0 0 #:overwrite? #t) (build-buff-spec "a" 0 0 #:overwrite? #t)
(build-buff-spec "|" 1 1) (build-buff-spec "|" 1 1)
(list '((#\|)))) (list '((#\|))))
(make-key-spec/allplatforms (make-key-spec/allplatforms
(build-buff-spec "a" 0 0 #:overwrite? #t) (build-buff-spec "a" 0 0 #:overwrite? #t)
(build-buff-spec "(" 1 1) (build-buff-spec "(" 1 1)
(list '((#\()))) (list '((#\())))
(make-key-spec/allplatforms (make-key-spec/allplatforms
(build-buff-spec "a" 0 0 #:overwrite? #t) (build-buff-spec "a" 0 0 #:overwrite? #t)
(build-buff-spec ")" 1 1) (build-buff-spec ")" 1 1)
(list '((#\))))) (list '((#\)))))
;; needs to be in auto-adjut open paren mode ;; needs to be in auto-adjut open paren mode
(make-key-spec/allplatforms (make-key-spec/allplatforms
(build-buff-spec "a" 0 0 #:overwrite? #t) (build-buff-spec "a" 0 0 #:overwrite? #t)
(build-buff-spec "(" 1 1) (build-buff-spec "(" 1 1)
(list '((#\[)))) (list '((#\[))))
(ascii-art-box-spec "+" "═") (ascii-art-box-spec "+" "═")
(ascii-art-box-spec "x" "x") (ascii-art-box-spec "x" "x")
(ascii-art-box-spec "+-+" "═══") (ascii-art-box-spec "+-+" "═══")
(ascii-art-box-spec "+\n|\n+\n" "║\n║\n║\n") (ascii-art-box-spec "+\n|\n+\n" "║\n║\n║\n")
(ascii-art-box-spec (string-append "+-+\n" (ascii-art-box-spec (string-append "+-+\n"
"| |\n" "| |\n"
"+-+\n") "+-+\n")
(string-append "╔═╗\n" (string-append "╔═╗\n"
"║ ║\n" "║ ║\n"
"╚═╝\n")) "╚═╝\n"))
(ascii-art-box-spec (string-append "+---+\n" (ascii-art-box-spec (string-append "+---+\n"
"| - |\n" "| - |\n"
"|+ ||\n" "|+ ||\n"
"+---+\n") "+---+\n")
(string-append "╔═══╗\n" (string-append "╔═══╗\n"
"║ - ║\n" "║ - ║\n"
"║+ |║\n" "║+ |║\n"
"╚═══╝\n")) "╚═══╝\n"))
(ascii-art-box-spec (string-append "+-+-+\n" (ascii-art-box-spec (string-append "+-+-+\n"
"| | |\n" "| | |\n"
"+-+-+\n" "+-+-+\n"
"| | |\n" "| | |\n"
"+-+-+\n") "+-+-+\n")
(string-append "╔═╦═╗\n" (string-append "╔═╦═╗\n"
"║ ║ ║\n" "║ ║ ║\n"
"╠═╬═╣\n" "╠═╬═╣\n"
"║ ║ ║\n" "║ ║ ║\n"
"╚═╩═╝\n")))) "╚═╩═╝\n"))))
(define automatic-scheme-specs (define automatic-scheme-specs
(list (make-key-spec/allplatforms (build-buff-spec "" 0 0) (list (make-key-spec/allplatforms (build-buff-spec "" 0 0)
(build-buff-spec "()" 1 1) (build-buff-spec "()" 1 1)
'(((#\()))) '(((#\())))
(make-key-spec/allplatforms (build-buff-spec "" 0 0) (make-key-spec/allplatforms (build-buff-spec "" 0 0)
(build-buff-spec "[]" 1 1) (build-buff-spec "[]" 1 1)
'(((#\[)))) '(((#\[))))
(make-key-spec/allplatforms (build-buff-spec "" 0 0) (make-key-spec/allplatforms (build-buff-spec "" 0 0)
(build-buff-spec "{}" 1 1) (build-buff-spec "{}" 1 1)
'(((#\{)))) '(((#\{))))
(make-key-spec/allplatforms (build-buff-spec "" 0 0) (make-key-spec/allplatforms (build-buff-spec "" 0 0)
(build-buff-spec "\"\"" 1 1) (build-buff-spec "\"\"" 1 1)
'(((#\")))) '(((#\"))))
(make-key-spec/allplatforms (build-buff-spec "" 0 0) (make-key-spec/allplatforms (build-buff-spec "" 0 0)
(build-buff-spec "||" 1 1) (build-buff-spec "||" 1 1)
'(((#\|)))))) '(((#\|))))))
(queue-sexp-to-mred `(send (make-object frame:basic% "dummy to trick frame group") show #t)) (define (queue-callback/wait t)
(wait-for-frame "dummy to trick frame group") (define c (make-channel))
(queue-callback (λ () (channel-put c (t))))
(channel-get c))
;; test-key : key-spec -> (define (test-specs frame-name frame-class specs)
;; evaluates a test case represented as a key-spec (define f #f)
(define (test-key key-spec i) (queue-callback/wait
(let* ([key-sequences (λ ()
((case (system-type) (set! f (make-object frame-class frame-name))
[(macos macosx) key-spec-macos] (send f show #t)))
[(unix) key-spec-unix]
[(windows) key-spec-windows])
key-spec)]
[before (key-spec-before key-spec)]
[after (key-spec-after key-spec)]
[process-key-sequence
(lambda (key-sequence)
(let ([text-expect (buff-spec-string after)]
[start-expect (buff-spec-start after)]
[end-expect (buff-spec-end after)])
(test (list key-sequence i)
(lambda (x) (equal? x (vector text-expect start-expect end-expect)))
`(let* ([qc (λ (t) (let ([c (make-channel)])
(queue-callback (λ () (channel-put c (t))))
(channel-get c)))]
[text (qc (λ () (send (get-top-level-focus-window) get-editor)))])
(qc (λ ()
(send text set-overwrite-mode ,(buff-spec-overwrite? before))
(send text erase)
(send text insert ,(buff-spec-string before))
(send text set-position ,(buff-spec-start before) ,(buff-spec-end before))))
,@(map (lambda (key) `(test:keystroke ',(car key) ',(cdr key)))
key-sequence)
(qc (λ ()
(vector (send text get-text)
(send text get-start-position)
(send text get-end-position))))))))])
(for-each process-key-sequence key-sequences)))
(for ([key-spec (in-list specs)]
[i (in-naturals)])
(define key-sequences
((case (system-type)
[(macos macosx) key-spec-macos]
[(unix) key-spec-unix]
[(windows) key-spec-windows])
key-spec))
(define before (key-spec-before key-spec))
(define after (key-spec-after key-spec))
(for ([key-sequence (in-list key-sequences)])
(define text-expect (buff-spec-string after))
(define start-expect (buff-spec-start after))
(define end-expect (buff-spec-end after))
(queue-callback
(λ ()
(define frame (test:get-active-top-level-window))
(define text (send frame get-editor))
(send text set-overwrite-mode (buff-spec-overwrite? before))
(send text erase)
(send text insert (buff-spec-string before))
(send text set-position (buff-spec-start before) (buff-spec-end before))))
(for ([key (in-list key-sequence)])
(test:keystroke (car key) (cdr key)))
(check-equal?
(queue-callback/wait
(λ ()
(define frame (test:get-active-top-level-window))
(define text (send frame get-editor))
(vector (send text get-text)
(send text get-start-position)
(send text get-end-position))))
(vector text-expect start-expect end-expect)
(~s (list key-sequence i)))))
(queue-callback/wait (λ () (send f close))))
(define (test-specs frame-name frame-class specs) (let ([pref-ht (make-hash)])
(queue-sexp-to-mred `(send (make-object ,frame-class ,frame-name) show #t)) (parameterize ([test:use-focus-table #t]
(wait-for-frame frame-name) [preferences:low-level-get-preference
(for ([spec (in-list specs)] (λ (sym [fail (λ () #f)])
[i (in-naturals)]) (hash-ref pref-ht sym fail))]
(test-key spec i)) [preferences:low-level-put-preferences
(queue-sexp-to-mred `(send (get-top-level-focus-window) close))) (λ (syms vals)
(for ([sym (in-list syms)]
[val (in-list vals)])
(hash-set! pref-ht sym val)))])
;; needs to be inside the test:use-focus-table setting
(parameterize ([current-eventspace (make-eventspace)])
(define old-paren-adjusting-prefs (define dummy #f)
(queue-sexp-to-mred `(list (preferences:get 'framework:fixup-open-parens) (queue-callback
(preferences:get 'framework:automatic-parens)))) (λ ()
(set! dummy (make-object frame:basic% "dummy to trick frame group"))
(send dummy show #t)))
(preferences:set 'framework:fixup-open-parens #t)
(preferences:set 'framework:automatic-parens #f)
(test-specs "global keybindings test" frame:text% global-specs)
(test-specs "racket mode keybindings test"
(class frame:editor%
(define/override (get-editor%) racket:text%)
(super-new))
scheme-specs)
(queue-sexp-to-mred `(preferences:set 'framework:fixup-open-parens #t)) (preferences:set 'framework:automatic-parens #t)
(queue-sexp-to-mred `(preferences:set 'framework:automatic-parens #f)) (preferences:set 'framework:fixup-open-parens #f)
(test-specs "global keybindings test" 'frame:text% global-specs) (test-specs "racket mode automatic-parens on keybindings test"
(test-specs "scheme mode keybindings test" (class frame:editor%
'(class frame:editor% (define/override (get-editor%) racket:text%)
(define/override (get-editor%) racket:text%) (super-new))
(super-new)) automatic-scheme-specs)
scheme-specs)
(queue-sexp-to-mred `(preferences:set 'framework:automatic-parens #t))
(queue-sexp-to-mred `(preferences:set 'framework:fixup-open-parens #f))
(test-specs "scheme mode automatic-parens on keybindings test"
'(class frame:editor%
(define/override (get-editor%) racket:text%)
(super-new))
automatic-scheme-specs)
(queue-sexp-to-mred (queue-callback (λ () (send dummy show #f))))))
`(begin (preferences:set 'framework:fixup-open-parens ,(list-ref old-paren-adjusting-prefs 0))
(preferences:set 'framework:automatic-parens ,(list-ref old-paren-adjusting-prefs 1))))