diff --git a/collects/mred/private/kernel.rkt b/collects/mred/private/kernel.rkt index 5680a68440..909d9f2a98 100644 --- a/collects/mred/private/kernel.rkt +++ b/collects/mred/private/kernel.rkt @@ -10,9 +10,6 @@ racket/class racket/draw) -(define (key-symbol-to-integer k) - (error 'key-symbol-to-integer "not yet implemented")) - (provide (all-from-out "wx/platform.rkt") clipboard<%> (all-from-out "wx/common/event.rkt" @@ -37,7 +34,6 @@ begin-busy-cursor is-busy? end-busy-cursor - key-symbol-to-integer application-file-handler application-quit-handler application-about-handler diff --git a/collects/mred/private/mrmenu.rkt b/collects/mred/private/mrmenu.rkt index 6c42f9ff79..2dbbac2751 100644 --- a/collects/mred/private/mrmenu.rkt +++ b/collects/mred/private/mrmenu.rkt @@ -183,7 +183,7 @@ (unless (or (not c) (char? c) (and (symbol? c) - (positive? (wx:key-symbol-to-integer c)))) + (wx:key-symbol-to-menu-key c))) (raise-type-error (who->name who) "character, key-code symbol, or #f" c))) (define (check-shortcut-prefix who p) @@ -259,7 +259,7 @@ (if (memq 'meta prefix) "Meta+" "") (if (memq 'alt prefix) "Alt+" "") (if (symbol? shortcut) - (string-titlecase (symbol->string shortcut)) + (wx:key-symbol-to-menu-key shortcut) (char-name (char-upcase shortcut) #t)))] @@ -273,7 +273,7 @@ (char->integer #\A))) (if (char? shortcut) (char->integer (char-upcase shortcut)) - (wx:key-symbol-to-integer shortcut)))])) + (wx:key-symbol-to-menu-key shortcut)))])) (strip-tab label))] [key-binding (and shortcut (let ([base (if (symbol? shortcut) diff --git a/collects/mred/private/wx/cocoa/keycode.rkt b/collects/mred/private/wx/cocoa/keycode.rkt index 7eb4d26fcc..da1f0338d9 100644 --- a/collects/mred/private/wx/cocoa/keycode.rkt +++ b/collects/mred/private/wx/cocoa/keycode.rkt @@ -1,6 +1,7 @@ #lang racket/base -(provide map-key-code) +(provide map-key-code + key-symbol-to-menu-key) (define (map-key-code v) (hash-ref @@ -54,3 +55,145 @@ (92 . numpad9)) v #f)) + +(define (key-symbol-to-menu-key k) + (hash-ref keysyms k #f)) + +(define keysyms + (let () + (define NSUpArrowFunctionKey #xF700) + (define NSDownArrowFunctionKey #xF701) + (define NSLeftArrowFunctionKey #xF702) + (define NSRightArrowFunctionKey #xF703) + (define NSF1FunctionKey #xF704) + (define NSF2FunctionKey #xF705) + (define NSF3FunctionKey #xF706) + (define NSF4FunctionKey #xF707) + (define NSF5FunctionKey #xF708) + (define NSF6FunctionKey #xF709) + (define NSF7FunctionKey #xF70A) + (define NSF8FunctionKey #xF70B) + (define NSF9FunctionKey #xF70C) + (define NSF10FunctionKey #xF70D) + (define NSF11FunctionKey #xF70E) + (define NSF12FunctionKey #xF70F) + (define NSF13FunctionKey #xF710) + (define NSF14FunctionKey #xF711) + (define NSF15FunctionKey #xF712) + (define NSF16FunctionKey #xF713) + (define NSF17FunctionKey #xF714) + (define NSF18FunctionKey #xF715) + (define NSF19FunctionKey #xF716) + (define NSF20FunctionKey #xF717) + (define NSF21FunctionKey #xF718) + (define NSF22FunctionKey #xF719) + (define NSF23FunctionKey #xF71A) + (define NSF24FunctionKey #xF71B) + (define NSF25FunctionKey #xF71C) + (define NSF26FunctionKey #xF71D) + (define NSF27FunctionKey #xF71E) + (define NSF28FunctionKey #xF71F) + (define NSF29FunctionKey #xF720) + (define NSF30FunctionKey #xF721) + (define NSF31FunctionKey #xF722) + (define NSF32FunctionKey #xF723) + (define NSF33FunctionKey #xF724) + (define NSF34FunctionKey #xF725) + (define NSF35FunctionKey #xF726) + (define NSInsertFunctionKey #xF727) + (define NSDeleteFunctionKey #xF728) + (define NSHomeFunctionKey #xF729) + (define NSBeginFunctionKey #xF72A) + (define NSEndFunctionKey #xF72B) + (define NSPageUpFunctionKey #xF72C) + (define NSPageDownFunctionKey #xF72D) + (define NSPrintScreenFunctionKey #xF72E) + (define NSScrollLockFunctionKey #xF72F) + (define NSPauseFunctionKey #xF730) + (define NSSysReqFunctionKey #xF731) + (define NSBreakFunctionKey #xF732) + (define NSResetFunctionKey #xF733) + (define NSStopFunctionKey #xF734) + (define NSMenuFunctionKey #xF735) + (define NSUserFunctionKey #xF736) + (define NSSystemFunctionKey #xF737) + (define NSPrintFunctionKey #xF738) + (define NSClearLineFunctionKey #xF739) + (define NSClearDisplayFunctionKey #xF73A) + (define NSInsertLineFunctionKey #xF73B) + (define NSDeleteLineFunctionKey #xF73C) + (define NSInsertCharFunctionKey #xF73D) + (define NSDeleteCharFunctionKey #xF73E) + (define NSPrevFunctionKey #xF73F) + (define NSNextFunctionKey #xF740) + (define NSSelectFunctionKey #xF741) + (define NSExecuteFunctionKey #xF742) + (define NSUndoFunctionKey #xF743) + (define NSRedoFunctionKey #xF744) + (define NSFindFunctionKey #xF745) + (define NSHelpFunctionKey #xF746) + (define NSModeSwitchFunctionKey #xF747) + + (hasheq + 'start NSResetFunctionKey + 'cancel NSStopFunctionKey + 'clear NSClearDisplayFunctionKey + 'menu NSMenuFunctionKey + 'pause NSPauseFunctionKey + 'prior NSPrevFunctionKey + 'next NSNextFunctionKey + 'end NSEndFunctionKey + 'home NSHomeFunctionKey + 'left NSLeftArrowFunctionKey + 'up NSUpArrowFunctionKey + 'right NSRightArrowFunctionKey + 'down NSDownArrowFunctionKey + 'escape 0 + 'select NSSelectFunctionKey + 'print NSPrintFunctionKey + 'execute NSExecuteFunctionKey + 'snapshot 0 + 'insert NSInsertFunctionKey + 'help NSHelpFunctionKey + 'numpad0 0 + 'numpad1 0 + 'numpad2 0 + 'numpad3 0 + 'numpad4 0 + 'numpad5 0 + 'numpad6 0 + 'numpad7 0 + 'numpad8 0 + 'numpad9 0 + 'numpad-enter 0 + 'multiply 0 + 'add 0 + 'separator 0 + 'subtract 0 + 'decimal 0 + 'divide 0 + 'f1 NSF1FunctionKey + 'f2 NSF2FunctionKey + 'f3 NSF3FunctionKey + 'f4 NSF4FunctionKey + 'f5 NSF5FunctionKey + 'f6 NSF6FunctionKey + 'f7 NSF7FunctionKey + 'f8 NSF8FunctionKey + 'f9 NSF9FunctionKey + 'f10 NSF10FunctionKey + 'f11 NSF11FunctionKey + 'f12 NSF12FunctionKey + 'f13 NSF13FunctionKey + 'f14 NSF14FunctionKey + 'f15 NSF15FunctionKey + 'f16 NSF16FunctionKey + 'f17 NSF17FunctionKey + 'f18 NSF18FunctionKey + 'f19 NSF19FunctionKey + 'f20 NSF20FunctionKey + 'f21 NSF21FunctionKey + 'f22 NSF22FunctionKey + 'f23 NSF23FunctionKey + 'f24 NSF24FunctionKey + 'scroll NSScrollLockFunctionKey))) diff --git a/collects/mred/private/wx/cocoa/platform.rkt b/collects/mred/private/wx/cocoa/platform.rkt index bd269af6f6..7b348428e8 100644 --- a/collects/mred/private/wx/cocoa/platform.rkt +++ b/collects/mred/private/wx/cocoa/platform.rkt @@ -85,4 +85,5 @@ get-highlight-text-color make-screen-bitmap make-gl-bitmap - check-for-break)) + check-for-break + key-symbol-to-menu-key)) diff --git a/collects/mred/private/wx/cocoa/procs.rkt b/collects/mred/private/wx/cocoa/procs.rkt index b3c12514f9..da2ca303f4 100644 --- a/collects/mred/private/wx/cocoa/procs.rkt +++ b/collects/mred/private/wx/cocoa/procs.rkt @@ -17,6 +17,7 @@ "menu-bar.rkt" "agl.rkt" "sound.rkt" + "keycode.rkt" "../../lock.rkt" "../common/handlers.rkt" (except-in "../common/default-procs.rkt" @@ -59,7 +60,8 @@ flush-display play-sound file-creator-and-type - file-selector) + file-selector + key-symbol-to-menu-key) (import-class NSScreen NSCursor) diff --git a/collects/mred/private/wx/gtk/keycode.rkt b/collects/mred/private/wx/gtk/keycode.rkt index ba967aeca0..2f70483248 100644 --- a/collects/mred/private/wx/gtk/keycode.rkt +++ b/collects/mred/private/wx/gtk/keycode.rkt @@ -1,6 +1,7 @@ #lang racket/base -(provide map-key-code) +(provide map-key-code + key-symbol-to-menu-key) (define (map-key-code v) (hash-ref @@ -27,7 +28,7 @@ (#xff93 . f3) (#xff94 . f4) (#xff95 . home) ; keypad - (#xff96 . left) ; keypd + (#xff96 . left) ; keypad (#xff97 . up) ; keypad (#xff98 . right) ; keypad (#xff99 . down) ; keypad @@ -67,3 +68,51 @@ (#xffcc . f15)) v #f)) + +(define (key-symbol-to-menu-key v) + (hash-ref + #hash((escape . #xff1b) + (home . #xff50) + (left . #xff51) + (up . #xff52) + (right . #xff53) + (down . #xff54) + (prior . #xff55) + (next . #xff56) + (end . #xff57) + (insert . #xff63) + (f1 . #xff91) + (f2 . #xff92) + (f3 . #xff93) + (f4 . #xff94) + (multiply . #xffaa) + (add . #xffab) + (subtract . #xffad) + (divide . #xffaf) + (numpad0 . #xffb0) + (numpad1 . #xffb1) + (numpad2 . #xffb2) + (numpad3 . #xffb3) + (numpad4 . #xffb4) + (numpad5 . #xffb5) + (numpad6 . #xffb6) + (numpad7 . #xffb7) + (numpad8 . #xffb8) + (numpad9 . #xffb9) + (f1 . #xffbe) + (f2 . #xffbf) + (f3 . #xffc0) + (f4 . #xffc1) + (f5 . #xffc2) + (f6 . #xffc3) + (f7 . #xffc4) + (f8 . #xffc5) + (f9 . #xffc6) + (f10 . #xffc7) + (f11 . #xffc8) + (f12 . #xffc9) + (f13 . #xffca) + (f14 . #xffcb) + (f15 . #xffcc)) + v + #f)) diff --git a/collects/mred/private/wx/gtk/menu.rkt b/collects/mred/private/wx/gtk/menu.rkt index 732821bd72..befde7ac45 100644 --- a/collects/mred/private/wx/gtk/menu.rkt +++ b/collects/mred/private/wx/gtk/menu.rkt @@ -166,18 +166,25 @@ (cb this e))))))) (define/private (adjust-shortcut item-gtk title) - (cond - [(regexp-match #rx"\tCtrl[+](.)$" title) - => (lambda (m) - (let ([code (gdk_unicode_to_keyval - (char->integer - (string-ref (cadr m) 0)))]) - (unless (zero? code) - (let ([accel-path (format "/Hardwired/~a" title)]) - (gtk_accel_map_add_entry accel-path - code - GDK_CONTROL_MASK) - (gtk_menu_item_set_accel_path item-gtk accel-path)))))])) + (printf "~s\n" title) + (let ([m (regexp-match #rx"\t(Ctrl[+])?(Shift[+])?(Meta[+])?(Alt[+])?(.|[0-9]+)$" + title)]) + (when m + (let ([mask (+ (if (list-ref m 1) GDK_CONTROL_MASK 0) + (if (list-ref m 2) GDK_SHIFT_MASK 0) + (if (list-ref m 3) GDK_MOD1_MASK 0) + (if (list-ref m 4) GDK_META_MASK 0))] + [code (let ([s (list-ref m 5)]) + (if (= 1 (string-length s)) + (gdk_unicode_to_keyval + (char->integer (string-ref s 0))) + (string->number s)))]) + (unless (zero? code) + (let ([accel-path (format "/Hardwired/~a" title)]) + (gtk_accel_map_add_entry accel-path + code + mask) + (gtk_menu_item_set_accel_path item-gtk accel-path))))))) (public [append-item append]) (define (append-item i label help-str-or-submenu chckable?) diff --git a/collects/mred/private/wx/gtk/platform.rkt b/collects/mred/private/wx/gtk/platform.rkt index 82fff1d7c0..7a41af4a96 100644 --- a/collects/mred/private/wx/gtk/platform.rkt +++ b/collects/mred/private/wx/gtk/platform.rkt @@ -86,4 +86,5 @@ get-highlight-text-color make-screen-bitmap make-gl-bitmap - check-for-break)) + check-for-break + key-symbol-to-menu-key)) diff --git a/collects/mred/private/wx/gtk/procs.rkt b/collects/mred/private/wx/gtk/procs.rkt index b64628f2cd..5bb9eae42c 100644 --- a/collects/mred/private/wx/gtk/procs.rkt +++ b/collects/mred/private/wx/gtk/procs.rkt @@ -16,6 +16,7 @@ "queue.rkt" "printer-dc.rkt" "gl-context.rkt" + "keycode.rkt" "../common/default-procs.rkt" "../common/handlers.rkt") @@ -56,7 +57,8 @@ special-option-key get-panel-background fill-private-color - get-color-from-user) + get-color-from-user + key-symbol-to-menu-key) (define (find-graphical-system-path what) (case what diff --git a/collects/mred/private/wx/platform.rkt b/collects/mred/private/wx/platform.rkt index 20ed0c37fe..58b7f2ed97 100644 --- a/collects/mred/private/wx/platform.rkt +++ b/collects/mred/private/wx/platform.rkt @@ -72,5 +72,6 @@ get-highlight-text-color make-screen-bitmap make-gl-bitmap - check-for-break) + check-for-break + key-symbol-to-menu-key) ((dynamic-require platform-lib 'platform-values))) diff --git a/collects/mred/private/wx/win32/key.rkt b/collects/mred/private/wx/win32/key.rkt index fefc460326..f5a493124f 100644 --- a/collects/mred/private/wx/win32/key.rkt +++ b/collects/mred/private/wx/win32/key.rkt @@ -9,7 +9,8 @@ (provide (protect-out make-key-event generates-key-event? - reset-key-mapping)) + reset-key-mapping + key-symbol-to-menu-key)) (define-user32 GetKeyState (_wfun _int -> _SHORT)) (define-user32 MapVirtualKeyW (_wfun _UINT _UINT -> _UINT)) @@ -256,3 +257,66 @@ (send e set-other-shift-altgr-key-code (as-key other-shift-altgr))) e)))))) +(define (key-symbol-to-menu-key k) + (hash-ref keysyms k #f)) + +(define keysyms + '#hash((numpad5 . |Numpad 5|) + (numpad1 . |Numpad 1|) + (escape . Escape) + (right . Right) + (prior . Prior) + (cancel . Cancel) + (start . Start) + (f22 . F22) + (f17 . F17) + (f13 . F13) + (f8 . F8) + (f3 . F3) + (divide . Divide) + (add . Add) + (numpad8 . |Numpad 8|) + (numpad3 . |Numpad 3|) + (select . Select) + (down . Down) + (next . Next) + (clear . Clear) + (scroll . Scroll) + (f21 . F21) + (f16 . F16) + (f12 . F12) + (f9 . F9) + (f4 . F4) + (f1 . F1) + (separator . Separator) + (numpad9 . |Numpad 9|) + (numpad4 . |Numpad 4|) + (help . Help) + (execute . Execute) + (left . Left) + (end . End) + (menu . Menu) + (print . Print) + (f23 . F23) + (f18 . F18) + (f14 . F14) + (f7 . F7) + (f2 . F2) + (decimal . Decimal) + (multiply . Multiply) + (numpad7 . |Numpad 7|) + (numpad2 . |Numpad 2|) + (insert . Insert) + (snapshot . Snapshot) + (up . Up) + (home . Home) + (pause . Pause) + (f24 . F24) + (f19 . F19) + (f15 . F15) + (f11 . F11) + (f6 . F6) + (f5 . F5) + (subtract . Subtract) + (numpad-enter . |Numpad Enter|) + (numpad6 . |Numpad 6|))) diff --git a/collects/mred/private/wx/win32/platform.rkt b/collects/mred/private/wx/win32/platform.rkt index 8fd883081d..c0e774e907 100644 --- a/collects/mred/private/wx/win32/platform.rkt +++ b/collects/mred/private/wx/win32/platform.rkt @@ -86,4 +86,5 @@ get-highlight-text-color make-screen-bitmap make-gl-bitmap - check-for-break)) + check-for-break + key-symbol-to-menu-key)) diff --git a/collects/mred/private/wx/win32/procs.rkt b/collects/mred/private/wx/win32/procs.rkt index 04a6bc3499..13c9db0e36 100644 --- a/collects/mred/private/wx/win32/procs.rkt +++ b/collects/mred/private/wx/win32/procs.rkt @@ -16,6 +16,7 @@ "filedialog.rkt" "colordialog.rkt" "sound.rkt" + "key.rkt" racket/draw) (provide @@ -55,8 +56,8 @@ make-gl-bitmap special-control-key special-option-key - get-color-from-user) - + get-color-from-user + key-symbol-to-menu-key) (define (find-graphical-system-path what) #f) diff --git a/collects/scribblings/gui/checkable-menu-item-class.scrbl b/collects/scribblings/gui/checkable-menu-item-class.scrbl index 0698294c5c..0bdcc80968 100644 --- a/collects/scribblings/gui/checkable-menu-item-class.scrbl +++ b/collects/scribblings/gui/checkable-menu-item-class.scrbl @@ -13,7 +13,7 @@ A @scheme[checkable-menu-item%] is a string-labelled menu item that [parent (or/c (is-a?/c menu% popup-menu%))] [callback ((is-a?/c checkable-menu-item%) (is-a?/c control-event%) . -> . any) (lambda (i e) (void))] - [shortcut (or/c char? false/c) #f] + [shortcut (or/c char? symbol? false/c) #f] [help-string (or/c label-string? false/c) #f] [demand-callback ((is-a?/c menu-item%) . -> . any) (lambda (i) (void))] diff --git a/collects/scribblings/gui/menu-item-class.scrbl b/collects/scribblings/gui/menu-item-class.scrbl index 5b6b61f898..6c91a0f7d0 100644 --- a/collects/scribblings/gui/menu-item-class.scrbl +++ b/collects/scribblings/gui/menu-item-class.scrbl @@ -12,7 +12,7 @@ A @scheme[menu-item%] is a plain string-labelled menu item. Its [parent (or/c (is-a?/c menu% popup-menu%))] [callback ((is-a?/c menu-item%) (is-a?/c control-event%) . -> . any) (lambda (i e) (void))] - [shortcut (or/c char? false/c) #f] + [shortcut (or/c char? symbol? false/c) #f] [help-string (or/c label-string? false/c) #f] [demand-callback ((is-a?/c menu-item%) . -> . any) (lambda (i) (void))] diff --git a/collects/scribblings/gui/selectable-menu-item-intf.scrbl b/collects/scribblings/gui/selectable-menu-item-intf.scrbl index 1fd10d0aa1..517e44fe91 100644 --- a/collects/scribblings/gui/selectable-menu-item-intf.scrbl +++ b/collects/scribblings/gui/selectable-menu-item-intf.scrbl @@ -35,7 +35,10 @@ The shortcut part of a menu item name is not included in the label returned by @method[labelled-menu-item<%> get-label]. For a list of allowed key symbols, see @xmethod[key-event% - get-key-code]. + get-key-code], except that the following are disallowed: + @scheme['shift], @scheme['control], @scheme['numlock], + @scheme['scroll], @scheme['wheel-up], @scheme['wheel-down], + @scheme['release], and @scheme['press]. }