added automatic remapping of [ to ( in many cases; see docs for details
svn: r2662 original commit: 6638f46c759632de38a490284399391e1fc1c950
This commit is contained in:
Robby Findler
parent
b4c7460924
commit
d47be726d1
|
|
@ -403,7 +403,7 @@
|
|||
(inherit get-styles-fixed)
|
||||
(inherit has-focus? find-snip split-snip)
|
||||
|
||||
(public get-limit balance-parens tabify-on-return? tabify
|
||||
(public get-limit tabify-on-return? tabify
|
||||
tabify-all insert-return calc-last-para
|
||||
box-comment-out-selection comment-out-selection uncomment-selection
|
||||
get-forward-sexp remove-sexp forward-sexp flash-forward-sexp get-backward-sexp
|
||||
|
|
@ -411,7 +411,7 @@
|
|||
remove-parens-forward)
|
||||
(define (get-limit pos) 0)
|
||||
|
||||
(define (balance-parens key-event)
|
||||
(define/public (balance-parens key-event)
|
||||
(insert-close-paren (get-start-position)
|
||||
(send key-event get-key-code)
|
||||
(preferences:get 'framework:paren-match)
|
||||
|
|
@ -972,6 +972,15 @@
|
|||
[define get-tab-size (λ () tab-size)]
|
||||
[define set-tab-size (λ (s) (set! tab-size s))]
|
||||
|
||||
(inherit is-frozen? is-stopped?)
|
||||
(define/public (rewrite-square-paren)
|
||||
(insert (cond
|
||||
[(or (is-frozen?) (is-stopped?))
|
||||
#\[]
|
||||
[else (choose-paren this (get-start-position))])
|
||||
(get-start-position)
|
||||
(get-end-position)))
|
||||
|
||||
(super-instantiate ())))
|
||||
|
||||
(define -text-mode<%>
|
||||
|
|
@ -1109,7 +1118,9 @@
|
|||
(add-edit-function "box-comment-out"
|
||||
(λ (x) (send x box-comment-out-selection)))
|
||||
(add-edit-function "uncomment"
|
||||
(λ (x) (send x uncomment-selection))))
|
||||
(λ (x) (send x uncomment-selection)))
|
||||
(add-edit-function "rewrite-square-paren"
|
||||
(λ (x) (send x rewrite-square-paren))))
|
||||
|
||||
(send keymap add-function "balance-parens"
|
||||
(λ (edit event)
|
||||
|
|
@ -1131,6 +1142,8 @@
|
|||
(send keymap map-function "]" "balance-parens")
|
||||
(send keymap map-function "}" "balance-parens")
|
||||
|
||||
(send keymap map-function "[" "rewrite-square-paren")
|
||||
|
||||
(let ([map-meta
|
||||
(λ (key func)
|
||||
(keymap:send-map-function-meta keymap key func))]
|
||||
|
|
@ -1197,6 +1210,73 @@
|
|||
(setup-keymap keymap)
|
||||
(define (get-keymap) keymap)
|
||||
|
||||
;; choose-paren : scheme-text number -> character
|
||||
;; returns the character to replace a #\[ with, based
|
||||
;; on the context where it is typed in.
|
||||
(define (choose-paren text pos)
|
||||
(if (memq (send text classify-position pos) '(string error comment symbol))
|
||||
#\[
|
||||
(let* ([before-whitespace-pos (send text skip-whitespace pos 'backward #t)]
|
||||
[backward-match (send text backward-match before-whitespace-pos 0)])
|
||||
(let ([b-m-char (and (number? backward-match) (send text get-character backward-match))])
|
||||
(cond
|
||||
[(member b-m-char '(#\( #\[ #\{))
|
||||
;; found a "sibling" parenthesized sequence. use the parens it uses.
|
||||
b-m-char]
|
||||
[backward-match
|
||||
;; there is a sexp before this, but it isn't parenthesized.
|
||||
;; if it is the `cond' keyword, we get a square bracket. otherwise not.
|
||||
(if (and (beginning-of-sequence? text backward-match)
|
||||
(text-between-equal? "cond" text backward-match before-whitespace-pos))
|
||||
#\[
|
||||
#\()]
|
||||
[(not (zero? before-whitespace-pos))
|
||||
;; this is the first thing in the sequence
|
||||
;; pop out one layer and look for a keyword.
|
||||
;; if we find a let<mumble> keyword, we get a square bracket,
|
||||
;; otherwise a round paren
|
||||
(let ([b-w-p-char (send text get-character (- before-whitespace-pos 1))])
|
||||
(cond
|
||||
[(equal? b-w-p-char #\()
|
||||
(let* ([second-before-whitespace-pos (send text skip-whitespace (- before-whitespace-pos 1) 'backward #t)]
|
||||
[second-backwards-match (send text backward-match second-before-whitespace-pos 0)])
|
||||
(cond
|
||||
[(not second-backwards-match)
|
||||
#\(]
|
||||
[(and (beginning-of-sequence? text second-backwards-match)
|
||||
(ormap (λ (x) (text-between-equal? x
|
||||
text
|
||||
second-backwards-match
|
||||
second-before-whitespace-pos))
|
||||
'("let"
|
||||
"let*" "let-values" "let-syntax" "let-struct" "let-syntaxes"
|
||||
"letrec"
|
||||
"letrec-syntaxes" "letrec-syntaxes+values" "letrec-values")))
|
||||
#\[]
|
||||
[else
|
||||
#\(]))]
|
||||
[else
|
||||
#\(]))]
|
||||
[else #\(])))))
|
||||
|
||||
(define (beginning-of-sequence? text start)
|
||||
(let ([before-space (send text skip-whitespace start 'backward #t)])
|
||||
(cond
|
||||
[(zero? before-space) #t]
|
||||
[else
|
||||
(member (send text get-character (- before-space 1))
|
||||
'(#\( #\[ #\{))])))
|
||||
|
||||
(define (text-between-equal? str text start end)
|
||||
(and (= (string-length str) (- end start))
|
||||
(let loop ([i (string-length str)])
|
||||
(cond
|
||||
[(= i 0) #t]
|
||||
[else
|
||||
(and (char=? (string-ref str (- i 1))
|
||||
(send text get-character (+ i start -1)))
|
||||
(loop (- i 1)))]))))
|
||||
|
||||
|
||||
;;; ;;;
|
||||
; ;
|
||||
|
|
|
|||
|
|
@ -1,129 +1,131 @@
|
|||
(module keys mzscheme
|
||||
(require "test-suite-utils.ss")
|
||||
(require (lib "include.ss"))
|
||||
|
||||
(test
|
||||
'keymap:aug-keymap%/get-table
|
||||
(lambda (x)
|
||||
(equal? '((c:k "abc")) x))
|
||||
(lambda ()
|
||||
(send-sexp-to-mred
|
||||
'(let ([k (make-object keymap:aug-keymap%)])
|
||||
(send k add-function "abc" void)
|
||||
(send k map-function "c:k" "abc")
|
||||
(hash-table-map (send k get-map-function-table) list)))))
|
||||
|
||||
(test
|
||||
'keymap:aug-keymap%/get-table/ht
|
||||
(lambda (x)
|
||||
(equal? x '((c:k "def"))))
|
||||
(lambda ()
|
||||
(send-sexp-to-mred
|
||||
'(let ([k (make-object keymap:aug-keymap%)]
|
||||
[ht (make-hash-table)])
|
||||
(send k add-function "abc" void)
|
||||
(send k map-function "c:k" "abc")
|
||||
(hash-table-put! ht 'c:k "def")
|
||||
(hash-table-map (send k get-map-function-table/ht ht) list)))))
|
||||
|
||||
(test
|
||||
'keymap:aug-keymap%/get-table/chain1
|
||||
(lambda (x)
|
||||
(equal? x '((c:k "abc-k2"))))
|
||||
(lambda ()
|
||||
(send-sexp-to-mred
|
||||
'(let ([k (make-object keymap:aug-keymap%)]
|
||||
[k1 (make-object keymap:aug-keymap%)]
|
||||
[k2 (make-object keymap:aug-keymap%)])
|
||||
(send k1 add-function "abc-k1" void)
|
||||
(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-table-map (send k get-map-function-table) list)))))
|
||||
|
||||
(test
|
||||
'keymap:aug-keymap%/get-table/chain/2
|
||||
(lambda (x)
|
||||
(equal? x '((c:k "abc-k"))))
|
||||
(lambda ()
|
||||
(send-sexp-to-mred
|
||||
'(let ([k (make-object keymap:aug-keymap%)]
|
||||
[k1 (make-object keymap:aug-keymap%)])
|
||||
(send k1 add-function "abc-k1" void)
|
||||
(send k1 map-function "c:k" "abc-k1")
|
||||
(send k add-function "abc-k" void)
|
||||
(send k map-function "c:k" "abc-k")
|
||||
(send k chain-to-keymap k1 #t)
|
||||
(hash-table-map (send k get-map-function-table) list)))))
|
||||
|
||||
(define (test-canonicalize name str1 str2)
|
||||
|
||||
(test
|
||||
(string->symbol (format "keymap:canonicalize-keybinding-string/~a" name))
|
||||
'keymap:aug-keymap%/get-table
|
||||
(lambda (x)
|
||||
(string=? x str2))
|
||||
(equal? '((c:k "abc")) x))
|
||||
(lambda ()
|
||||
(send-sexp-to-mred
|
||||
`(keymap:canonicalize-keybinding-string ,str2)))))
|
||||
'(let ([k (make-object keymap:aug-keymap%)])
|
||||
(send k add-function "abc" void)
|
||||
(send k map-function "c:k" "abc")
|
||||
(hash-table-map (send k get-map-function-table) list)))))
|
||||
|
||||
(test
|
||||
'keymap:aug-keymap%/get-table/ht
|
||||
(lambda (x)
|
||||
(equal? x '((c:k "def"))))
|
||||
(lambda ()
|
||||
(send-sexp-to-mred
|
||||
'(let ([k (make-object keymap:aug-keymap%)]
|
||||
[ht (make-hash-table)])
|
||||
(send k add-function "abc" void)
|
||||
(send k map-function "c:k" "abc")
|
||||
(hash-table-put! ht 'c:k "def")
|
||||
(hash-table-map (send k get-map-function-table/ht ht) list)))))
|
||||
|
||||
(test
|
||||
'keymap:aug-keymap%/get-table/chain1
|
||||
(lambda (x)
|
||||
(equal? x '((c:k "abc-k2"))))
|
||||
(lambda ()
|
||||
(send-sexp-to-mred
|
||||
'(let ([k (make-object keymap:aug-keymap%)]
|
||||
[k1 (make-object keymap:aug-keymap%)]
|
||||
[k2 (make-object keymap:aug-keymap%)])
|
||||
(send k1 add-function "abc-k1" void)
|
||||
(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-table-map (send k get-map-function-table) list)))))
|
||||
|
||||
(test
|
||||
'keymap:aug-keymap%/get-table/chain/2
|
||||
(lambda (x)
|
||||
(equal? x '((c:k "abc-k"))))
|
||||
(lambda ()
|
||||
(send-sexp-to-mred
|
||||
'(let ([k (make-object keymap:aug-keymap%)]
|
||||
[k1 (make-object keymap:aug-keymap%)])
|
||||
(send k1 add-function "abc-k1" void)
|
||||
(send k1 map-function "c:k" "abc-k1")
|
||||
(send k add-function "abc-k" void)
|
||||
(send k map-function "c:k" "abc-k")
|
||||
(send k chain-to-keymap k1 #t)
|
||||
(hash-table-map (send k get-map-function-table) list)))))
|
||||
|
||||
(define (test-canonicalize name str1 str2)
|
||||
(test
|
||||
(string->symbol (format "keymap:canonicalize-keybinding-string/~a" name))
|
||||
(lambda (x)
|
||||
(string=? x str2))
|
||||
(lambda ()
|
||||
(send-sexp-to-mred
|
||||
`(keymap:canonicalize-keybinding-string ,str2)))))
|
||||
|
||||
(test-canonicalize 1 "c:a" "c:a")
|
||||
(test-canonicalize 2 "d:a" "d:a")
|
||||
(test-canonicalize 3 "m:a" "m:a")
|
||||
(test-canonicalize 4 "a:a" "a:a")
|
||||
(test-canonicalize 5 "s:a" "s:a")
|
||||
(test-canonicalize 6 "c:a" "c:a")
|
||||
(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")
|
||||
|
||||
(include "key-specs.ss")
|
||||
|
||||
(send-sexp-to-mred `(send (make-object frame:basic% "dummy to trick frame group") show #t))
|
||||
(wait-for-frame "dummy to trick frame group")
|
||||
|
||||
(define (test-key key-spec)
|
||||
(let* ([keys ((case (system-type)
|
||||
[(macos macosx) key-spec-macos]
|
||||
[(unix) key-spec-unix]
|
||||
[(windows) key-spec-windows])
|
||||
key-spec)]
|
||||
[before (key-spec-before key-spec)]
|
||||
[after (key-spec-after key-spec)]
|
||||
[process-key
|
||||
(lambda (key)
|
||||
(printf "process-key.1 ~s\n" key)
|
||||
(let ([text-expect (buff-spec-string after)]
|
||||
[start-expect (buff-spec-start after)]
|
||||
[end-expect (buff-spec-end after)])
|
||||
(test key
|
||||
(lambda (x) (equal? x (vector text-expect start-expect end-expect)))
|
||||
`(let* ([text (send (get-top-level-focus-window) get-editor)])
|
||||
(send text erase)
|
||||
(send text insert ,(buff-spec-string before))
|
||||
(send text set-position ,(buff-spec-start before) ,(buff-spec-end before))
|
||||
(test:keystroke ',(car key) ',(cdr key))
|
||||
(vector (send text get-text)
|
||||
(send text get-start-position)
|
||||
(send text get-end-position))))))])
|
||||
(for-each process-key keys)))
|
||||
|
||||
(define (test-specs frame-name frame-class specs)
|
||||
(printf "test-specs.1\n")
|
||||
(send-sexp-to-mred `(send (make-object ,frame-class ,frame-name) show #t))
|
||||
(printf "test-specs.2\n")
|
||||
(wait-for-frame frame-name)
|
||||
(printf "test-specs.3\n")
|
||||
(for-each test-key specs)
|
||||
(printf "test-specs.4\n")
|
||||
(send-sexp-to-mred `(send (get-top-level-focus-window) close))
|
||||
(printf "test-specs.5\n"))
|
||||
|
||||
(test-specs "global keybingings test" 'frame:text% global-specs)
|
||||
(test-specs "scheme mode keybindings test"
|
||||
'(class frame:editor%
|
||||
(define/override (get-editor%) scheme:text%)
|
||||
(super-new))
|
||||
scheme-specs))
|
||||
|
||||
(test-canonicalize 1 "c:a" "c:a")
|
||||
(test-canonicalize 2 "d:a" "d:a")
|
||||
(test-canonicalize 3 "m:a" "m:a")
|
||||
(test-canonicalize 4 "a:a" "a:a")
|
||||
(test-canonicalize 5 "s:a" "s:a")
|
||||
(test-canonicalize 6 "c:a" "c:a")
|
||||
(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")
|
||||
|
||||
(include "key-specs.ss")
|
||||
|
||||
(send-sexp-to-mred `(send (make-object frame:basic% "dummy to trick frame group") show #t))
|
||||
(wait-for-frame "dummy to trick frame group")
|
||||
|
||||
(define (test-key key-spec)
|
||||
(let* ([keys ((case (system-type)
|
||||
[(macos) key-spec-macos]
|
||||
[(unix) key-spec-unix]
|
||||
[(windows) key-spec-windows])
|
||||
key-spec)]
|
||||
[before (key-spec-before key-spec)]
|
||||
[after (key-spec-after key-spec)]
|
||||
[process-key
|
||||
(lambda (key)
|
||||
(let ([text-expect (buff-spec-string after)]
|
||||
[start-expect (buff-spec-start after)]
|
||||
[end-expect (buff-spec-end after)])
|
||||
(test key
|
||||
(lambda (x) (equal? x (vector text-expect start-expect end-expect)))
|
||||
`(let* ([text (send (get-top-level-focus-window) get-editor)])
|
||||
(send text erase)
|
||||
(send text insert ,(buff-spec-string before))
|
||||
(send text set-position ,(buff-spec-start before) ,(buff-spec-end before))
|
||||
(test:keystroke ',(car key) ',(cdr key))
|
||||
(vector (send text get-text)
|
||||
(send text get-start-position)
|
||||
(send text get-end-position))))))])
|
||||
(for-each process-key keys)))
|
||||
|
||||
(define (test-specs frame-name frame-class specs)
|
||||
(send-sexp-to-mred `(send (make-object ,frame-class ,frame-name) show #t))
|
||||
(wait-for-frame frame-name)
|
||||
(for-each test-key specs)
|
||||
(send-sexp-to-mred `(send (get-top-level-focus-window) close)))
|
||||
|
||||
(test-specs "global keybingings test" 'frame:text% global-specs)
|
||||
(test-specs "scheme mode keybindings test"
|
||||
'(class frame:editor% (name)
|
||||
(override
|
||||
[get-editor%
|
||||
(lambda ()
|
||||
(scheme:text-mixin text:basic%))])
|
||||
(sequence (super-init name)))
|
||||
scheme-specs)
|
||||
|
||||
)
|
||||
|
|
|
|||
|
|
@ -1,7 +1,8 @@
|
|||
(module main mzscheme
|
||||
(require (lib "launcher.ss" "launcher")
|
||||
(lib "cmdline.ss")
|
||||
(lib "unitsig.ss")
|
||||
(lib "list.ss")
|
||||
(lib "unitsig.ss")
|
||||
"debug.ss"
|
||||
"test-suite-utils.ss")
|
||||
|
||||
|
|
@ -50,31 +51,33 @@
|
|||
(debug-printf admin " backup preferences file exists, using that one~n")
|
||||
(begin (copy-file preferences-file old-preferences-file)
|
||||
(debug-printf admin " saved preferences file~n"))))
|
||||
|
||||
(with-handlers ([(lambda (x) #f)
|
||||
(lambda (x) (display (exn-message x)) (newline))])
|
||||
(for-each
|
||||
(lambda (x)
|
||||
(when (member x all-files)
|
||||
(shutdown-mred)
|
||||
(load-framework-automatically #t)
|
||||
(let/ec k
|
||||
(dynamic-wind
|
||||
(lambda ()
|
||||
(set-section-name! x)
|
||||
(set-section-jump! k))
|
||||
(lambda ()
|
||||
(with-handlers ([(lambda (x) #t)
|
||||
(lambda (exn)
|
||||
(debug-printf schedule "~a~n" (if (exn? exn) (exn-message exn) exn)))])
|
||||
|
||||
(debug-printf schedule "beginning ~a test suite~n" x)
|
||||
(dynamic-require `(lib ,x "tests" "framework") #f)
|
||||
(debug-printf schedule "PASSED ~a test suite~n" x)))
|
||||
(lambda ()
|
||||
(reset-section-name!)
|
||||
(reset-section-jump!))))))
|
||||
files-to-process))
|
||||
|
||||
(define jumped-out-tests '())
|
||||
|
||||
(for-each
|
||||
(lambda (x)
|
||||
(when (member x all-files)
|
||||
(shutdown-mred)
|
||||
(load-framework-automatically #t)
|
||||
(let/ec k
|
||||
(dynamic-wind
|
||||
(lambda ()
|
||||
(set! jumped-out-tests (cons x jumped-out-tests))
|
||||
(set-section-name! x)
|
||||
(set-section-jump! k))
|
||||
(lambda ()
|
||||
(with-handlers ([(lambda (x) #t)
|
||||
(lambda (exn)
|
||||
(debug-printf schedule "~a~n" (if (exn? exn) (exn-message exn) exn)))])
|
||||
|
||||
(debug-printf schedule "beginning ~a test suite~n" x)
|
||||
(dynamic-require `(lib ,x "tests" "framework") #f)
|
||||
(set! jumped-out-tests (remq x jumped-out-tests))
|
||||
(debug-printf schedule "PASSED ~a test suite~n" x)))
|
||||
(lambda ()
|
||||
(reset-section-name!)
|
||||
(reset-section-jump!))))))
|
||||
files-to-process)
|
||||
|
||||
(debug-printf admin " restoring preferences file ~s to ~s~n" old-preferences-file preferences-file)
|
||||
(when (file-exists? preferences-file)
|
||||
|
|
@ -88,10 +91,12 @@
|
|||
(shutdown-listener)
|
||||
|
||||
(cond
|
||||
[(null? failed-tests)
|
||||
(printf "All tests passed.~n")]
|
||||
[else
|
||||
(debug-printf schedule "FAILED tests:~n")
|
||||
(for-each (lambda (failed-test)
|
||||
(debug-printf schedule " ~a // ~a~n" (car failed-test) (cdr failed-test)))
|
||||
failed-tests)]))
|
||||
[(not (null? jumped-out-tests))
|
||||
(printf "Test suites ended with exns ~s\n" jumped-out-tests)]
|
||||
[(null? failed-tests)
|
||||
(printf "All tests passed.~n")]
|
||||
[else
|
||||
(debug-printf schedule "FAILED tests:~n")
|
||||
(for-each (lambda (failed-test)
|
||||
(debug-printf schedule " ~a // ~a~n" (car failed-test) (cdr failed-test)))
|
||||
failed-tests)]))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user