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

fixed up code that populates the keybindings menu, added more bindings for the greek letters

Browse Source 
svn: r7486
This commit is contained in:
Robby Findler 2007-10-11 13:00:57 +00:00
parent 6d36cf0439
commit 2b6bcf6025
2 changed files with 82 additions and 29 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

63
collects/drscheme/private/frame.ss
View File

@ -49,12 +49,36 @@
[(#\;) "semicolon"]
[(#\:) "colon"]
[(#\space) "space"]
[else
(string short-cut)]))))])
[else (string short-cut)]))))])
(hash-table-put! name-ht keyname (send item get-plain-label))))))
(when (is-a? item menu-item-container<%>)
(loop item)))
(send menu-container get-items)))
(when (eq? (system-type) 'windows)
(for-each (λ (top-level-menu)
(when (is-a? top-level-menu menu%)
(let ([amp-key
(let loop ([str (send top-level-menu get-label)])
(cond
[(regexp-match #rx"[^&]*[&](.)(.*)" str)
=>
(λ (m)
(let ([this-amp (list-ref m 1)]
[rest (list-ref m 2)])
(cond
[(equal? this-amp "&")
(loop rest)]
[else
(string-downcase this-amp)])))]
[else #f]))])
(when amp-key
(hash-table-put! name-ht
(format "m:~a" amp-key)
(format "~a menu" (send top-level-menu get-plain-label)))
(hash-table-put! name-ht
(format "m:s:~a" amp-key)
(format "~a menu" (send top-level-menu get-plain-label)))))))
(send (get-menu-bar) get-items)))
name-ht))
(define/private (menu-item->prefix-string item)
@ -87,24 +111,23 @@
(let ([keymap (send edit-object get-keymap)])
(is-a? keymap keymap:aug-keymap<%>)))))]
[define/private show-keybindings
(λ ()
(if (can-show-keybindings?)
(let ([edit-object (get-edit-target-object)])
(let ([keymap (send edit-object get-keymap)])
(let* ([menu-names (get-menu-bindings)]
[table (send keymap get-map-function-table)]
[bindings (hash-table-map table list)]
[w/menus
(append (hash-table-map menu-names list)
(filter (λ (binding) (not (bound-by-menu? binding menu-names)))
bindings))]
[structured-list
(mzlib:list:sort
w/menus
(λ (x y) (string-ci<=? (cadr x) (cadr y))))])
(show-keybindings-to-user structured-list this))))
(bell)))]
[define/private (show-keybindings)
(if (can-show-keybindings?)
(let* ([edit-object (get-edit-target-object)]
[keymap (send edit-object get-keymap)]
[menu-names (get-menu-bindings)]
[table (send keymap get-map-function-table)]
[bindings (hash-table-map table list)]
[w/menus
(append (hash-table-map menu-names list)
(filter (λ (binding) (not (bound-by-menu? binding menu-names)))
bindings))]
[structured-list
(mzlib:list:sort
w/menus
(λ (x y) (string-ci<=? (cadr x) (cadr y))))])
(show-keybindings-to-user structured-list this))
(bell))]
(define/private (bound-by-menu? binding menu-table)
(ormap (λ (constituent)

48
collects/framework/private/keymap.ss
View File

@ -128,15 +128,9 @@
function-table
(λ (keyname fname)
(unless (hash-table-get table keyname (λ () #f))
(cond
[(and (eq? (system-type) 'windows)
(let ([cs (canonicalize-keybinding-string (format "~a" keyname))])
(or (regexp-match #rx"a:c" cs)
(regexp-match #rx"c:m" cs))))
(void) ;; don't show these keybindigns -- they don't work
]
[else
(hash-table-put! table keyname fname)]))))
(let ([cs (canonicalize-keybinding-string (format "~a" keyname))])
(when (on-this-platform? cs)
(hash-table-put! table keyname fname))))))
(for-each
(λ (chained-keymap)
(when (is-a? chained-keymap aug-keymap<%>)
@ -144,6 +138,38 @@
chained-keymaps)
table)
(define/private (on-this-platform? cs)
(let* ([splits (map (λ (x) (all-but-last (split-out #\: x))) (split-out #\; (string->list cs)))]
[has-key? (λ (k) (ormap (λ (x) (member (list k) x)) splits))])
(cond
[(eq? (system-type) 'windows)
(cond
[(or (regexp-match #rx"a:c" cs)
(regexp-match #rx"c:m" cs))
#f]
[(or (has-key? #\a) (has-key? #\d))
#f]
[else #t])]
[(eq? (system-type) 'macosx)
(cond
[(has-key? #\m)
#f]
[else #t])]
[(eq? (system-type) 'unix)
(cond
[(or (has-key? #\a) (has-key? #\d))
#f]
[else #t])]
[else
;; just in case new platforms come along ....
#t])))
(define/private (all-but-last l)
(cond
[(null? l) l]
[(null? (cdr l)) l]
[else (cons (car l) (all-but-last (cdr l)))]))
(super-new)))
(define aug-keymap% (aug-keymap-mixin keymap%))
@ -1023,6 +1049,10 @@
(if shift? "s:" "")
roman-char)
(format "insert ~a" greek-char))
(map (format "m:x;c:g;~a~a"
(if shift? "s:" "")
roman-char)
(format "insert ~a" greek-char))
(map (format "c:x;c:g;~a~a"
(if shift? "s:" "")
roman-char)