diff --git a/collects/drscheme/private/rep.ss b/collects/drscheme/private/rep.ss index c49bb2fda4..fb5d76969c 100644 --- a/collects/drscheme/private/rep.ss +++ b/collects/drscheme/private/rep.ss @@ -312,7 +312,7 @@ TODO (define drs-bindings-keymap-mixin (mixin (editor:keymap<%>) (editor:keymap<%>) (define/override (get-keymaps) - (cons drs-bindings-keymap (super get-keymaps))) + (append (super get-keymaps) (list drs-bindings-keymap))) (super-instantiate ()))) ;; Max length of output queue (user's thread blocks if the @@ -849,7 +849,7 @@ TODO (define/override get-keymaps (λ () - (cons scheme-interaction-mode-keymap (super get-keymaps)))) + (append (super get-keymaps) (list scheme-interaction-mode-keymap)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; diff --git a/collects/framework/keybinding-lang.ss b/collects/framework/keybinding-lang.ss index 6676842f2c..2e1f8e2436 100644 --- a/collects/framework/keybinding-lang.ss +++ b/collects/framework/keybinding-lang.ss @@ -1,51 +1,60 @@ -(module keybinding-lang mzscheme - (require mred - string-constants - framework - mzlib/class) - - (provide (rename kl-module-begin #%module-begin) - (all-from-except mzscheme #%module-begin) - (all-from framework) - (all-from mred) - (all-from mzlib/class)) - - (define-syntax (kl-module-begin stx) - (syntax-case stx () - [(mb a ...) - (with-syntax ([#%keymap (datum->syntax-object (syntax mb) '#%keymap)] - [#%keybinding (datum->syntax-object (syntax mb) '#%keybinding)] - [keybinding (datum->syntax-object (syntax mb) 'keybinding)]) - (syntax (#%plain-module-begin - (define #%keymap (make-object keymap:aug-keymap%)) - (provide #%keymap) - (define counter 0) - (define (#%keybinding key proc src line col pos) - (unless (string? key) - (error 'keybinding "expected string as first argument, got ~e (other arg ~e)" key proc)) - (unless (and (procedure? proc) - (procedure-arity-includes? proc 2)) - (error 'keybinding "expected procedure of two arguments as second argument, got ~e (other arg ~e)" - proc - key)) - (set! counter (+ counter 1)) - (let ([name - (cond - [(symbol? (object-name proc)) - (format "~a:~a" (object-name proc) counter)] - [(and line col) - (format "~a:~a.~a:~a" src line col counter)] - [else - (format "~a:~a:~a" src pos counter)])]) - (send #%keymap add-function name - (λ (x y) - (let ([end-edit-sequence - (λ () - (when (is-a? x editor<%>) - (let loop () - (when (send x in-edit-sequence?) - (send x end-edit-sequence) - (loop)))))]) +#lang scheme +(require mred + string-constants + framework + scheme/class) + +(provide (rename-out (kl-module-begin #%module-begin)) + (except-out (all-from-out scheme) #%module-begin) + (all-from-out framework + mred + scheme/class)) + +(define-syntax (kl-module-begin stx) + (syntax-case stx () + [(mb a ...) + (with-syntax ([#%keymap (datum->syntax (syntax mb) '#%keymap)] + [#%keybinding (datum->syntax (syntax mb) '#%keybinding)] + [keybinding (datum->syntax (syntax mb) 'keybinding)]) + (syntax (#%plain-module-begin + (define #%keymap (make-object keymap:aug-keymap%)) + (provide #%keymap) + (define name-counter (make-hash)) + (define (unique-name raw-name) + (let ([last-number (hash-ref name-counter raw-name #f)]) + (cond + [last-number + (hash-set! name-counter raw-name (+ last-number 1)) + (format "~a:~a" raw-name last-number)] + [else + (hash-set! name-counter raw-name 2) + raw-name]))) + (define (#%keybinding key proc src line col pos) + (unless (string? key) + (error 'keybinding "expected string as first argument, got ~e (other arg ~e)" key proc)) + (unless (and (procedure? proc) + (procedure-arity-includes? proc 2)) + (error 'keybinding "expected procedure of two arguments as second argument, got ~e (other arg ~e)" + proc + key)) + (let ([name + (unique-name + (cond + [(symbol? (object-name proc)) + (format "~a" (object-name proc))] + [(and line col) + (format "~a:~a.~a" src line col)] + [else + (format "~a:~a" src pos)]))]) + (send #%keymap add-function name + (λ (x y) + (let ([end-edit-sequence + (λ () + (when (is-a? x editor<%>) + (let loop () + (when (send x in-edit-sequence?) + (send x end-edit-sequence) + (loop)))))]) (with-handlers ([exn:fail? (λ (x) (end-edit-sequence) @@ -59,15 +68,15 @@ (end-edit-sequence) (message-box (string-constant drscheme) (format (string-constant user-defined-keybinding-error) - name - "Editor left in edit-sequence")))))))) - (send #%keymap map-function key name))) - (define-syntax (keybinding stx) - (syntax-case stx () - [(_ key val) - (with-syntax ([src (syntax-source stx)] - [line (syntax-line stx)] - [col (syntax-column stx)] - [pos (syntax-position stx)]) - (syntax (#%keybinding key val 'src 'line 'col 'pos)))])) - a ...)))]))) + name + "Editor left in edit-sequence")))))))) + (send #%keymap map-function key name))) + (define-syntax (keybinding stx) + (syntax-case stx () + [(_ key val) + (with-syntax ([src (syntax-source stx)] + [line (syntax-line stx)] + [col (syntax-column stx)] + [pos (syntax-position stx)]) + (syntax (#%keybinding key val 'src 'line 'col 'pos)))])) + a ...)))])) diff --git a/collects/framework/private/editor.ss b/collects/framework/private/editor.ss index 422f3ae4d0..6265bc3557 100644 --- a/collects/framework/private/editor.ss +++ b/collects/framework/private/editor.ss @@ -505,7 +505,7 @@ (define/public (get-can-close-parent) #f) (define/override (get-keymaps) - (cons (keymap:get-file) (super get-keymaps))) + (append (super get-keymaps) (list (keymap:get-file)))) (super-new))) (define backup-autosave<%> diff --git a/collects/framework/private/frame.ss b/collects/framework/private/frame.ss index a203326d93..1a68e649d0 100644 --- a/collects/framework/private/frame.ss +++ b/collects/framework/private/frame.ss @@ -1691,7 +1691,7 @@ (loop (send snip next)))] [else (cons snip (loop (send snip next)))])))) (define/override (get-keymaps) - (cons search/replace-keymap (super get-keymaps))) + (append (super get-keymaps) (list search/replace-keymap))) (super-new) (inherit set-styles-fixed) (set-styles-fixed #t) @@ -1889,7 +1889,7 @@ (inherit set-styles-fixed) (super-new [pref-sym 'framework:replace-string]) (define/override (get-keymaps) - (cons search/replace-keymap (super get-keymaps))) + (append (super get-keymaps) (list search/replace-keymap))) (set-styles-fixed #t))) (define search/replace-keymap (new keymap%)) diff --git a/collects/framework/private/keymap.ss b/collects/framework/private/keymap.ss index 7ac785a19b..39525d37d9 100644 --- a/collects/framework/private/keymap.ss +++ b/collects/framework/private/keymap.ss @@ -1430,7 +1430,7 @@ (define global (make-object aug-keymap%)) (define global-main (make-object aug-keymap%)) - (send global chain-to-keymap global-main #t) + (send global chain-to-keymap global-main #f) (setup-global global-main) (generic-setup global-main) (define (get-global) global) diff --git a/collects/framework/private/scheme.ss b/collects/framework/private/scheme.ss index a1b1d0f928..492c2b3340 100644 --- a/collects/framework/private/scheme.ss +++ b/collects/framework/private/scheme.ss @@ -1151,7 +1151,7 @@ (define/override (on-enable-surrogate text) (send text begin-edit-sequence) (super on-enable-surrogate text) - (send (send text get-keymap) chain-to-keymap keymap #t) + (send (send text get-keymap) chain-to-keymap keymap #f) ;; I don't know about these editor flag settings. ;; maybe they belong in drscheme? diff --git a/collects/framework/private/text.ss b/collects/framework/private/text.ss index 576ca6e182..aaa52a42e2 100644 --- a/collects/framework/private/text.ss +++ b/collects/framework/private/text.ss @@ -852,7 +852,7 @@ WARNING: printf is rebound in the body of the unit to always find-string) (define/override (get-keymaps) - (cons (keymap:get-search) (super get-keymaps))) + (append (super get-keymaps) (list (keymap:get-search)))) (define searching-str #f) (define case-sensitive? #f)