diff --git a/collects/framework/editor.ss b/collects/framework/editor.ss index fe7a2870..36a5c6bb 100644 --- a/collects/framework/editor.ss +++ b/collects/framework/editor.ss @@ -171,8 +171,6 @@ (sequence (apply super-init args) (let ([keymap (get-keymap)]) - (keymap:set-keymap-error-handler keymap) - (keymap:set-keymap-implied-shifts keymap) (for-each (lambda (k) (send keymap chain-to-keymap k #f)) (get-keymaps)))))) diff --git a/collects/framework/finder.ss b/collects/framework/finder.ss index 475bfa72..c2d3fdf8 100644 --- a/collects/framework/finder.ss +++ b/collects/framework/finder.ss @@ -326,7 +326,7 @@ [top-panel (make-object horizontal-panel% main-panel)] - [_1 (make-object message% top-panel prompt)] + [_1 (make-object message% prompt top-panel)] [dir-choice (make-object choice% #f null top-panel do-dir)] diff --git a/collects/framework/frameworks.ss b/collects/framework/frameworks.ss index e7580b26..2d9fdd73 100644 --- a/collects/framework/frameworks.ss +++ b/collects/framework/frameworks.ss @@ -207,9 +207,7 @@ get-gc-off-bitmap)) (define-signature framework:keymap^ - (set-keymap-error-handler - set-keymap-implied-shifts - send-map-function-meta + (send-map-function-meta make-meta-prefix-list setup-global diff --git a/collects/framework/keymap.ss b/collects/framework/keymap.ss index 42358bb7..38a4b921 100644 --- a/collects/framework/keymap.ss +++ b/collects/framework/keymap.ss @@ -8,18 +8,6 @@ [frame : framework:frame^]) (rename [-get-file get-file]) - - (define keyerr - (lambda (str) - (display str (current-error-port)) - (newline (current-error-port)))) - - (define (set-keymap-error-handler keymap) - (send keymap set-error-callback keyerr)) - - (define (set-keymap-implied-shifts keymap) - (map (lambda (k) (send keymap implies-shift k)) - (keys:get-shifted-key-list))) (define (make-meta-prefix-list key) (list (string-append "m:" key) @@ -530,18 +518,14 @@ (send edit set-overwrite-mode (not (send edit get-overwrite-mode))))]) (lambda (kmap) - ; Redirect keymapping error messages to stderr - (send kmap set-error-callback keyerr) - ; Set the implied shifting map - (map (lambda (k) (send kmap implies-shift k)) (keys:get-shifted-key-list)) (let* ([map (lambda (key func) (send kmap map-function key func))] [map-meta (lambda (key func) (send-map-function-meta kmap key func))] [add (lambda (name func) - (send kmap add-key-function name func))] + (send kmap add-function name func))] [add-m (lambda (name func) - (send kmap add-mouse-function name func))]) + (send kmap add-function name func))]) ; Map names to keyboard functions (add "toggle-overwrite" toggle-overwrite) @@ -748,8 +732,6 @@ (map "leftbuttontriple" "select-click-line") (map "leftbuttondouble" "select-click-word") - (map "c:x;c:c" "exit") - (map "rightbutton" "copy-click-region") (map "rightbuttondouble" "cut-click-region") (map "middlebutton" "paste-click-region") @@ -778,9 +760,9 @@ [map-meta (lambda (key func) (send-map-function-meta kmap key func))] [add (lambda (name func) - (send kmap add-key-function name func))] + (send kmap add-function name func))] [add-m (lambda (name func) - (send kmap add-mouse-function name func))]) + (send kmap add-function name func))]) (add "move-to-search-or-search" (send-frame 'move-to-search-or-search)) ;; key 1 (add "move-to-search-or-reverse-search" (send-frame 'move-to-search-or-reverse-search)) ;; key 1b, backwards @@ -828,15 +810,14 @@ (handler:open-file) #t)]) (lambda (kmap) - (map (lambda (k) (send kmap implies-shift k)) (keys:get-shifted-key-list)) (let* ([map (lambda (key func) (send kmap map-function key func))] [map-meta (lambda (key func) (send-map-function-meta kmap key func))] [add (lambda (name func) - (send kmap add-key-function name func))] + (send kmap add-function name func))] [add-m (lambda (name func) - (send kmap add-mouse-function name func))]) + (send kmap add-function name func))]) (add "save-file" save-file) (add "save-file-as" save-file-as) @@ -848,8 +829,6 @@ (map "c:x;c:f" "load-file"))))) (define (generic-setup keymap) - (set-keymap-error-handler keymap) - (set-keymap-implied-shifts keymap) (add-editor-keymap-functions keymap) (add-pasteboard-keymap-functions keymap) (add-text-keymap-functions keymap)) diff --git a/collects/framework/scheme.ss b/collects/framework/scheme.ss index 918e1bda..f3f0c9fd 100644 --- a/collects/framework/scheme.ss +++ b/collects/framework/scheme.ss @@ -754,12 +754,10 @@ (define setup-keymap (lambda (keymap) - (keymap:set-keymap-error-handler keymap) - (keymap:set-keymap-implied-shifts keymap) (let ([add-pos-function ;; wx: this needs to be cleaned up! (lambda (name ivar-sym) - (send keymap add-key-function name + (send keymap add-function name (lambda (edit event) ((ivar/proc edit ivar-sym) (send edit get-start-position)))))]) @@ -775,7 +773,7 @@ (let ([add-edit-function (lambda (name ivar-sym) - (send keymap add-key-function name + (send keymap add-function name (lambda (edit event) ((ivar/proc edit ivar-sym)))))]) (add-edit-function "select-forward-sexp" 'select-forward-sexp) @@ -787,10 +785,10 @@ (add-edit-function "comment-out" 'comment-out-selection) (add-edit-function "uncomment" 'uncomment-selection)) - (send keymap add-key-function "balance-parens" + (send keymap add-function "balance-parens" (lambda (edit event) (send edit balance-parens event))) - (send keymap add-key-function "balance-quotes" + (send keymap add-function "balance-quotes" (lambda (edit event) (send edit balance-quotes event))) diff --git a/collects/tests/framework/frame.ss b/collects/tests/framework/frame.ss index 42e0a94f..ae83e52c 100644 --- a/collects/tests/framework/frame.ss +++ b/collects/tests/framework/frame.ss @@ -1,84 +1,102 @@ -(let ([test-creation - (lambda (name class-expression) - (test - name - (lambda (x) x) - (lambda () - (send-sexp-to-mred - `(send (make-object ,class-expression "test") show #t)) - (wait-for-frame "test") - (send-sexp-to-mred - '(send (get-top-level-focus-window) show #f)) - #t)))]) +(define (test-creation name class-expression) + '(test + name + (lambda (x) x) + (lambda () + (send-sexp-to-mred + `(send (make-object ,class-expression "test") show #t)) + (wait-for-frame "test") + (send-sexp-to-mred + '(send (get-top-level-focus-window) show #f)) + #t))) - (test-creation - 'basic%-creation - 'frame:basic%) - (test-creation - 'basic-mixin-creation - '(frame:basic-mixin frame%)) +(test-creation + 'basic%-creation + 'frame:basic%) +(test-creation + 'basic-mixin-creation + '(frame:basic-mixin frame%)) - (test-creation - 'standard-menus%-creation - 'frame:standard-menus%) - (test-creation - 'standard-menus-mixin - '(frame:standard-menus-mixin frame:basic%)) +(test-creation + 'standard-menus%-creation + 'frame:standard-menus%) +(test-creation + 'standard-menus-mixin + '(frame:standard-menus-mixin frame:basic%)) - (test-creation - 'text%-creation - 'frame:text%) - (test-creation - 'text-mixin-creation - '(frame:text-mixin frame:editor%)) - (test-creation - 'text-mixin-creation - '(frame:text-mixin (frame:editor-mixin frame:standard-menus%))) +(test-creation + 'text%-creation + 'frame:text%) +(test-creation + 'text-mixin-creation + '(frame:text-mixin frame:editor%)) +(test-creation + 'text-mixin-creation + '(frame:text-mixin (frame:editor-mixin frame:standard-menus%))) - (test-creation - 'searchable%-creation - 'frame:searchable%) - (test-creation - 'searchable-mixin - '(frame:searchable-mixin frame:text%)) +(test-creation + 'searchable%-creation + 'frame:searchable%) +(test-creation + 'searchable-mixin + '(frame:searchable-mixin frame:text%)) - (test-creation - 'info-mixin-creation - '(frame:info-mixin frame:searchable%)) - (test-creation - 'text-info-mixin-creation - '(frame:text-info-mixin (frame:info-mixin frame:searchable%))) - (test-creation - 'text-info%-creation - 'frame:text-info%) +(test-creation + 'info-mixin-creation + '(frame:info-mixin frame:searchable%)) +(test-creation + 'text-info-mixin-creation + '(frame:text-info-mixin (frame:info-mixin frame:searchable%))) +(test-creation + 'text-info%-creation + 'frame:text-info%) - (test-creation - 'text-info-file%-creation - 'frame:text-info-file%) - (test-creation - 'text-info-file-mixin-creation - '(frame:file-mixin frame:text-info%)) +(test-creation + 'text-info-file%-creation + 'frame:text-info-file%) +(test-creation + 'text-info-file-mixin-creation + '(frame:file-mixin frame:text-info%)) - (test-creation - 'pasteboard-mixin-creation - '(frame:pasteboard-mixin frame:editor%)) - (test-creation - 'pasteboard-mixin-creation - '(frame:pasteboard-mixin (frame:editor-mixin frame:standard-menus%))) - (test-creation - 'pasteboard%-creation - 'frame:pasteboard%) +(test-creation + 'pasteboard-mixin-creation + '(frame:pasteboard-mixin frame:editor%)) +(test-creation + 'pasteboard-mixin-creation + '(frame:pasteboard-mixin (frame:editor-mixin frame:standard-menus%))) +(test-creation + 'pasteboard%-creation + 'frame:pasteboard%) - (test-creation - 'pasteboard-info-mixin-creation - '(frame:info-mixin frame:searchable%)) - (test-creation - 'pasteboard-info%-creation - 'frame:pasteboard-info%) +(test-creation + 'pasteboard-info-mixin-creation + '(frame:info-mixin frame:searchable%)) +(test-creation + 'pasteboard-info%-creation + 'frame:pasteboard-info%) - (test-creation - 'pasteboard-info-file-mixin-creation - '(frame:file-mixin frame:pasteboard-info%)) - (test-creation - 'pasteboard-info-file%-creation - 'frame:pasteboard-info-file%)) +(test-creation + 'pasteboard-info-file-mixin-creation + '(frame:file-mixin frame:pasteboard-info%)) +(test-creation + 'pasteboard-info-file%-creation + 'frame:pasteboard-info-file%) + +(define (test-open name class-expression) + (test + name + (lambda (x) x) + (lambda () + (send-sexp-to-mred + `(begin + (preferences:set + 'framework:file-dialogs + 'common) + (send (make-object ,class-expression "test open") show #t))) + (wait-for-frame "test open") + (send-sexp-to-mred + `(test:menu-select "File" "Open...")) + (wait-for-frame "Open File") + #t))) + +(test-open "frame:editor open" 'frame:text%)