diff --git a/collects/framework/framework.ss b/collects/framework/framework.ss index 335e1583..89096b48 100644 --- a/collects/framework/framework.ss +++ b/collects/framework/framework.ss @@ -934,6 +934,19 @@ "@link bitmap ok?" "method.") + (keymap:remove-user-keybindings-file + (-> path? any) + (user-keybindings-path) + "Removes the keymap previously added by" + "@flink keymap:add-user-keybindings-file %" + ".") + (keymap:add-user-keybindings-file + (-> path? any) + (user-keybindings-path) + "Chains the keymap defined by \\var{user-keybindings-path} to " + "the global keymap, returned by " + "@flink keymap:get-global %" + ".") (keymap:add-to-right-button-menu (case-> (((is-a?/c popup-menu%) (is-a?/c editor<%>) (is-a?/c event%) . -> . void?) . -> . void?) diff --git a/collects/framework/private/keymap.ss b/collects/framework/private/keymap.ss index b2c0ba2e..66c33142 100644 --- a/collects/framework/private/keymap.ss +++ b/collects/framework/private/keymap.ss @@ -6,6 +6,7 @@ (lib "class.ss") (lib "list.ss") (lib "mred-sig.ss" "mred") + (lib "match.ss") "sig.ss") (provide keymap@) @@ -21,6 +22,30 @@ (rename [-get-file get-file]) + (define user-keybindings-files (make-hash-table 'equal)) + + (define (add-user-keybindings-file path) + (hash-table-get + user-keybindings-files + path + (lambda () + (let ([sexp (and (file-exists? path) + (call-with-input-file path read))]) + (match sexp + [`(module ,name (lib "keybinding-lang.ss" "framework") ,@(x ...)) + (let ([km (dynamic-require path '#%keymap)]) + (hash-table-put! user-keybindings-files path km) + (send global chain-to-keymap km #t))] + [else (error 'add-user-keybindings-file + (string-constant user-defined-keybinding-malformed-file) + (path->string path))]))))) + + (define (remove-user-keybindings-file path) + (let/ec k + (let ([km (hash-table-get user-keybindings-files path (lambda () (k (void))))]) + (send global remove-chained-keymap km) + (hash-table-remove! user-keybindings-files path)))) + (define (remove-chained-keymap ed keymap-to-remove) (let ([ed-keymap (send ed get-keymap)]) (when (eq? keymap-to-remove ed-keymap) @@ -1275,8 +1300,10 @@ (add-text-keymap-functions keymap)) (define global (make-object aug-keymap%)) - (setup-global global) - (generic-setup global) + (define global-main (make-object aug-keymap%)) + (send global chain-to-keymap global-main #t) + (setup-global global-main) + (generic-setup global-main) (define (get-global) global) (define file (make-object aug-keymap%)) diff --git a/collects/framework/private/sig.ss b/collects/framework/private/sig.ss index e6d4a790..2316a631 100644 --- a/collects/framework/private/sig.ss +++ b/collects/framework/private/sig.ss @@ -489,7 +489,10 @@ set-chained-keymaps remove-chained-keymap - call/text-keymap-initializer)) + call/text-keymap-initializer + + add-user-keybindings-file + remove-user-keybindings-file)) (define-signature framework:keymap^ ((open framework:keymap-class^) (open framework:keymap-fun^)))