added ability to have user-defined keybindings in PLaneT
svn: r4267
This commit is contained in:
Robby Findler
parent
5d37cb79e7
commit
81a70fe101
|
|
@ -148,7 +148,9 @@
|
|||
mixin
|
||||
basics-mixin
|
||||
basics<%>
|
||||
create-root-menubar))
|
||||
create-root-menubar
|
||||
add-keybindings-item
|
||||
planet-spec?))
|
||||
|
||||
(define-signature drscheme:program^
|
||||
(frame%))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -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?)
|
||||
|
|
|
|||
|
|
@ -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)])
|
||||
|
|
|
|||
|
|
@ -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.")
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user