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

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

@ -129,68 +129,66 @@
'()))))) '())))))
(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
(or user-key? ;; for key release events -- is this a problem? (we'll find out!)
(super on-subwindow-char receiver event)))) (or user-key?
(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<%>) (define short-cut (send item get-shortcut))
(let ([short-cut (send item get-shortcut)]) (when short-cut
(when short-cut (define keyname
(let ([keyname (string->symbol
(string->symbol (keymap:canonicalize-keybinding-string
(keymap:canonicalize-keybinding-string (string-append
(string-append (menu-item->prefix-string item)
(menu-item->prefix-string item) (case short-cut
(case short-cut [(#\;) "semicolon"]
[(#\;) "semicolon"] [(#\:) "colon"]
[(#\:) "colon"] [(#\space) "space"]
[(#\space) "space"] [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))) (when (eq? (system-type) 'windows)
(send menu-container get-items))) (for ([top-level-menu (in-list (send (get-menu-bar) get-items))])
(when (eq? (system-type) 'windows) (when (is-a? top-level-menu menu%)
(for-each (λ (top-level-menu) (define amp-key
(when (is-a? top-level-menu menu%) (let loop ([str (send top-level-menu get-label)])
(let ([amp-key (cond
(let loop ([str (send top-level-menu get-label)]) [(regexp-match #rx"[^&]*[&](.)(.*)" str)
(cond =>
[(regexp-match #rx"[^&]*[&](.)(.*)" str) (λ (m)
=> (define this-amp (list-ref m 1))
(λ (m) (define rest (list-ref m 2))
(let ([this-amp (list-ref m 1)] (cond
[rest (list-ref m 2)]) [(equal? this-amp "&")
(cond (loop rest)]
[(equal? this-amp "&") [else
(loop rest)] (string-downcase this-amp)]))]
[else [else #f])))
(string-downcase this-amp)])))] (when amp-key
[else #f]))]) (hash-set! name-ht
(when amp-key (format "m:~a" amp-key)
(hash-set! name-ht (format "~a menu" (send top-level-menu get-plain-label)))
(format "m:~a" amp-key) (hash-set! name-ht
(format "~a menu" (send top-level-menu get-plain-label))) (format "m:s:~a" amp-key)
(hash-set! name-ht (format "~a menu" (send top-level-menu get-plain-label)))))))
(format "m:s:~a" amp-key) name-ht)
(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) (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,72 +303,71 @@
(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 (λ (keybindings-menu)
(λ (keybindings-menu) (for-each (λ (old) (send old delete))
(for-each (λ (old) (send old delete)) (send keybindings-menu get-items))
(send keybindings-menu get-items)) (new menu-item%
(new menu-item% (parent keybindings-menu)
(parent keybindings-menu) (label (string-constant keybindings-show-active))
(label (string-constant keybindings-show-active)) (callback (λ (x y) (show-keybindings)))
(callback (λ (x y) (show-keybindings))) (help-string (string-constant keybindings-info))
(help-string (string-constant keybindings-info)) (demand-callback keybindings-on-demand))
(demand-callback keybindings-on-demand)) (new menu-item%
(new menu-item% (parent keybindings-menu)
(parent keybindings-menu) (label (string-constant keybindings-add-user-defined-keybindings))
(label (string-constant keybindings-add-user-defined-keybindings)) (callback
(callback (λ (x y)
(λ (x y) (with-handlers ([exn? (λ (x)
(with-handlers ([exn? (λ (x) (printf "~a\n" (exn-message x)))])
(printf "~a\n" (exn-message x)))]) (let ([filename (finder:get-file
(let ([filename (finder:get-file #f
#f (string-constant keybindings-choose-user-defined-file)
(string-constant keybindings-choose-user-defined-file) #f
#f ""
"" this)])
this)]) (when filename
(when filename (add-keybindings-item/update-prefs filename)))))))
(add-keybindings-item/update-prefs filename))))))) (new menu-item%
(new menu-item% (parent keybindings-menu)
(parent keybindings-menu) (label (string-constant keybindings-add-user-defined-keybindings/planet))
(label (string-constant keybindings-add-user-defined-keybindings/planet)) (callback
(callback (λ (x y)
(λ (x y) (define planet-spec
(let ([planet-spec (get-text-from-user (string-constant drscheme) (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
[(planet-string-spec? planet-spec) [(planet-string-spec? planet-spec)
=> =>
(λ (planet-sexp-spec) (λ (planet-sexp-spec)
(add-keybindings-item/update-prefs planet-sexp-spec))] (add-keybindings-item/update-prefs planet-sexp-spec))]
[else [else
(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)
(path->string item) (path->string item)
(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]