changed keybinding setup so that the user keybindings override all of the other keybindings (and improved the names a little)
svn: r12180
This commit is contained in:
Robby Findler
parent
eada4a5b7e
commit
ebb3efa6ba
|
|
@ -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))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; ;;;
|
||||
|
|
|
|||
|
|
@ -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 ...)))]))
|
||||
|
|
|
|||
|
|
@ -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<%>
|
||||
|
|
|
|||
|
|
@ -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%))
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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?
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user