diff --git a/collects/drscheme/private/drsig.ss b/collects/drscheme/private/drsig.ss index c9fa74332d..2ecaac814e 100644 --- a/collects/drscheme/private/drsig.ss +++ b/collects/drscheme/private/drsig.ss @@ -148,7 +148,9 @@ mixin basics-mixin basics<%> - create-root-menubar)) + create-root-menubar + add-keybindings-item + planet-spec?)) (define-signature drscheme:program^ (frame%)) diff --git a/collects/drscheme/private/frame.ss b/collects/drscheme/private/frame.ss index 12ea092a76..9e38e1225e 100644 --- a/collects/drscheme/private/frame.ss +++ b/collects/drscheme/private/frame.ss @@ -3,6 +3,7 @@ (require (lib "name-message.ss" "mrlib") (lib "string-constant.ss" "string-constants") (lib "unitsig.ss") + (lib "match.ss") (lib "class.ss") (lib "string.ss") (lib "list.ss") @@ -29,6 +30,8 @@ (define basics<%> (interface (frame:standard-menus<%>))) + (define last-keybindings-planet-attempt "") + (define basics-mixin (mixin (frame:standard-menus<%>) (basics<%>) (inherit get-edit-target-window get-edit-target-object get-menu-bar) @@ -187,37 +190,85 @@ (let ([filename (get-file (string-constant keybindings-choose-user-defined-file) this)]) (when filename - (add-keybindings-file filename)))))) + (add-keybindings-item/update-prefs filename)))))) + (new menu-item% + (parent keybindings-menu) + (label (string-constant keybindings-add-user-defined-keybindings/planet)) + (callback + (λ (x y) + (let ([planet-spec (get-text-from-user (string-constant drscheme) + (string-constant keybindings-type-planet-spec) + this + last-keybindings-planet-attempt)]) + (when planet-spec + (set! last-keybindings-planet-attempt planet-spec)) + (cond + [(planet-string-spec? planet-spec) + => + (λ (planet-sexp-spec) + (add-keybindings-item/update-prefs planet-sexp-spec))] + [else + (message-box (string-constant drscheme) + (format (string-constant keybindings-planet-malformed-spec) + planet-spec))]))))) (let ([ud (preferences:get 'drscheme:user-defined-keybindings)]) (unless (null? ud) (new separator-menu-item% (parent keybindings-menu)) - (for-each (λ (path) + (for-each (λ (item) (new menu-item% (label (format (string-constant keybindings-menu-remove) - (path->string path))) + (if (path? item) + (path->string item) + (format "~s" item)))) (parent keybindings-menu) (callback - (λ (x y) (remove-keybindings-file path))))) + (λ (x y) (remove-keybindings-item item))))) ud))))))) (unless (current-eventspace-has-standard-menus?) (make-object separator-menu-item% menu))) (super-new))) - (define (add-keybindings-file path) + (define (add-keybindings-item/update-prefs item) + (when (add-keybindings-item item) + (preferences:set 'drscheme:user-defined-keybindings + (cons item + (preferences:get 'drscheme:user-defined-keybindings))))) + + (define (planet-string-spec? p) + (let ([sexp + (with-handlers ([exn:fail:read? (λ (x) #f)]) + (read (open-input-string p)))]) + (and sexp + (planet-spec? sexp) + sexp))) + + (define (planet-spec? p) + (match p + [`(planet ,(? string?) (,(? string?) ,(? string?) ,(? number?))) #t] + [`(planet ,(? string?) (,(? string?) ,(? string?) ,(? number?) ,(? number?))) #t] + [else #f])) + + ;; add-keybindings-item : keybindings-item[path or planet spec] -> boolean + ;; boolean indicates if the addition happened sucessfully + (define (add-keybindings-item item) (with-handlers ([exn? (λ (x) (message-box (string-constant drscheme) - (exn-message x)))]) - (keymap:add-user-keybindings-file path) - (preferences:set 'drscheme:user-defined-keybindings - (cons path - (preferences:get 'drscheme:user-defined-keybindings))))) - (define (remove-keybindings-file path) - (keymap:remove-user-keybindings-file path) + (format (string-constant keybindings-error-installing-file) + (if (path? item) + (path->string item) + (format "~s" item)) + (exn-message x))) + #f)]) + (keymap:add-user-keybindings-file item) + #t)) + + (define (remove-keybindings-item item) + (keymap:remove-user-keybindings-file item) (preferences:set 'drscheme:user-defined-keybindings - (remq path - (preferences:get 'drscheme:user-defined-keybindings)))) + (remove item + (preferences:get 'drscheme:user-defined-keybindings)))) ;; install-plt-file : (union #f dialog% frame%) -> void ;; asks the user for a .plt file, either from the web or from diff --git a/collects/drscheme/private/main.ss b/collects/drscheme/private/main.ss index 6dc6460a7e..33172a3f0c 100644 --- a/collects/drscheme/private/main.ss +++ b/collects/drscheme/private/main.ss @@ -66,14 +66,19 @@ (preferences:set-default 'drscheme:show-interactions-on-execute #t boolean?) (preferences:set-default 'drscheme:open-in-tabs #f boolean?) (preferences:set-default 'drscheme:toolbar-shown #t boolean?) - (preferences:set-default 'drscheme:user-defined-keybindings '() (λ (x) (and (list? x) (andmap path? x)))) + (preferences:set-default 'drscheme:user-defined-keybindings + '() + (λ (x) (and (list? x) + (andmap (λ (x) (or (path? x) (drscheme:frame:planet-spec? x))) + x)))) + (preferences:set-un/marshall 'drscheme:user-defined-keybindings - (λ (in) (map path->bytes in)) - (λ (ex) (if (and (list? ex) - (andmap bytes? ex)) - (map bytes->path ex) - '()))) + (λ (in) (map (λ (x) (if (path? x) (path->bytes x) x)) + in)) + (λ (ex) (if (list? ex) + (map (λ (x) (if (bytes? x) (bytes->path x) x)) ex) + '()))) (let ([number-between-zero-and-one? (λ (x) (and (number? x) (<= 0 x 1)))]) @@ -364,12 +369,8 @@ (autosave:restore-autosave-files/gui) ;; install user's keybindings - (with-handlers ([exn? - (λ (exn) - (message-box (string-constant drscheme) - (exn-message exn)))]) - (for-each keymap:add-user-keybindings-file - (preferences:get 'drscheme:user-defined-keybindings))) + (for-each drscheme:frame:add-keybindings-item + (preferences:get 'drscheme:user-defined-keybindings)) ;; the initial window doesn't set the ;; unit object's state correctly, yet. diff --git a/collects/framework/framework.ss b/collects/framework/framework.ss index a756f88596..5650cab6f3 100644 --- a/collects/framework/framework.ss +++ b/collects/framework/framework.ss @@ -966,18 +966,22 @@ "method.") (keymap:remove-user-keybindings-file - (-> path? any) + (-> any/c 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 " + (-> any/c any) + (user-keybindings-path-or-require-spec) + "Chains the keymap defined by \\var{user-keybindings-path-or-require-spec} to " "the global keymap, returned by " "@flink keymap:get-global %" - ".") + "." + "" + "If \\var{user-keybindings-path-or-require-spec} is a path, the module is loaded" + "directly from that path. Otherwise, \\var{user-keybindings-path-or-require-spec}" + "is treated like an argument to \\scheme|require|.") (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 3bc22533ce..ded3830871 100644 --- a/collects/framework/private/keymap.ss +++ b/collects/framework/private/keymap.ss @@ -23,27 +23,50 @@ (define user-keybindings-files (make-hash-table 'equal)) - (define (add-user-keybindings-file path) + (define (add-user-keybindings-file spec) (hash-table-get user-keybindings-files - path + spec (λ () - (let ([sexp (and (file-exists? path) - (call-with-input-file path read))]) + (let* ([path (spec->path spec)] + [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) + (let ([km (dynamic-require spec '#%keymap)]) + (hash-table-put! user-keybindings-files spec 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) + (define (spec->path p) + (cond + [(path? p) p] + [else + (let* ([mod-name ((current-module-name-resolver) p #f #f)] + [str (symbol->string mod-name)] + [pth (substring str 1 (string-length str))]) + (let-values ([(base name _) (split-path pth)]) + (let ([filenames + (sort + (filter (λ (x) (substring? (path->string name) x)) + (map path->string (directory-list base))) + (λ (x y) (> (string-length x) (string-length y))))]) + (when (null? filenames) + (error 'spec->path "could not convert ~s, found no filenames for ~s" p mod-name)) + (build-path base (car filenames)))))])) + + (define (substring? s1 s2) + (and (<= (string-length s1) + (string-length s2)) + (string=? s1 (substring s2 0 (string-length s1))))) + + (define (remove-user-keybindings-file spec) (let/ec k - (let ([km (hash-table-get user-keybindings-files path (λ () (k (void))))]) + (let ([km (hash-table-get user-keybindings-files spec (λ () (k (void))))]) (send global remove-chained-keymap km) - (hash-table-remove! user-keybindings-files path)))) + (hash-table-remove! user-keybindings-files spec)))) (define (remove-chained-keymap ed keymap-to-remove) (let ([ed-keymap (send ed get-keymap)]) diff --git a/collects/string-constants/english-string-constants.ss b/collects/string-constants/english-string-constants.ss index 6e7e887932..a42354c1ef 100644 --- a/collects/string-constants/english-string-constants.ss +++ b/collects/string-constants/english-string-constants.ss @@ -621,9 +621,16 @@ please adhere to these guidelines: (keybindings-sort-by-name "Sort by Name") (keybindings-sort-by-key "Sort by Key") (keybindings-add-user-defined-keybindings "Add User-defined Keybindings...") + (keybindings-add-user-defined-keybindings/planet "Add User-defined Keybindings from PLaneT...") (keybindings-menu-remove "Remove ~a") (keybindings-choose-user-defined-file "Please choose a file containing keybindings.") - + (keybindings-planet-malformed-spec "The PLaneT spec is malformed: ~a") ; the string will be what the user typed in + (keybindings-type-planet-spec "Please enter a PLaneT require spec (without the `require')") + + ; first ~a will be a string naming the file or planet package where the keybindings come from; + ; second ~a will be an error message + (keybindings-error-installing-file "Error when installing the keybindings ~a:\n\n~a") + (user-defined-keybinding-error "Error running keybinding ~a\n\n~a") (user-defined-keybinding-malformed-file "The file ~a does not contain a module written in the (lib \"keybinding-lang.ss\" \"framework\") language.")