suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

added ability to have user-defined keybindings in PLaneT

Browse Source 
svn: r4267
This commit is contained in:
Robby Findler 2006-09-07 03:18:39 +00:00
parent 5d37cb79e7
commit 81a70fe101
6 changed files with 130 additions and 42 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/drscheme/private/drsig.ss
View File

@ -148,7 +148,9 @@
mixin mixin
basics-mixin basics-mixin
basics<%> basics<%>
create-root-menubar)) create-root-menubar
add-keybindings-item
planet-spec?))
(define-signature drscheme:program^ (define-signature drscheme:program^
(frame%)) (frame%))

79
collects/drscheme/private/frame.ss
View File

@ -3,6 +3,7 @@
(require (lib "name-message.ss" "mrlib") (require (lib "name-message.ss" "mrlib")
(lib "string-constant.ss" "string-constants") (lib "string-constant.ss" "string-constants")
(lib "unitsig.ss") (lib "unitsig.ss")
(lib "match.ss")
(lib "class.ss") (lib "class.ss")
(lib "string.ss") (lib "string.ss")
(lib "list.ss") (lib "list.ss")
@ -29,6 +30,8 @@
(define basics<%> (interface (frame:standard-menus<%>))) (define basics<%> (interface (frame:standard-menus<%>)))
(define last-keybindings-planet-attempt "")
(define basics-mixin (define basics-mixin
(mixin (frame:standard-menus<%>) (basics<%>) (mixin (frame:standard-menus<%>) (basics<%>)
(inherit get-edit-target-window get-edit-target-object get-menu-bar) (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) (let ([filename (get-file (string-constant keybindings-choose-user-defined-file)
this)]) this)])
(when filename (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)]) (let ([ud (preferences:get 'drscheme:user-defined-keybindings)])
(unless (null? ud) (unless (null? ud)
(new separator-menu-item% (parent keybindings-menu)) (new separator-menu-item% (parent keybindings-menu))
(for-each (λ (path) (for-each (λ (item)
(new menu-item% (new menu-item%
(label (format (string-constant keybindings-menu-remove) (label (format (string-constant keybindings-menu-remove)
(path->string path))) (if (path? item)
(path->string item)
(format "~s" item))))
(parent keybindings-menu) (parent keybindings-menu)
(callback (callback
(λ (x y) (remove-keybindings-file path))))) (λ (x y) (remove-keybindings-item item)))))
ud))))))) ud)))))))
(unless (current-eventspace-has-standard-menus?) (unless (current-eventspace-has-standard-menus?)
(make-object separator-menu-item% menu))) (make-object separator-menu-item% menu)))
(super-new))) (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) (with-handlers ([exn? (λ (x)
(message-box (string-constant drscheme) (message-box (string-constant drscheme)
(exn-message x)))]) (format (string-constant keybindings-error-installing-file)
(keymap:add-user-keybindings-file path) (if (path? item)
(preferences:set 'drscheme:user-defined-keybindings (path->string item)
(cons path (format "~s" item))
(preferences:get 'drscheme:user-defined-keybindings))))) (exn-message x)))
(define (remove-keybindings-file path) #f)])
(keymap:remove-user-keybindings-file path) (keymap:add-user-keybindings-file item)
#t))
(define (remove-keybindings-item item)
(keymap:remove-user-keybindings-file item)
(preferences:set (preferences:set
'drscheme:user-defined-keybindings 'drscheme:user-defined-keybindings
(remq path (remove item
(preferences:get 'drscheme:user-defined-keybindings)))) (preferences:get 'drscheme:user-defined-keybindings))))
;; install-plt-file : (union #f dialog% frame%) -> void ;; install-plt-file : (union #f dialog% frame%) -> void
;; asks the user for a .plt file, either from the web or from ;; asks the user for a .plt file, either from the web or from

25
collects/drscheme/private/main.ss
View File

@ -66,14 +66,19 @@
(preferences:set-default 'drscheme:show-interactions-on-execute #t boolean?) (preferences:set-default 'drscheme:show-interactions-on-execute #t boolean?)
(preferences:set-default 'drscheme:open-in-tabs #f boolean?) (preferences:set-default 'drscheme:open-in-tabs #f boolean?)
(preferences:set-default 'drscheme:toolbar-shown #t 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 (preferences:set-un/marshall
'drscheme:user-defined-keybindings 'drscheme:user-defined-keybindings
(λ (in) (map path->bytes in)) (λ (in) (map (λ (x) (if (path? x) (path->bytes x) x))
(λ (ex) (if (and (list? ex) in))
(andmap bytes? ex)) (λ (ex) (if (list? ex)
(map bytes->path ex) (map (λ (x) (if (bytes? x) (bytes->path x) x)) ex)
'()))) '())))
(let ([number-between-zero-and-one? (let ([number-between-zero-and-one?
(λ (x) (and (number? x) (<= 0 x 1)))]) (λ (x) (and (number? x) (<= 0 x 1)))])
@ -364,12 +369,8 @@
(autosave:restore-autosave-files/gui) (autosave:restore-autosave-files/gui)
;; install user's keybindings ;; install user's keybindings
(with-handlers ([exn? (for-each drscheme:frame:add-keybindings-item
(λ (exn) (preferences:get 'drscheme:user-defined-keybindings))
(message-box (string-constant drscheme)
(exn-message exn)))])
(for-each keymap:add-user-keybindings-file
(preferences:get 'drscheme:user-defined-keybindings)))
;; the initial window doesn't set the ;; the initial window doesn't set the
;; unit object's state correctly, yet. ;; unit object's state correctly, yet.

14
collects/framework/framework.ss
View File

@ -966,18 +966,22 @@
"method.") "method.")
(keymap:remove-user-keybindings-file (keymap:remove-user-keybindings-file
(-> path? any) (-> any/c any)
(user-keybindings-path) (user-keybindings-path)
"Removes the keymap previously added by" "Removes the keymap previously added by"
"@flink keymap:add-user-keybindings-file %" "@flink keymap:add-user-keybindings-file %"
".") ".")
(keymap:add-user-keybindings-file (keymap:add-user-keybindings-file
(-> path? any) (-> any/c any)
(user-keybindings-path) (user-keybindings-path-or-require-spec)
"Chains the keymap defined by \\var{user-keybindings-path} to " "Chains the keymap defined by \\var{user-keybindings-path-or-require-spec} to "
"the global keymap, returned by " "the global keymap, returned by "
"@flink keymap:get-global %" "@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 (keymap:add-to-right-button-menu
(case-> (case->
(((is-a?/c popup-menu%) (is-a?/c editor<%>) (is-a?/c event%) . -> . void?) . -> . void?) (((is-a?/c popup-menu%) (is-a?/c editor<%>) (is-a?/c event%) . -> . void?) . -> . void?)

41
collects/framework/private/keymap.ss
View File

@ -23,27 +23,50 @@
(define user-keybindings-files (make-hash-table 'equal)) (define user-keybindings-files (make-hash-table 'equal))
(define (add-user-keybindings-file path) (define (add-user-keybindings-file spec)
(hash-table-get (hash-table-get
user-keybindings-files user-keybindings-files
path spec
(λ () (λ ()
(let ([sexp (and (file-exists? path) (let* ([path (spec->path spec)]
(call-with-input-file path read))]) [sexp (and (file-exists? path)
(call-with-input-file path read))])
(match sexp (match sexp
[`(module ,name (lib "keybinding-lang.ss" "framework") ,@(x ...)) [`(module ,name (lib "keybinding-lang.ss" "framework") ,@(x ...))
(let ([km (dynamic-require path '#%keymap)]) (let ([km (dynamic-require spec '#%keymap)])
(hash-table-put! user-keybindings-files path km) (hash-table-put! user-keybindings-files spec km)
(send global chain-to-keymap km #t))] (send global chain-to-keymap km #t))]
[else (error 'add-user-keybindings-file [else (error 'add-user-keybindings-file
(string-constant user-defined-keybinding-malformed-file) (string-constant user-defined-keybinding-malformed-file)
(path->string path))]))))) (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/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) (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) (define (remove-chained-keymap ed keymap-to-remove)
(let ([ed-keymap (send ed get-keymap)]) (let ([ed-keymap (send ed get-keymap)])

7
collects/string-constants/english-string-constants.ss
View File

@ -621,8 +621,15 @@ please adhere to these guidelines:
(keybindings-sort-by-name "Sort by Name") (keybindings-sort-by-name "Sort by Name")
(keybindings-sort-by-key "Sort by Key") (keybindings-sort-by-key "Sort by Key")
(keybindings-add-user-defined-keybindings "Add User-defined Keybindings...") (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-menu-remove "Remove ~a")
(keybindings-choose-user-defined-file "Please choose a file containing keybindings.") (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-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.") (user-defined-keybinding-malformed-file "The file ~a does not contain a module written in the (lib \"keybinding-lang.ss\" \"framework\") language.")