From 463f71e53ded99ea1aac7d4a1c561482692cd4b6 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 6 Jul 2006 18:03:37 +0000 Subject: [PATCH] oops - the rest of 350.4 svn: r3630 --- collects/mred/mred-sig.ss | 1 + collects/mred/mred.ss | 1 + collects/mred/private/kernel.ss | 3 + collects/mred/private/mrmenu.ss | 158 ++++++++++++++++++++-------- collects/mred/private/mrmenuintf.ss | 2 +- collects/mred/private/wxtop.ss | 30 +++++- 6 files changed, 151 insertions(+), 44 deletions(-) diff --git a/collects/mred/mred-sig.ss b/collects/mred/mred-sig.ss index 13e677f7e2..e5b06a02b1 100644 --- a/collects/mred/mred-sig.ss +++ b/collects/mred/mred-sig.ss @@ -81,6 +81,7 @@ gauge% get-choices-from-user get-color-from-user + get-default-shortcut-prefix get-directory get-display-depth get-display-left-top-inset diff --git a/collects/mred/mred.ss b/collects/mred/mred.ss index 4428422598..448ca8af8b 100644 --- a/collects/mred/mred.ss +++ b/collects/mred/mred.ss @@ -218,6 +218,7 @@ labelled-menu-item<%> menu-item% checkable-menu-item% + get-default-shortcut-prefix menu-item-container<%> menu% menu-bar% diff --git a/collects/mred/private/kernel.ss b/collects/mred/private/kernel.ss index 003f04926b..dcbb3f7e0e 100644 --- a/collects/mred/private/kernel.ss +++ b/collects/mred/private/kernel.ss @@ -467,6 +467,8 @@ get-position set-position) (define-class key-event% event% ([key-code #\nul] [shift-down #f] [control-down #f] [meta-down #f] [alt-down #f] [x 0] [y 0] [time-stamp 0]) + set-other-shift-key-code + get-other-shift-key-code get-key-code set-key-code get-key-release-code @@ -483,6 +485,7 @@ set-x get-y set-y) + (define-function key-symbol-to-integer) (define-class mouse-event% event% (event-type [left-down #f] [middle-down #f] [right-down #f] [x 0] [y 0] [shift-down #f] [control-down #f] [meta-down #f] [alt-down #f] [time-stamp 0]) moving? leaving? diff --git a/collects/mred/private/mrmenu.ss b/collects/mred/private/mrmenu.ss index 39da21e15f..c39cacfa84 100644 --- a/collects/mred/private/mrmenu.ss +++ b/collects/mred/private/mrmenu.ss @@ -19,6 +19,7 @@ checkable-menu-item% menu% menu-bar% + get-default-shortcut-prefix (protect menu-parent-only menu-or-bar-parent)) @@ -168,8 +169,59 @@ [(#\;) (if print? ";" "Semicolon")] [else c])) + (define key-code->keymap-name #hasheq((prior . #"pageup") + (next . #"pagedown") + (escape . #"esc"))) + + (define (check-shortcut who c) + (unless (or (not c) + (char? c) + (and (symbol? c) + (positive? (wx:key-symbol-to-integer c)))) + (raise-type-error (who->name who) "character, key-code symbol, or #f" c))) + + (define (check-shortcut-prefix who p) + (unless (and (list? p) + (andmap (lambda (i) + (memq i '(meta alt cmd shift option ctl))) + p) + (let loop ([p p]) + (cond + [(null? p) #t] + [(memq (car p) (cdr p)) #f] + [else (loop (cdr p))]))) + (raise-type-error (who->name who) + "list of unique symbols: 'shift, 'meta, 'alt, 'cmd, 'option, and 'ctl" + p)) + (let ([disallowed (case (system-type) + [(unix) '(cmd option)] + [(windows) '(cmd option meta)] + [(macosx) '(meta alt)])]) + (for-each (lambda (i) + (when (memq i p) + (raise-mismatch-error (who->name who) + "prefix not supported for the current platform: " + i))) + disallowed) + (when (eq? 'unix (system-type)) + (when (and (memq 'meta p) + (memq 'alt p)) + (raise-mismatch-error (who->name who) + "prefix contains both 'meta and 'alt: " + p))))) + + (define default-prefix + (case (system-type) + [(unix) (list-immutable default-x-prefix)] + [(windows) (list-immutable 'ctl)] + [(macosx) (list-immutable 'cmd)])) + + (define (get-default-shortcut-prefix) + default-prefix) + (define basic-selectable-menu-item% - (class100* basic-labelled-menu-item% (selectable-menu-item<%>) (lbl checkable? mnu cb shrtcut help-string set-wx demand-callback) + (class100* basic-labelled-menu-item% (selectable-menu-item<%>) (lbl checkable? mnu cb shrtcut help-string set-wx + demand-callback shrtcut-prefix) (inherit is-enabled?) (rename [super-restore restore] [super-set-label set-label] [super-is-deleted? is-deleted?] @@ -186,38 +238,61 @@ (check-instance '(method selectable-menu-item<%> command) wx:control-event% 'control-event% #f e) (void (callback this e)))]) (private-field - [x-prefix default-x-prefix]) + [prefix (apply list-immutable shrtcut-prefix)]) (private [calc-labels (lambda (label) (let* ([new-label (if shortcut (string-append (strip-tab label) (case (system-type) - [(unix) (format "~a~a~a" #\tab - (case x-prefix - [(meta) "Meta+"] - [(alt) "Alt+"] - [(ctl-m) "Ctl+M "] - [(ctl) "Ctl+"]) - (char-name - (char-upcase shortcut) - #t))] - [(windows) (format "~aCtl+~a" #\tab - (char-name (char-upcase shortcut) #t))] - [(macos macosx) (format "~aCmd+~a" #\tab - (char-name (char-upcase shortcut) #t))])) + [(unix windows) + (format "~a~a~a~a~a~a" #\tab + (if (memq 'ctl prefix) "Ctrl+" "") + (if (memq 'shift prefix) "Shift+" "") + (if (memq 'meta prefix) "Meta+" "") + (if (memq 'alt prefix) "Alt+" "") + (if (symbol? shortcut) + (string-titlecase (symbol->string shortcut)) + (char-name + (char-upcase shortcut) + #t)))] + [(macosx) + (format "\tCut=~a~a" + (integer->char + (+ (if (memq 'shift prefix) 1 0) + (if (memq 'option prefix) 2 0) + (if (memq 'ctl prefix) 4 0) + (if (memq 'cmd prefix) 0 8) + (char->integer #\A))) + (if (char? shortcut) + (char->integer (char-upcase shortcut)) + (wx:key-symbol-to-integer shortcut)))])) (strip-tab label))] [key-binding (and shortcut - (case (system-type) - [(unix) (format "~a~a" - (case x-prefix - [(meta) ":m:"] - [(alt) ":m:"] - [(ctl-m) ":c:m;:"] - [(ctl) ":c:"]) - (char-name (char-downcase shortcut) #f))] - [(windows) (format ":c:~a" (char-name (char-downcase shortcut) #f))] - [(macos macosx) (format ":d:~a" (char-name (char-downcase shortcut) #f))]))] + (let ([base (if (symbol? shortcut) + (hash-table-get key-code->keymap-name shortcut (lambda () shortcut)) + (char-name (char-downcase shortcut) #f))] + [exact (if (or (symbol? shortcut) + (and (char-alphabetic? shortcut) + ((char->integer shortcut) . < . 128)) + (char-numeric? shortcut)) + ":" + "")]) + (case (system-type) + [(unix windows) (format "~a~a~a~a~a?:~a" + exact + (if (memq 'shift prefix) "s:" "") + (if (memq 'meta prefix) "m:" "") + (if (memq 'alt prefix) "m:" "") + (if (memq 'ctl prefix) "c:" "") + base)] + [(macosx) (format "~a~a~a~a~a?:~a" + exact + (if (memq 'shift prefix) "s:" "") + (if (memq 'cmd prefix) "d:" "") + (if (memq 'ctl prefix) "c:" "") + (if (memq 'option prefix) "a:" "") + base)])))] [keymap (and key-binding (let ([keymap (make-object wx:keymap%)]) (send keymap add-function "menu-item" @@ -244,41 +319,42 @@ [set-label (lambda (s) (do-set-label s))]) (public [set-shortcut (lambda (c) - (check-char/false '(method selectable-menu-item<%> set-shortcut) c) + (check-shortcut '(method selectable-menu-item<%> set-shortcut) c) (unless (equal? shortcut c) (set! shortcut c) (do-set-label label)))] [get-shortcut (lambda () shortcut)] - [get-x-shortcut-prefix (lambda () x-prefix)] - [set-x-shortcut-prefix (lambda (p) - (unless (memq p '(meta alt ctl-m ctl)) - (raise-type-error (who->name '(method selectable-menu-item<%> set-x-shortcut-prefix)) - "symbol: meta, alt, ctl-m, or ctl" p)) - (set! x-prefix p) (do-set-label label))]) + [get-shortcut-prefix (lambda () prefix)] + [set-shortcut-prefix (lambda (p) + (check-shortcut-prefix '(method selectable-menu-item<%> set-x-shortcut-prefix) p) + (set! prefix p) (do-set-label label))]) (sequence (set! label (string->immutable-string label)) (let-values ([(new-label keymap) (calc-labels label)]) (super-init menu new-label help-string #f checkable? keymap (lambda (x) (set! wx x) (set-wx x)) demand-callback))))) - (define (check-shortcut-args who label menu callback shortcut help-string demand-callback) + (define (check-shortcut-args who label menu callback shortcut help-string demand-callback shortcut-prefix) (let ([cwho `(constructor ,who)]) (check-label-string cwho label) (menu-parent-only who menu) (check-callback cwho callback) - (check-char/false cwho shortcut) + (check-shortcut cwho shortcut) (check-label-string/false cwho help-string) - (check-callback1 cwho demand-callback))) + (check-callback1 cwho demand-callback) + (check-shortcut-prefix cwho shortcut-prefix))) (define menu-item% - (class100 basic-selectable-menu-item% (label parent callback [shortcut #f] [help-string #f] [demand-callback void]) + (class100 basic-selectable-menu-item% (label parent callback [shortcut #f] [help-string #f] [demand-callback void] + [shortcut-prefix default-prefix]) (sequence - (check-shortcut-args 'menu-item label parent callback shortcut help-string demand-callback) - (super-init label #f parent callback shortcut help-string (lambda (x) x) demand-callback)))) + (check-shortcut-args 'menu-item label parent callback shortcut help-string demand-callback shortcut-prefix) + (super-init label #f parent callback shortcut help-string (lambda (x) x) demand-callback shortcut-prefix)))) (define checkable-menu-item% - (class100 basic-selectable-menu-item% (label parent callback [shortcut #f] [help-string #f] [demand-callback void] [checked #f]) + (class100 basic-selectable-menu-item% (label parent callback [shortcut #f] [help-string #f] [demand-callback void] + [checked #f] [shortcut-prefix default-prefix]) (sequence - (check-shortcut-args 'checkable-menu-item label parent callback shortcut help-string demand-callback)) + (check-shortcut-args 'checkable-menu-item label parent callback shortcut help-string demand-callback shortcut-prefix)) (private-field [mnu parent] [wx #f]) @@ -286,7 +362,7 @@ [check (entry-point (lambda (on?) (send (send (mred->wx mnu) get-container) check (send wx id) on?)))] [is-checked? (entry-point (lambda () (send (send (mred->wx mnu) get-container) checked? (send wx id))))]) (sequence - (super-init label #t mnu callback shortcut help-string (lambda (x) (set! wx x) x) demand-callback) + (super-init label #t mnu callback shortcut help-string (lambda (x) (set! wx x) x) demand-callback shortcut-prefix) (when checked (check #t))))) (define menu% diff --git a/collects/mred/private/mrmenuintf.ss b/collects/mred/private/mrmenuintf.ss index 943fc76778..e4c4d4003c 100644 --- a/collects/mred/private/mrmenuintf.ss +++ b/collects/mred/private/mrmenuintf.ss @@ -27,7 +27,7 @@ (interface (labelled-menu-item<%>) command get-shortcut set-shortcut - get-x-shortcut-prefix set-x-shortcut-prefix)) + get-shortcut-prefix set-shortcut-prefix)) (define menu-item-container<%> (interface () diff --git a/collects/mred/private/wxtop.ss b/collects/mred/private/wxtop.ss index 583cb293ec..65d9c792e4 100644 --- a/collects/mred/private/wxtop.ss +++ b/collects/mred/private/wxtop.ss @@ -602,6 +602,31 @@ [get-act-date/milliseconds (lambda () act-date/milliseconds)]) (sequence (apply super-init mred proxy args)))) + (define function-keys #hasheq((f1 . #t) + (f2 . #t) + (f3 . #t) + (f4 . #t) + (f5 . #t) + (f6 . #t) + (f7 . #t) + (f8 . #t) + (f9 . #t) + (f10 . #t) + (f11 . #t) + (f12 . #t) + (f13 . #t) + (f14 . #t) + (f15 . #t) + (f16 . #t) + (f17 . #t) + (f18 . #t) + (f19 . #t) + (f20 . #t) + (f21 . #t) + (f22 . #t) + (f23 . #t) + (f24 . #t))) + (define wx-frame% (make-top-level-window-glue% (class100 (make-top-container% wx:frame% #f) args @@ -650,10 +675,11 @@ (lambda (event) (and menu-bar ;; It can't be a menu event without a - ;; control, meta, or alt key... + ;; control, meta, alt key, or function key (or (send event get-control-down) (send event get-meta-down) - (send event get-alt-down)) + (send event get-alt-down) + (hash-table-get function-keys (send event get-key-code) #f)) (begin (send menu-bar on-demand) (send menu-bar handle-key event))))])