...
original commit: 474384e087e736c55ace56ae1b4ef342b686b6f5
This commit is contained in:
parent
a888199ce3
commit
dc8723de7e
|
@ -221,6 +221,8 @@
|
|||
aug-keymap%
|
||||
aug-keymap<%>
|
||||
|
||||
canonicalize-keybinding-string
|
||||
|
||||
setup-global
|
||||
setup-search
|
||||
setup-file
|
||||
|
|
|
@ -5,11 +5,15 @@
|
|||
[finder : framework:finder^]
|
||||
[handler : framework:handler^]
|
||||
[scheme-paren : framework:scheme-paren^]
|
||||
[frame : framework:frame^])
|
||||
[frame : framework:frame^]
|
||||
[mzlib:function : mzlib:function^])
|
||||
|
||||
(rename [-get-file get-file])
|
||||
|
||||
(define aug-keymap<%> (interface () get-chained-keymaps get-map-function-table))
|
||||
(define aug-keymap<%> (interface ()
|
||||
get-chained-keymaps
|
||||
get-map-function-table
|
||||
get-map-function-table/ht))
|
||||
|
||||
(define aug-keymap%
|
||||
(class* keymap% (aug-keymap<%>) args
|
||||
|
@ -41,25 +45,127 @@
|
|||
(public
|
||||
[get-map-function-table
|
||||
(lambda ()
|
||||
(let ([table (make-hash-table)])
|
||||
(hash-table-for-each
|
||||
function-table
|
||||
(lambda (keyname fname) (hash-table-put! table keyname fname)))
|
||||
(for-each
|
||||
(lambda (chained-keymap)
|
||||
(when (is-a? chained-keymap aug-keymap<%>)
|
||||
(hash-table-for-each
|
||||
(send chained-keymap get-map-function-table)
|
||||
(lambda (keyname fname)
|
||||
(unless (hash-table-get table keyname (lambda () #f))
|
||||
(hash-table-put! table keyname fname))))))
|
||||
chained-keymaps)
|
||||
table))])
|
||||
(get-map-function-table/ht (make-hash-table)))]
|
||||
|
||||
[get-map-function-table/ht
|
||||
(lambda (table)
|
||||
(hash-table-for-each
|
||||
function-table
|
||||
(lambda (keyname fname)
|
||||
(unless (hash-table-get table keyname (lambda () #f))
|
||||
(hash-table-put! table keyname fname))))
|
||||
(for-each
|
||||
(lambda (chained-keymap)
|
||||
(when (is-a? chained-keymap aug-keymap<%>)
|
||||
(send chained-keymap get-map-function-table/ht table)))
|
||||
chained-keymaps)
|
||||
table)])
|
||||
|
||||
(sequence
|
||||
(apply super-init args))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;;;;;; ;;;;;;;;
|
||||
;;;;;;; canonicalize ;;;;;;;;
|
||||
;;;;;;; ;;;;;;;;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;; canonicalize-keybinding-string : string -> string
|
||||
;; The result can be used with string=? to determine
|
||||
;; if two key bindings refer to the same key.
|
||||
;; Assumes a well-formed keystring.
|
||||
(define (canonicalize-keybinding-string str)
|
||||
(let* ([chars (string->list str)]
|
||||
[separated-keys
|
||||
(map
|
||||
canonicalize-single-keybinding-string
|
||||
(split-out #\; chars))])
|
||||
(join-strings ";" separated-keys)))
|
||||
|
||||
;; join-strings : string (listof string) -> string
|
||||
;; concatenates strs with sep between each of them
|
||||
(define (join-strings sep strs)
|
||||
(if (null? strs)
|
||||
""
|
||||
(apply
|
||||
string-append
|
||||
(cons
|
||||
(car strs)
|
||||
(let loop ([keys (cdr strs)])
|
||||
(cond
|
||||
[(null? keys) null]
|
||||
[else (list* sep
|
||||
(car keys)
|
||||
(loop (cdr keys)))]))))))
|
||||
|
||||
;; canonicalize-single-keybinding-string : (listof char) -> string
|
||||
(define (canonicalize-single-keybinding-string chars)
|
||||
(let* ([neg? (char=? (car chars) #\:)]
|
||||
[mods/key (split-out #\: (if neg? (cdr chars) chars))]
|
||||
[mods
|
||||
(let loop ([mods mods/key])
|
||||
(cond
|
||||
[(null? mods) null]
|
||||
[(null? (cdr mods)) null]
|
||||
[else (cons (car mods) (loop (cdr mods)))]))]
|
||||
[key (cdr (mzlib:function:last-pair mods/key))]
|
||||
[shift (if neg? #f 'd/c)]
|
||||
[control (if neg? #f 'd/c)]
|
||||
[alt (if neg? #f 'd/c)]
|
||||
[meta (if neg? #f 'd/c)]
|
||||
[command (if neg? #f 'd/c)]
|
||||
|
||||
[do-key
|
||||
(lambda (char val)
|
||||
(cond
|
||||
[(eq? val #t) (string char)]
|
||||
[(eq? val #f) (string #\~ char)]
|
||||
[(eq? val 'd/c) ""]))])
|
||||
|
||||
(for-each (lambda (mod)
|
||||
(let ([val (not (char=? (car mod) #\~))])
|
||||
(case (if (char=? (car mod) #\~)
|
||||
(cadr mod)
|
||||
(car mod))
|
||||
[(#\s) (set! shift val)]
|
||||
[(#\c) (set! control val)]
|
||||
[(#\a) (set! alt val)]
|
||||
[(#\d) (set! command val)]
|
||||
[(#\m) (set! meta val)])))
|
||||
mods)
|
||||
(join-strings #\: (list
|
||||
(do-key #\a alt)
|
||||
(do-key #\c control)
|
||||
(do-key #\d command)
|
||||
(do-key #\m meta)
|
||||
(do-key #\s shift)
|
||||
(apply string-append key)))))
|
||||
|
||||
;; split-out : char (listof char) -> (listof (listof char))
|
||||
;; splits a list of characters at its first argument
|
||||
(define (split-out split-char chars)
|
||||
(let loop ([chars chars]
|
||||
[this-split null]
|
||||
[all-split null])
|
||||
(cond
|
||||
[(null? chars) (reverse all-split)]
|
||||
[else (let ([char (car chars)])
|
||||
(cond
|
||||
[(char=? split-char chars)
|
||||
(loop (cdr chars)
|
||||
null
|
||||
(cons (reverse this-split) all-split))]
|
||||
[else
|
||||
(loop (cdr chars)
|
||||
(cons char this-split)
|
||||
all-split)]))])))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;;;;;; ;;;;;;;;
|
||||
;;;;;;; end canonicalize ;;;;;;;;
|
||||
;;;;;;; ;;;;;;;;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (make-meta-prefix-list key)
|
||||
(list (string-append "m:" key)
|
||||
(string-append "ESC;" key)))
|
||||
|
|
|
@ -882,14 +882,18 @@
|
|||
(send keymap map-function key func))])
|
||||
|
||||
(map-meta "up" "up-sexp")
|
||||
(map-meta "c:u" "up-sexp")
|
||||
(map "a:up" "up-sexp")
|
||||
(map-meta "s:up" "select-up-sexp")
|
||||
(map "a:s:up" "select-up-sexp")
|
||||
(map-meta "s:c:u" "select-up-sexp")
|
||||
|
||||
(map-meta "down" "down-sexp")
|
||||
(map "a:down" "down-sexp")
|
||||
(map-meta "c:down" "down-sexp")
|
||||
(map-meta "s:down" "select-down-sexp")
|
||||
(map "a:s:down" "select-down-sexp")
|
||||
(map-meta "s:c:down" "down-sexp")
|
||||
|
||||
(map-meta "right" "forward-sexp")
|
||||
(map "a:right" "forward-sexp")
|
||||
|
@ -920,9 +924,6 @@
|
|||
(map-meta "c:b" "backward-sexp")
|
||||
(map-meta "s:c:b" "select-backward-sexp")
|
||||
|
||||
;(map-meta "c:u" "up-sexp")
|
||||
;(map-meta "c:d" "down-sexp")
|
||||
|
||||
(map-meta "c:p" "flash-backward-sexp")
|
||||
(map-meta "s:c:n" "flash-forward-sexp")
|
||||
|
||||
|
|
|
@ -1,11 +1,86 @@
|
|||
(begin-elaboration-time (current-load-relative-directory
|
||||
"Cupertino:robby:plt:collects:tests:framework")
|
||||
(printf "3 curr-dir ~a curr-load-dir ~a~n"
|
||||
(current-directory)
|
||||
(current-load-relative-directory)))
|
||||
(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))
|
||||
(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) key-spec-macos]
|
||||
|
@ -31,14 +106,11 @@
|
|||
(send text get-end-position))))))])
|
||||
(for-each process-key keys)))
|
||||
|
||||
(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-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 `(test:close-frame (get-top-level-focus-window))))
|
||||
(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"
|
||||
|
|
|
@ -358,11 +358,11 @@
|
|||
(import (P : (program))
|
||||
(A : (argv)))
|
||||
(link
|
||||
[L : launcher-maker^ ((require-library "launcherr.ss" "launcher"))]
|
||||
[C : mzlib:core^ ((require-library "corer.ss"))]
|
||||
[core : mzlib:core^ ((require-library "corer.ss"))]
|
||||
[launcher : launcher-maker^ ((require-library "launcherr.ss" "launcher") (core file))]
|
||||
[M : mzlib:command-line^ ((require-library "cmdliner.ss"))]
|
||||
[T : internal-TestSuite^ (TestSuite P E L (C pretty-print) (C function))]
|
||||
[E : Engine^ (Engine A T M (C function) (C file) (C string) (C pretty-print))])
|
||||
[T : internal-TestSuite^ (TestSuite P E launcher (core pretty-print) (core function))]
|
||||
[E : Engine^ (Engine A T M (core function) (core file) (core string) (core pretty-print))])
|
||||
(export))
|
||||
(program)
|
||||
(argv))
|
||||
|
|
Loading…
Reference in New Issue
Block a user