finish implementing display of menu shortcuts

that involve non-chars shortcuts and alternate prefixes

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

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)

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)))

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))

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)
 

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))

collects/mred/private/wx/gtk/menu.rkt

@@ -166,18 +166,25 @@
                 (cb this e)))))))
   
   (define/private (adjust-shortcut item-gtk title)
-    (cond
+    (printf "~s\n" title)
-     [(regexp-match #rx"\tCtrl[+](.)$" title)
+    (let ([m (regexp-match #rx"\t(Ctrl[+])?(Shift[+])?(Meta[+])?(Alt[+])?(.|[0-9]+)$" 
-      => (lambda (m)
+                           title)])
-           (let ([code (gdk_unicode_to_keyval 
+      (when m
-                        (char->integer
+        (let ([mask (+ (if (list-ref m 1) GDK_CONTROL_MASK 0)
-                         (string-ref (cadr m) 0)))])
+                       (if (list-ref m 2) GDK_SHIFT_MASK 0)
-             (unless (zero? code)
+                       (if (list-ref m 3) GDK_MOD1_MASK 0)
-               (let ([accel-path (format "<GRacket>/Hardwired/~a" title)])
+                       (if (list-ref m 4) GDK_META_MASK 0))]
-                 (gtk_accel_map_add_entry accel-path
+              [code (let ([s (list-ref m 5)])
-                                          code
+                      (if (= 1 (string-length s))
-                                          GDK_CONTROL_MASK)
+                          (gdk_unicode_to_keyval 
-                 (gtk_menu_item_set_accel_path item-gtk accel-path)))))]))
+                           (char->integer (string-ref s 0)))
+                          (string->number s)))])
+          (unless (zero? code)
+            (let ([accel-path (format "<GRacket>/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?)

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))

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

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)))

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|)))

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))

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)

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))]

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))]

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].
 
 }