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

Rackety

Browse Source
This commit is contained in:
Robby Findler 2013-11-10 21:05:33 -06:00
parent cda5c12f6c
commit ad234e1e33
1 changed files with 137 additions and 138 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

85
pkgs/drracket-pkgs/drracket/drracket/private/frame.rkt
View File

@ -129,26 +129,26 @@
'()))))) '())))))
(define/override (on-subwindow-char receiver event) (define/override (on-subwindow-char receiver event)
(let ([user-key? (send (keymap:get-user) (define user-key? (send (keymap:get-user)
handle-key-event handle-key-event
(if (is-a? receiver editor-canvas%) (if (is-a? receiver editor-canvas%)
(send receiver get-editor) (send receiver get-editor)
receiver) receiver)
event)]) event))
;; (printf "user-key? ~s\n" user-key?) returns #t for key release events -- is this a problem? (we'll find out!) ;; (printf "user-key? ~s\n" user-key?) returns #t
;; for key release events -- is this a problem? (we'll find out!)
(or user-key? (or user-key?
(super on-subwindow-char receiver event)))) (super on-subwindow-char receiver event)))
(inherit get-edit-target-window get-edit-target-object get-menu-bar) (inherit get-edit-target-window get-edit-target-object get-menu-bar)
(define/private (get-menu-bindings) (define/private (get-menu-bindings)
(let ([name-ht (make-hasheq)]) (define name-ht (make-hasheq))
(let loop ([menu-container (get-menu-bar)]) (let loop ([menu-container (get-menu-bar)])
(for-each (for ([item (in-list (send menu-container get-items))])
(λ (item)
(when (is-a? item selectable-menu-item<%>) (when (is-a? item selectable-menu-item<%>)
(let ([short-cut (send item get-shortcut)]) (define short-cut (send item get-shortcut))
(when short-cut (when short-cut
(let ([keyname (define keyname
(string->symbol (string->symbol
(keymap:canonicalize-keybinding-string (keymap:canonicalize-keybinding-string
(string-append (string-append
@ -160,28 +160,27 @@
[else [else
(cond (cond
[(symbol? short-cut) (symbol->string short-cut)] [(symbol? short-cut) (symbol->string short-cut)]
[(char? short-cut) (string short-cut)])]))))]) [(char? short-cut) (string short-cut)])])))))
(hash-set! name-ht keyname (send item get-plain-label)))))) (hash-set! name-ht keyname (send item get-plain-label))))
(when (is-a? item menu-item-container<%>) (when (is-a? item menu-item-container<%>)
(loop item))) (loop item))))
(send menu-container get-items)))
(when (eq? (system-type) 'windows) (when (eq? (system-type) 'windows)
(for-each (λ (top-level-menu) (for ([top-level-menu (in-list (send (get-menu-bar) get-items))])
(when (is-a? top-level-menu menu%) (when (is-a? top-level-menu menu%)
(let ([amp-key (define amp-key
(let loop ([str (send top-level-menu get-label)]) (let loop ([str (send top-level-menu get-label)])
(cond (cond
[(regexp-match #rx"[^&]*[&](.)(.*)" str) [(regexp-match #rx"[^&]*[&](.)(.*)" str)
=> =>
(λ (m) (λ (m)
(let ([this-amp (list-ref m 1)] (define this-amp (list-ref m 1))
[rest (list-ref m 2)]) (define rest (list-ref m 2))
(cond (cond
[(equal? this-amp "&") [(equal? this-amp "&")
(loop rest)] (loop rest)]
[else [else
(string-downcase this-amp)])))] (string-downcase this-amp)]))]
[else #f]))]) [else #f])))
(when amp-key (when amp-key
(hash-set! name-ht (hash-set! name-ht
(format "m:~a" amp-key) (format "m:~a" amp-key)
@ -189,8 +188,7 @@
(hash-set! name-ht (hash-set! name-ht
(format "m:s:~a" amp-key) (format "m:s:~a" amp-key)
(format "~a menu" (send top-level-menu get-plain-label))))))) (format "~a menu" (send top-level-menu get-plain-label)))))))
(send (get-menu-bar) get-items))) name-ht)
name-ht))
(define/private (menu-item->prefix-string item) (define/private (menu-item->prefix-string item)
(apply (apply
@ -209,18 +207,17 @@
(send item get-shortcut-prefix)))) (send item get-shortcut-prefix))))
(define/private (copy-hash-table ht) (define/private (copy-hash-table ht)
(let ([res (make-hasheq)]) (define res (make-hasheq))
(hash-for-each (for ([(x y) (in-hash ht)])
ht (hash-set! res x y))
(λ (x y) (hash-set! res x y))) res)
res))
(define/private (can-show-keybindings?) (define/private (can-show-keybindings?)
(let ([edit-object (get-edit-target-object)]) (define edit-object (get-edit-target-object))
(and edit-object (and edit-object
(is-a? edit-object editor<%>) (is-a? edit-object editor<%>)
(let ([keymap (send edit-object get-keymap)]) (let ([keymap (send edit-object get-keymap)])
(is-a? keymap keymap:aug-keymap<%>))))) (is-a? keymap keymap:aug-keymap<%>))))
;; pre: (can-show-keybindings?) = #t ;; pre: (can-show-keybindings?) = #t
(define/private (get-keybindings-to-show) (define/private (get-keybindings-to-show)
@ -277,7 +274,8 @@
(λ (item evt) (λ (item evt)
(install-pkg this (install-pkg this
(lambda (thunk) (lambda (thunk)
(parameterize ([error-display-handler drracket:init:original-error-display-handler]) (parameterize ([error-display-handler
drracket:init:original-error-display-handler])
(thunk)))))]) (thunk)))))])
(new separator-menu-item% [parent file-menu]) (new separator-menu-item% [parent file-menu])
(new menu-item% (new menu-item%
@ -286,7 +284,8 @@
[callback [callback
(λ (item evt) (λ (item evt)
(pkg-manager (lambda (thunk) (pkg-manager (lambda (thunk)
(parameterize ([error-display-handler drracket:init:original-error-display-handler]) (parameterize ([error-display-handler
drracket:init:original-error-display-handler])
(thunk)))))]) (thunk)))))])
(super file-menu:between-open-and-revert file-menu)) (super file-menu:between-open-and-revert file-menu))
@ -304,11 +303,10 @@
(super edit-menu:between-find-and-preferences menu) (super edit-menu:between-find-and-preferences menu)
(when (current-eventspace-has-standard-menus?) (when (current-eventspace-has-standard-menus?)
(new separator-menu-item% [parent menu])) (new separator-menu-item% [parent menu]))
(let ([keybindings-on-demand (define (keybindings-on-demand menu-item)
(λ (menu-item) (define last-edit-object (get-edit-target-window))
(let ([last-edit-object (get-edit-target-window)]) (send menu-item enable (can-show-keybindings?)))
(send menu-item enable (can-show-keybindings?))))]) (new menu%
(instantiate menu% ()
(label (string-constant keybindings-menu-item)) (label (string-constant keybindings-menu-item))
(parent menu) (parent menu)
(demand-callback (demand-callback
@ -341,10 +339,11 @@
(label (string-constant keybindings-add-user-defined-keybindings/planet)) (label (string-constant keybindings-add-user-defined-keybindings/planet))
(callback (callback
(λ (x y) (λ (x y)
(let ([planet-spec (get-text-from-user (string-constant drscheme) (define planet-spec
(get-text-from-user (string-constant drscheme)
(string-constant keybindings-type-planet-spec) (string-constant keybindings-type-planet-spec)
this this
last-keybindings-planet-attempt)]) last-keybindings-planet-attempt))
(when planet-spec (when planet-spec
(set! last-keybindings-planet-attempt planet-spec) (set! last-keybindings-planet-attempt planet-spec)
(cond (cond
@ -356,11 +355,11 @@
(message-box (string-constant drscheme) (message-box (string-constant drscheme)
(format (string-constant keybindings-planet-malformed-spec) (format (string-constant keybindings-planet-malformed-spec)
planet-spec) planet-spec)
#:dialog-mixin frame:focus-table-mixin)])))))) #:dialog-mixin frame:focus-table-mixin)])))))
(let ([ud (preferences:get 'drracket:user-defined-keybindings)]) (define ud (preferences:get 'drracket:user-defined-keybindings))
(unless (null? ud) (unless (null? ud)
(new separator-menu-item% (parent keybindings-menu)) (new separator-menu-item% (parent keybindings-menu))
(for-each (λ (item) (for ([item (in-list ud)])
(new menu-item% (new menu-item%
(label (format (string-constant keybindings-menu-remove) (label (format (string-constant keybindings-menu-remove)
(if (path? item) (if (path? item)
@ -368,8 +367,7 @@
(format "~s" item)))) (format "~s" item))))
(parent keybindings-menu) (parent keybindings-menu)
(callback (callback
(λ (x y) (remove-keybindings-item item))))) (λ (x y) (remove-keybindings-item item)))))))))
ud)))))))
(unless (current-eventspace-has-standard-menus?) (unless (current-eventspace-has-standard-menus?)
(make-object separator-menu-item% menu))) (make-object separator-menu-item% menu)))
@ -899,7 +897,8 @@
[label (brinfo-title a-brinfo)] [label (brinfo-title a-brinfo)]
[callback [callback
(λ (x y) (λ (x y)
(help-desk:report-bug (brinfo-id a-brinfo) #:frame-mixin basics-mixin))])) (help-desk:report-bug (brinfo-id a-brinfo)
#:frame-mixin basics-mixin))]))
(new separator-menu-item% [parent saved-bug-reports-menu]) (new separator-menu-item% [parent saved-bug-reports-menu])
(new menu-item% (new menu-item%
[parent saved-bug-reports-menu] [parent saved-bug-reports-menu]