1326 lines
49 KiB
Scheme
1326 lines
49 KiB
Scheme
|
|
(module keymap mzscheme
|
|
(require (lib "string-constant.ss" "string-constants")
|
|
(lib "unitsig.ss")
|
|
(lib "class.ss")
|
|
(lib "list.ss")
|
|
(lib "mred-sig.ss" "mred")
|
|
(lib "match.ss")
|
|
"sig.ss")
|
|
|
|
(provide keymap@)
|
|
|
|
(define keymap@
|
|
(unit/sig framework:keymap^
|
|
(import mred^
|
|
[preferences : framework:preferences^]
|
|
[finder : framework:finder^]
|
|
[handler : framework:handler^]
|
|
[frame : framework:frame^]
|
|
[editor : framework:editor^])
|
|
|
|
(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
|
|
(λ ()
|
|
(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 (λ () (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)
|
|
(error 'keymap:remove-keymap "cannot remove initial keymap from editor"))
|
|
(let p-loop ([parent-keymap ed-keymap])
|
|
(unless (is-a? parent-keymap aug-keymap<%>)
|
|
(error 'keymap:remove-keymap
|
|
"found a keymap that is not a keymap:aug-keymap<%> ~e"
|
|
parent-keymap))
|
|
(let c-loop ([child-keymaps (send parent-keymap get-chained-keymaps)])
|
|
(cond
|
|
[(null? child-keymaps) null]
|
|
[else
|
|
(let ([child-keymap (car child-keymaps)])
|
|
(cond
|
|
[(eq? child-keymap keymap-to-remove)
|
|
(send parent-keymap remove-chained-keymap child-keymap)
|
|
(c-loop (cdr child-keymaps))]
|
|
[else
|
|
(p-loop child-keymap)
|
|
(c-loop (cdr child-keymaps))]))])))))
|
|
|
|
(define (set-chained-keymaps parent-keymap children-keymaps)
|
|
(for-each (λ (orig-sub) (send parent-keymap remove-chained-keymap))
|
|
(send parent-keymap get-chained-keymaps))
|
|
(for-each (λ (new-sub) (send parent-keymap chain-to-keymap new-sub #f))
|
|
children-keymaps))
|
|
|
|
(define aug-keymap<%> (interface ((class->interface keymap%))
|
|
get-chained-keymaps
|
|
get-map-function-table
|
|
get-map-function-table/ht))
|
|
|
|
(define aug-keymap-mixin
|
|
(mixin ((class->interface keymap%)) (aug-keymap<%>)
|
|
(define chained-keymaps null)
|
|
(define/public (get-chained-keymaps) chained-keymaps)
|
|
|
|
(define/override (chain-to-keymap keymap prefix?)
|
|
(super chain-to-keymap keymap prefix?)
|
|
(set! chained-keymaps
|
|
(if prefix?
|
|
(cons keymap chained-keymaps)
|
|
(append chained-keymaps (list keymap)))))
|
|
|
|
(define/override (remove-chained-keymap keymap)
|
|
(super remove-chained-keymap keymap)
|
|
(set! chained-keymaps (remq keymap chained-keymaps)))
|
|
|
|
(define function-table (make-hash-table))
|
|
(define/public (get-function-table) function-table)
|
|
(define/override (map-function keyname fname)
|
|
(super map-function (canonicalize-keybinding-string keyname) fname)
|
|
(hash-table-put! function-table (string->symbol keyname) fname))
|
|
|
|
(define/public (get-map-function-table)
|
|
(get-map-function-table/ht (make-hash-table)))
|
|
|
|
(define/public (get-map-function-table/ht table)
|
|
(hash-table-for-each
|
|
function-table
|
|
(λ (keyname fname)
|
|
(unless (hash-table-get table keyname (λ () #f))
|
|
(hash-table-put! table keyname fname))))
|
|
(for-each
|
|
(λ (chained-keymap)
|
|
(when (is-a? chained-keymap aug-keymap<%>)
|
|
(send chained-keymap get-map-function-table/ht table)))
|
|
chained-keymaps)
|
|
table)
|
|
|
|
(super-new)))
|
|
|
|
(define aug-keymap% (aug-keymap-mixin keymap%))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;;;;;; ;;;;;;;;
|
|
;;;;;;; canonicalize-keybinding-string ;;;;;;;;
|
|
;;;;;;; ;;;;;;;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;; canonicalize-keybinding-string : string -> string
|
|
;; The result can be used with string=? to determine
|
|
;; if two key bindings refer to the same key.
|
|
;; Assumes a well-formed keystring.
|
|
(define (canonicalize-keybinding-string str)
|
|
(let* ([chars (map char-downcase (string->list str))]
|
|
[separated-keys
|
|
(map
|
|
canonicalize-single-keybinding-string
|
|
(split-out #\; chars))])
|
|
(join-strings ";" separated-keys)))
|
|
|
|
;; join-strings : string (listof string) -> string
|
|
;; concatenates strs with sep between each of them
|
|
(define (join-strings sep strs)
|
|
(if (null? strs)
|
|
""
|
|
(apply
|
|
string-append
|
|
(cons
|
|
(car strs)
|
|
(let loop ([sepd-strs (cdr strs)])
|
|
(cond
|
|
[(null? sepd-strs) null]
|
|
[else (list*
|
|
sep
|
|
(car sepd-strs)
|
|
(loop (cdr sepd-strs)))]))))))
|
|
|
|
;; canonicalize-single-keybinding-string : (listof char) -> string
|
|
(define (canonicalize-single-keybinding-string chars)
|
|
(let* ([neg? (char=? (car chars) #\:)]
|
|
[mods/key (split-out #\: (if neg? (cdr chars) chars))]
|
|
[mods
|
|
(let loop ([mods mods/key])
|
|
(cond
|
|
[(null? mods) null]
|
|
[(null? (cdr mods)) null]
|
|
[else (cons (car mods) (loop (cdr mods)))]))]
|
|
[key (apply string (car (last-pair mods/key)))]
|
|
[canon-key
|
|
(cond
|
|
[(string=? key "enter") "return"]
|
|
[(string=? key "del") "delete"]
|
|
[(string=? key "ins") "insert"]
|
|
[else key])]
|
|
[shift (if neg? #f 'd/c)]
|
|
[control (if neg? #f 'd/c)]
|
|
[alt (if neg? #f 'd/c)]
|
|
[meta (if neg? #f 'd/c)]
|
|
[command (if neg? #f 'd/c)]
|
|
|
|
[do-key
|
|
(λ (char val)
|
|
(cond
|
|
[(eq? val #t) (string char)]
|
|
[(eq? val #f) (string #\~ char)]
|
|
[(eq? val 'd/c) #f]))])
|
|
|
|
(for-each (λ (mod)
|
|
(let ([val (not (char=? (car mod) #\~))])
|
|
(case (if (char=? (car mod) #\~)
|
|
(cadr mod)
|
|
(car mod))
|
|
[(#\s) (set! shift val)]
|
|
[(#\c) (set! control val)]
|
|
[(#\a) (set! alt val)]
|
|
[(#\d) (set! command val)]
|
|
[(#\m) (set! meta val)])))
|
|
mods)
|
|
|
|
(join-strings ":"
|
|
(filter
|
|
(λ (x) x)
|
|
(list
|
|
(do-key #\a alt)
|
|
(do-key #\c control)
|
|
(do-key #\d command)
|
|
(do-key #\m meta)
|
|
(do-key #\s shift)
|
|
canon-key)))))
|
|
|
|
;; split-out : char (listof char) -> (listof (listof char))
|
|
;; splits a list of characters at its first argument
|
|
;; if the last character is the same as the first character,
|
|
;; it is not split into an empty list, but returned.
|
|
(define (split-out split-char chars)
|
|
(let loop ([chars chars]
|
|
[this-split null]
|
|
[all-split null])
|
|
(cond
|
|
[(null? chars)
|
|
(reverse (cons (reverse this-split) all-split))]
|
|
[else (let ([char (car chars)])
|
|
(cond
|
|
[(char=? split-char char)
|
|
(if (null? (cdr chars))
|
|
(loop null
|
|
(cons char this-split)
|
|
all-split)
|
|
(loop (cdr chars)
|
|
null
|
|
(cons (reverse this-split) all-split)))]
|
|
[else
|
|
(loop (cdr chars)
|
|
(cons char this-split)
|
|
all-split)]))])))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;;;;;; ;;;;;;;;
|
|
;;;;;;; end canonicalize-keybinding-string ;;;;;;;;
|
|
;;;;;;; ;;;;;;;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define (make-meta-prefix-list key)
|
|
(let ([defaults
|
|
(list (string-append "m:" key)
|
|
(string-append "ESC;" key))])
|
|
(if (eq? (system-type) 'macosx)
|
|
(cons (string-append "a:" key)
|
|
defaults)
|
|
defaults)))
|
|
|
|
(define send-map-function-meta
|
|
(λ (keymap key func)
|
|
(for-each (λ (key) (send keymap map-function key func))
|
|
(make-meta-prefix-list key))))
|
|
|
|
(define add-to-right-button-menu (make-parameter void))
|
|
(define add-to-right-button-menu/before (make-parameter void))
|
|
|
|
(define setup-global
|
|
; Define some useful keyboard functions
|
|
(let* ([ring-bell
|
|
(λ (edit event)
|
|
(bell))]
|
|
|
|
[mouse-popup-menu
|
|
(λ (edit event)
|
|
(when (send event button-down?)
|
|
(let ([a (send edit get-admin)])
|
|
(when a
|
|
(let ([m (make-object popup-menu%)])
|
|
|
|
((add-to-right-button-menu/before) m edit event)
|
|
|
|
(append-editor-operation-menu-items m)
|
|
(for-each
|
|
(λ (i)
|
|
(when (is-a? i selectable-menu-item<%>)
|
|
(send i set-shortcut #f)))
|
|
(send m get-items))
|
|
|
|
((add-to-right-button-menu) m edit event)
|
|
|
|
(let-values ([(x y) (send edit
|
|
dc-location-to-editor-location
|
|
(send event get-x)
|
|
(send event get-y))])
|
|
(send a popup-menu m (+ x 1) (+ y 1))))))))]
|
|
|
|
[toggle-anchor
|
|
(λ (edit event)
|
|
(send edit set-anchor
|
|
(not (send edit get-anchor))))]
|
|
[center-view-on-line
|
|
(λ (edit event)
|
|
(let ([new-mid-line (send edit position-line
|
|
(send edit get-start-position))]
|
|
[bt (box 0)]
|
|
[bb (box 0)])
|
|
(send edit get-visible-line-range bt bb #f)
|
|
(let* ([half (sub1 (quotient (- (unbox bb) (unbox bt)) 2))]
|
|
[last-pos (send edit position-line (send edit last-position))]
|
|
[top-pos (send edit line-start-position
|
|
(max (min (- new-mid-line half) last-pos) 0))]
|
|
[bottom-pos (send edit line-start-position
|
|
(max 0
|
|
(min (+ new-mid-line half)
|
|
last-pos)))])
|
|
(send edit scroll-to-position
|
|
top-pos
|
|
#f
|
|
bottom-pos)))
|
|
#t)]
|
|
|
|
[make-insert-brace-pair
|
|
(λ (open-brace close-brace)
|
|
(λ (edit event)
|
|
(send edit begin-edit-sequence)
|
|
(let ([selection-start (send edit get-start-position)])
|
|
(send edit set-position (send edit get-end-position))
|
|
(send edit insert close-brace)
|
|
(send edit set-position selection-start)
|
|
(send edit insert open-brace))
|
|
(send edit end-edit-sequence)))]
|
|
|
|
[insert-lambda-template
|
|
(λ (edit event)
|
|
(send edit begin-edit-sequence)
|
|
(let ([selection-start (send edit get-start-position)])
|
|
(send edit set-position (send edit get-end-position))
|
|
(send edit insert ")")
|
|
(send edit set-position selection-start)
|
|
(send edit insert ") ")
|
|
(send edit set-position selection-start)
|
|
(send edit insert "(λ ("))
|
|
(send edit end-edit-sequence))]
|
|
|
|
[collapse-variable-space
|
|
;; As per emacs: collapse tabs & spaces around the point,
|
|
;; perhaps leaving a single space.
|
|
;; drscheme bonus: if at end-of-line, collapse into the next line.
|
|
(λ (leave-one? edit event)
|
|
(letrec ([last-pos (send edit last-position)]
|
|
[sel-start (send edit get-start-position)]
|
|
[sel-end (send edit get-end-position)]
|
|
[collapsible? (λ (c) (and (char-whitespace? c)
|
|
(not (char=? #\newline c))))]
|
|
[find-noncollapsible
|
|
; Return index of next non-collapsible char,
|
|
; starting at pos in direction dir.
|
|
; NB returns -1 or last-pos, if examining
|
|
; initial/final whitespace
|
|
; (or, when initial pos is outside of [0,last-pos).)
|
|
(λ (pos dir)
|
|
(let loop ([pos pos])
|
|
(cond [(< pos 0) -1]
|
|
[(>= pos last-pos) last-pos]
|
|
[(collapsible? (send edit get-character pos))
|
|
(loop (+ pos dir))]
|
|
[else pos])))])
|
|
(when (= sel-start sel-end) ; Only when no selection:
|
|
(let* ([start (add1 (find-noncollapsible (sub1 sel-start) -1))]
|
|
[end-heeding-eol (find-noncollapsible sel-start +1)]
|
|
; This is the end of the range, were we to always heed newlines.
|
|
|
|
; Special case: if we're sitting at EOL,
|
|
; and we're not affecting much else,
|
|
; then delete that EOL and collapse spaces
|
|
; at the start of next line, too:
|
|
[end (if (and (<= (- end-heeding-eol start)
|
|
(if leave-one? 1 0))
|
|
(char=? #\newline (send edit get-character end-heeding-eol))
|
|
; If you wish to avoid deleting an newline at EOF, do so here.
|
|
)
|
|
(find-noncollapsible (add1 end-heeding-eol) +1)
|
|
end-heeding-eol)]
|
|
[making-no-difference?
|
|
; Don't introduce edits into undo-chain, if no effect.
|
|
(if leave-one?
|
|
(and (= (- end start) 1)
|
|
(char=? #\space (send edit get-character start)))
|
|
(= (- end start) 0))])
|
|
(unless making-no-difference?
|
|
(send edit begin-edit-sequence)
|
|
(send edit set-position end) ; Even after delete, caret will be at "end".
|
|
(send edit delete start end)
|
|
(when leave-one? (send edit insert #\space start))
|
|
(send edit end-edit-sequence))))))]
|
|
|
|
[collapse-space
|
|
(λ (edit event)
|
|
(collapse-variable-space #t edit event))]
|
|
|
|
[remove-space
|
|
(λ (edit event)
|
|
(collapse-variable-space #f edit event))]
|
|
|
|
[collapse-newline
|
|
(λ (edit event)
|
|
(letrec ([find-nonwhite
|
|
(λ (pos d offset)
|
|
(let/ec escape
|
|
(let ([max (if (> offset 0)
|
|
(send edit last-position)
|
|
0)])
|
|
(let loop ([pos pos])
|
|
(if (= pos max)
|
|
(escape pos)
|
|
(let ([c (send edit get-character (+ pos offset))])
|
|
(cond
|
|
[(char=? #\newline c)
|
|
(loop (+ pos d))
|
|
(escape pos)]
|
|
[(char-whitespace? c)
|
|
(loop (+ pos d))]
|
|
[else pos])))))))])
|
|
(let ([sel-start (send edit get-start-position)]
|
|
[sel-end (send edit get-end-position)])
|
|
(when (= sel-start sel-end)
|
|
(let* ([pos-line (send edit position-line sel-start #f)]
|
|
[pos-line-start (send edit line-start-position pos-line)]
|
|
[pos-line-end (send edit line-end-position pos-line)]
|
|
|
|
[whiteline?
|
|
(let loop ([pos pos-line-start])
|
|
(if (>= pos pos-line-end)
|
|
#t
|
|
(and (char-whitespace? (send edit get-character pos))
|
|
(loop (add1 pos)))))]
|
|
|
|
[start (find-nonwhite pos-line-start -1 -1)]
|
|
[end (find-nonwhite pos-line-end 1 0)]
|
|
|
|
[start-line
|
|
(send edit position-line start #f)]
|
|
[start-line-start
|
|
(send edit line-start-position start-line)]
|
|
[end-line
|
|
(send edit position-line end #f)]
|
|
[end-line-start
|
|
(send edit line-start-position (add1 end-line))])
|
|
(cond
|
|
[(and whiteline?
|
|
(= start-line pos-line)
|
|
(= end-line pos-line))
|
|
; Special case: just delete this line
|
|
(send edit delete pos-line-start (add1 pos-line-end))]
|
|
[(and whiteline? (< start-line pos-line))
|
|
; Can delete before & after
|
|
(send* edit
|
|
(begin-edit-sequence)
|
|
(delete (add1 pos-line-end) end-line-start)
|
|
(delete start-line-start pos-line-start)
|
|
(end-edit-sequence))]
|
|
[else
|
|
; Only delete after
|
|
(send edit delete (add1 pos-line-end)
|
|
end-line-start)]))))))]
|
|
|
|
[open-line
|
|
(λ (edit event)
|
|
(let ([sel-start (send edit get-start-position)]
|
|
[sel-end (send edit get-end-position)])
|
|
(if (= sel-start sel-end)
|
|
(send* edit
|
|
(insert #\newline)
|
|
(set-position sel-start)))))]
|
|
|
|
[transpose-chars
|
|
(λ (edit event)
|
|
(let ([sel-start (send edit get-start-position)]
|
|
[sel-end (send edit get-end-position)])
|
|
(when (and (= sel-start sel-end)
|
|
(not (= sel-start 0)))
|
|
|
|
(let ([sel-start
|
|
(if (= sel-start
|
|
(send edit line-end-position
|
|
(send edit position-line sel-start)))
|
|
(sub1 sel-start)
|
|
sel-start)])
|
|
(let ([s (send edit get-text
|
|
sel-start (add1 sel-start))])
|
|
(send* edit
|
|
(begin-edit-sequence)
|
|
(delete sel-start (add1 sel-start))
|
|
(insert s (- sel-start 1))
|
|
(set-position (add1 sel-start))
|
|
(end-edit-sequence)))))))]
|
|
|
|
[transpose-words
|
|
(λ (edit event)
|
|
(let ([sel-start (send edit get-start-position)]
|
|
[sel-end (send edit get-end-position)])
|
|
(when (= sel-start sel-end)
|
|
(let ([word-1-start (box sel-start)])
|
|
(send edit find-wordbreak word-1-start #f 'caret)
|
|
(let ([word-1-end (box (unbox word-1-start))])
|
|
(send edit find-wordbreak #f word-1-end 'caret)
|
|
(let ([word-2-end (box (unbox word-1-end))])
|
|
(send edit find-wordbreak #f word-2-end 'caret)
|
|
(let ([word-2-start (box (unbox word-2-end))])
|
|
(send edit find-wordbreak word-2-start #f 'caret)
|
|
(let ([text-1 (send edit get-text
|
|
(unbox word-1-start)
|
|
(unbox word-1-end))]
|
|
[text-2 (send edit get-text
|
|
(unbox word-2-start)
|
|
(unbox word-2-end))])
|
|
(send* edit
|
|
(begin-edit-sequence)
|
|
(insert text-1
|
|
(unbox word-2-start)
|
|
(unbox word-2-end))
|
|
(insert text-2
|
|
(unbox word-1-start)
|
|
(unbox word-1-end))
|
|
(set-position (unbox word-2-end))
|
|
(end-edit-sequence))))))))))]
|
|
|
|
[capitalize-it
|
|
(λ (edit char-case1 char-case2)
|
|
(let ([sel-start (send edit get-start-position)]
|
|
[sel-end (send edit get-end-position)]
|
|
[real-end (send edit last-position)])
|
|
(when (= sel-start sel-end)
|
|
(let ([word-end (let ([b (box sel-start)])
|
|
(send edit find-wordbreak #f b 'caret)
|
|
(min real-end (unbox b)))])
|
|
(send edit begin-edit-sequence)
|
|
(let loop ([pos sel-start]
|
|
[char-case char-case1])
|
|
(when (< pos word-end)
|
|
(let ([c (send edit get-character pos)])
|
|
(cond
|
|
[(char-alphabetic? c)
|
|
(send edit insert
|
|
(list->string
|
|
(list (char-case c)))
|
|
pos (add1 pos))
|
|
(loop (add1 pos) char-case2)]
|
|
[else
|
|
(loop (add1 pos) char-case)]))))
|
|
(send* edit
|
|
(end-edit-sequence)
|
|
(set-position word-end))))))]
|
|
|
|
[capitalize-word
|
|
(λ (edit event)
|
|
(capitalize-it edit char-upcase char-downcase))]
|
|
[upcase-word
|
|
(λ (edit event)
|
|
(capitalize-it edit char-upcase char-upcase))]
|
|
[downcase-word
|
|
(λ (edit event)
|
|
(capitalize-it edit char-downcase char-downcase))]
|
|
|
|
[kill-word
|
|
(λ (edit event)
|
|
(let ([sel-start (send edit get-start-position)]
|
|
[sel-end (send edit get-end-position)])
|
|
(let ([end-box (box sel-end)])
|
|
(send edit find-wordbreak #f end-box 'caret)
|
|
(send edit kill 0 sel-start (unbox end-box)))))]
|
|
|
|
[backward-kill-word
|
|
(λ (edit event)
|
|
(let ([sel-start (send edit get-start-position)]
|
|
[sel-end (send edit get-end-position)])
|
|
(let ([start-box (box sel-start)])
|
|
(send edit find-wordbreak start-box #f 'caret)
|
|
(send edit kill 0 (unbox start-box) sel-end))))]
|
|
|
|
[region-click
|
|
(λ (edit event f)
|
|
(when (and (send event button-down?)
|
|
(is-a? edit text%))
|
|
(let ([x-box (box (send event get-x))]
|
|
[y-box (box (send event get-y))]
|
|
[eol-box (box #f)])
|
|
(send edit global-to-local x-box y-box)
|
|
(let ([click-pos (send edit find-position
|
|
(unbox x-box)
|
|
(unbox y-box)
|
|
eol-box)]
|
|
[start-pos (send edit get-start-position)]
|
|
[end-pos (send edit get-end-position)])
|
|
(let ([eol (unbox eol-box)])
|
|
(if (< start-pos click-pos)
|
|
(f click-pos eol start-pos click-pos)
|
|
(f click-pos eol click-pos end-pos)))))))]
|
|
[copy-click-region
|
|
(λ (edit event)
|
|
(region-click edit event
|
|
(λ (click eol start end)
|
|
(send edit flash-on start end)
|
|
(send edit copy #f 0 start end))))]
|
|
[cut-click-region
|
|
(λ (edit event)
|
|
(region-click edit event
|
|
(λ (click eol start end)
|
|
(send edit cut #f 0 start end))))]
|
|
[paste-click-region
|
|
(λ (edit event)
|
|
(region-click edit event
|
|
(λ (click eol start end)
|
|
(send edit set-position click)
|
|
(send edit paste-x-selection 0 click))))]
|
|
|
|
[mouse-copy-clipboard
|
|
(λ (edit event)
|
|
(send edit copy #f (send event get-time-stamp)))]
|
|
|
|
[mouse-paste-clipboard
|
|
(λ (edit event)
|
|
(send edit paste (send event get-time-stamp)))]
|
|
|
|
[mouse-cut-clipboard
|
|
(λ (edit event)
|
|
(send edit cut #f (send event get-time-stamp)))]
|
|
|
|
[select-click-word
|
|
(λ (edit event)
|
|
(region-click edit event
|
|
(λ (click eol start end)
|
|
(let ([start-box (box click)]
|
|
[end-box (box click)])
|
|
(send edit find-wordbreak
|
|
start-box
|
|
end-box
|
|
'selection)
|
|
(send edit set-position
|
|
(unbox start-box)
|
|
(unbox end-box))))))]
|
|
[select-click-line
|
|
(λ (edit event)
|
|
(region-click edit event
|
|
(λ (click eol start end)
|
|
(let* ([line (send edit position-line
|
|
click eol)]
|
|
[start (send edit line-start-position
|
|
line #f)]
|
|
[end (send edit line-end-position
|
|
line #f)])
|
|
(send edit set-position start end)))))]
|
|
|
|
[goto-line
|
|
(λ (edit event)
|
|
(let ([num-str
|
|
(call/text-keymap-initializer
|
|
(λ ()
|
|
(get-text-from-user
|
|
(string-constant goto-line)
|
|
(string-constant goto-line))))])
|
|
(when (string? num-str)
|
|
(let ([line-num (inexact->exact (string->number num-str))])
|
|
(cond
|
|
[(and (number? line-num)
|
|
(= line-num (floor line-num))
|
|
(<= 1 line-num (+ (send edit last-paragraph) 1)))
|
|
(let ([pos (send edit paragraph-start-position
|
|
(sub1 line-num))])
|
|
(send edit set-position pos))]
|
|
[else
|
|
(message-box
|
|
(string-constant goto-line)
|
|
(format
|
|
(string-constant goto-line-invalid-number)
|
|
num-str
|
|
(+ (send edit last-line) 1)))]))))
|
|
|
|
#t)]
|
|
[goto-position
|
|
(λ (edit event)
|
|
(let ([num-str
|
|
(call/text-keymap-initializer
|
|
(λ ()
|
|
(get-text-from-user
|
|
(string-constant goto-position)
|
|
(string-constant goto-position))))])
|
|
(if (string? num-str)
|
|
(let ([pos (string->number num-str)])
|
|
(when pos
|
|
(send edit set-position (sub1 pos))))))
|
|
#t)]
|
|
[repeater
|
|
(λ (n edit)
|
|
(let* ([km (send edit get-keymap)]
|
|
[done
|
|
(λ ()
|
|
(send km set-break-sequence-callback void)
|
|
(send km remove-grab-key-function))])
|
|
(send km set-grab-key-function
|
|
(λ (name local-km edit event)
|
|
(if name
|
|
(begin
|
|
(done)
|
|
(dynamic-wind
|
|
(λ ()
|
|
(send edit begin-edit-sequence))
|
|
(λ ()
|
|
(let loop ([n n])
|
|
(unless (zero? n)
|
|
(send local-km call-function name edit event)
|
|
(loop (sub1 n)))))
|
|
(λ ()
|
|
(send edit end-edit-sequence))))
|
|
(let ([k (send event get-key-code)])
|
|
(if (and (char? k) (char<=? #\0 k #\9))
|
|
(set! n (+ (* n 10) (- (char->integer k)
|
|
(char->integer #\0))))
|
|
(begin
|
|
(done)
|
|
(dynamic-wind
|
|
(λ ()
|
|
(send edit begin-edit-sequence))
|
|
(λ ()
|
|
(let loop ([n n])
|
|
(unless (zero? n)
|
|
(send edit on-char event)
|
|
(loop (sub1 n)))))
|
|
(λ ()
|
|
(send edit end-edit-sequence)))))))
|
|
#t))
|
|
(send km set-break-sequence-callback done)
|
|
#t))]
|
|
[make-make-repeater
|
|
(λ (n)
|
|
(λ (edit event)
|
|
(repeater n edit)))]
|
|
[current-macro '()]
|
|
[building-macro #f] [build-macro-km #f] [build-protect? #f]
|
|
[show/hide-keyboard-macro-icon
|
|
(λ (edit on?)
|
|
(when (is-a? edit editor:basic<%>)
|
|
(let ([frame (send edit get-top-level-window)])
|
|
(when (is-a? frame frame:text-info<%>)
|
|
(send frame set-macro-recording on?)
|
|
(send frame update-shown)))))]
|
|
|
|
[do-macro
|
|
(λ (edit event)
|
|
; If c:x;e during record, copy the old macro
|
|
(when building-macro
|
|
(set! building-macro (append (reverse current-macro)
|
|
(cdr building-macro))))
|
|
(let ([bm building-macro]
|
|
[km (send edit get-keymap)])
|
|
(dynamic-wind
|
|
(λ ()
|
|
(set! building-macro #f)
|
|
(send edit begin-edit-sequence))
|
|
(λ ()
|
|
(let/ec escape
|
|
(for-each
|
|
(λ (f)
|
|
(let ([name (car f)]
|
|
[event (cdr f)])
|
|
(if name
|
|
(unless (send km call-function name edit event #t)
|
|
(escape #t))
|
|
(send edit on-char event))))
|
|
current-macro)))
|
|
(λ ()
|
|
(send edit end-edit-sequence)
|
|
(set! building-macro bm))))
|
|
#t)]
|
|
[start-macro
|
|
(λ (edit event)
|
|
(if building-macro
|
|
(send build-macro-km break-sequence)
|
|
(letrec ([km (send edit get-keymap)]
|
|
[done
|
|
(λ ()
|
|
(if build-protect?
|
|
(send km set-break-sequence-callback done)
|
|
(begin
|
|
(set! building-macro #f)
|
|
(show/hide-keyboard-macro-icon edit #f)
|
|
(send km set-break-sequence-callback void)
|
|
(send km remove-grab-key-function))))])
|
|
(set! building-macro '())
|
|
(show/hide-keyboard-macro-icon edit #t)
|
|
(set! build-macro-km km)
|
|
(send km set-grab-key-function
|
|
(λ (name local-km edit event)
|
|
(dynamic-wind
|
|
(λ ()
|
|
(set! build-protect? #t))
|
|
(λ ()
|
|
(if name
|
|
(send local-km call-function name edit event)
|
|
(send edit on-default-char event)))
|
|
(λ ()
|
|
(set! build-protect? #f)))
|
|
(when building-macro
|
|
(set! building-macro
|
|
(cons (cons name event)
|
|
building-macro)))
|
|
#t))
|
|
(send km set-break-sequence-callback done)))
|
|
#t)]
|
|
[end-macro
|
|
(λ (edit event)
|
|
(when building-macro
|
|
(set! current-macro (reverse building-macro))
|
|
(set! build-protect? #f)
|
|
(send build-macro-km break-sequence))
|
|
#t)]
|
|
[delete-key
|
|
(λ (edit event)
|
|
(let ([kmap (send edit get-keymap)])
|
|
(send kmap call-function
|
|
(if (preferences:get 'framework:delete-forward?)
|
|
"delete-next-character"
|
|
"delete-previous-character")
|
|
edit event #t)))]
|
|
|
|
[toggle-overwrite
|
|
(λ (edit event)
|
|
(send edit set-overwrite-mode
|
|
(not (send edit get-overwrite-mode))))]
|
|
|
|
[down-into-embedded-editor
|
|
(λ (text event)
|
|
(let ([start (send text get-start-position)]
|
|
[end (send text get-end-position)])
|
|
(when (= start end)
|
|
(let* ([bx (box 0)]
|
|
[after-snip (send text find-snip start 'after-or-none bx)])
|
|
(cond
|
|
[(and (= (unbox bx) start)
|
|
after-snip
|
|
(is-a? after-snip editor-snip%))
|
|
(let ([embedded-editor (send after-snip get-editor)])
|
|
(when (is-a? embedded-editor text%)
|
|
(send embedded-editor set-position 0))
|
|
(send embedded-editor set-caret-owner #f 'global))]
|
|
[else
|
|
(let ([before-snip (send text find-snip start 'before-or-none bx)])
|
|
(when (and (= (+ (unbox bx) 1) start)
|
|
before-snip
|
|
(is-a? before-snip editor-snip%))
|
|
(let ([embedded-editor (send before-snip get-editor)])
|
|
(when (is-a? embedded-editor text%)
|
|
(send embedded-editor set-position
|
|
(send embedded-editor last-position)))
|
|
(send embedded-editor set-caret-owner #f 'global))))]))))
|
|
#t)]
|
|
|
|
[forward-to-next-embedded-editor
|
|
(λ (text event)
|
|
(let ([start-pos (send text get-start-position)]
|
|
[end-pos (send text get-end-position)])
|
|
(when (= start-pos end-pos)
|
|
(let loop ([snip (send text find-snip start-pos 'after-or-none)])
|
|
(cond
|
|
[(not snip) (void)]
|
|
[(is-a? snip editor-snip%)
|
|
(send text set-position (send text get-snip-position snip))]
|
|
[else (loop (send snip next))]))))
|
|
#t)]
|
|
|
|
[back-to-prev-embedded-editor
|
|
(λ (text event)
|
|
(let ([start-pos (send text get-start-position)]
|
|
[end-pos (send text get-end-position)])
|
|
(when (= start-pos end-pos)
|
|
(let loop ([snip (send text find-snip start-pos 'before-or-none)])
|
|
(cond
|
|
[(not snip) (void)]
|
|
[(is-a? snip editor-snip%)
|
|
(send text set-position (+ (send text get-snip-position snip) 1))]
|
|
[else (loop (send snip previous))]))))
|
|
#t)]
|
|
|
|
[up-out-of-embedded-editor
|
|
(λ (text event)
|
|
(let ([start (send text get-start-position)]
|
|
[end (send text get-end-position)])
|
|
(when (= start end)
|
|
(let ([editor-admin (send text get-admin)])
|
|
(when (is-a? editor-admin editor-snip-editor-admin<%>)
|
|
(let* ([snip (send editor-admin get-snip)]
|
|
[snip-admin (send snip get-admin)])
|
|
(when snip-admin
|
|
(let ([editor (send snip-admin get-editor)])
|
|
(when (is-a? editor text%)
|
|
(let ([new-pos (send editor get-snip-position snip)])
|
|
(send editor set-position new-pos new-pos))
|
|
(send editor set-caret-owner #f 'display)))))))))
|
|
#t)]
|
|
|
|
[make-read-only
|
|
(λ (text event)
|
|
(send text lock #t)
|
|
#t)])
|
|
|
|
(λ (kmap)
|
|
(let* ([map (λ (key func)
|
|
(send kmap map-function key func))]
|
|
[map-meta (λ (key func)
|
|
(send-map-function-meta kmap key func))]
|
|
[add (λ (name func)
|
|
(send kmap add-function name func))]
|
|
[add-m (λ (name func)
|
|
(send kmap add-function name func))])
|
|
|
|
; Map names to keyboard functions
|
|
|
|
(add "down-into-embedded-editor" down-into-embedded-editor)
|
|
(add "up-out-of-embedded-editor" up-out-of-embedded-editor)
|
|
(add "forward-to-next-embedded-editor" forward-to-next-embedded-editor)
|
|
(add "back-to-prev-embedded-editor" back-to-prev-embedded-editor)
|
|
|
|
(add "toggle-overwrite" toggle-overwrite)
|
|
|
|
(add "exit" (λ (edit event)
|
|
(let ([frame (send edit get-frame)])
|
|
(if (and frame
|
|
(is-a? frame frame:standard-menus<%>))
|
|
(send frame file-menu:quit)
|
|
(bell)))))
|
|
|
|
(add "ring-bell" ring-bell)
|
|
|
|
(add "insert-()-pair" (make-insert-brace-pair "(" ")"))
|
|
(add "insert-[]-pair" (make-insert-brace-pair "[" "]"))
|
|
(add "insert-{}-pair" (make-insert-brace-pair "{" "}"))
|
|
(add "insert-\"\"-pair" (make-insert-brace-pair "\"" "\""))
|
|
(add "insert-||-pair" (make-insert-brace-pair "|" "|"))
|
|
(add "insert-lambda-template" insert-lambda-template)
|
|
|
|
(add "toggle-anchor" toggle-anchor)
|
|
(add "center-view-on-line" center-view-on-line)
|
|
(add "collapse-space" collapse-space)
|
|
(add "remove-space" remove-space)
|
|
(add "collapse-newline" collapse-newline)
|
|
(add "open-line" open-line)
|
|
(add "transpose-chars" transpose-chars)
|
|
(add "transpose-words" transpose-words)
|
|
(add "capitalize-word" capitalize-word)
|
|
(add "upcase-word" upcase-word)
|
|
(add "downcase-word" downcase-word)
|
|
(add "kill-word" kill-word)
|
|
(add "backward-kill-word" backward-kill-word)
|
|
|
|
(let loop ([n 9])
|
|
(unless (negative? n)
|
|
(let ([s (number->string n)])
|
|
(add (string-append "command-repeat-" s)
|
|
(make-make-repeater n))
|
|
(loop (sub1 n)))))
|
|
|
|
(add "keyboard-macro-run-saved" do-macro)
|
|
(add "keyboard-macro-start-record" start-macro)
|
|
(add "keyboard-macro-end-record" end-macro)
|
|
|
|
(add-m "copy-clipboard" mouse-copy-clipboard)
|
|
(add-m "cut-clipboard" mouse-cut-clipboard)
|
|
(add-m "paste-clipboard" mouse-paste-clipboard)
|
|
(add-m "copy-click-region" copy-click-region)
|
|
(add-m "cut-click-region" cut-click-region)
|
|
(add-m "paste-click-region" paste-click-region)
|
|
(add-m "select-click-word" select-click-word)
|
|
(add-m "select-click-line" select-click-line)
|
|
|
|
(add "goto-line" goto-line)
|
|
(add "goto-position" goto-position)
|
|
|
|
(add "delete-key" delete-key)
|
|
|
|
(add "mouse-popup-menu" mouse-popup-menu)
|
|
|
|
(add "make-read-only" make-read-only)
|
|
|
|
; Map keys to functions
|
|
|
|
(map-meta "c:down" "down-into-embedded-editor")
|
|
(map "a:c:down" "down-into-embedded-editor")
|
|
(map-meta "c:up" "up-out-of-embedded-editor")
|
|
(map "a:c:up" "up-out-of-embedded-editor")
|
|
(map-meta "c:right" "forward-to-next-embedded-editor")
|
|
(map "a:c:right" "forward-to-next-embedded-editor")
|
|
(map-meta "c:left" "back-to-prev-embedded-editor")
|
|
(map "a:c:left" "back-to-prev-embedded-editor")
|
|
|
|
(map "c:g" "ring-bell")
|
|
(map-meta "c:g" "ring-bell")
|
|
(map "c:x;c:g" "ring-bell")
|
|
(map "c:c;c:g" "ring-bell")
|
|
|
|
(map-meta "(" "insert-()-pair")
|
|
(map-meta "[" "insert-[]-pair")
|
|
(map-meta "{" "insert-{}-pair")
|
|
(map-meta "\"" "insert-\"\"-pair")
|
|
(map-meta "|" "insert-||-pair")
|
|
(map-meta "s:l" "insert-lambda-template")
|
|
|
|
(map "c:p" "previous-line")
|
|
(map "up" "previous-line")
|
|
(map "s:c:p" "select-up")
|
|
(map "s:up" "select-up")
|
|
|
|
(map "c:n" "next-line")
|
|
(map "down" "next-line")
|
|
(map "s:c:n" "select-down")
|
|
(map "s:down" "select-down")
|
|
|
|
(map "c:e" "end-of-line")
|
|
(map "d:right" "end-of-line")
|
|
(map "m:right" "end-of-line")
|
|
(map "end" "end-of-line")
|
|
(map "m:s:right" "select-to-end-of-line")
|
|
(map "s:end" "select-to-end-of-line")
|
|
(map "s:c:e" "select-to-end-of-line")
|
|
|
|
(map "c:a" "beginning-of-line")
|
|
(map "d:left" "beginning-of-line")
|
|
(map "m:left" "beginning-of-line")
|
|
(map "home" "beginning-of-line")
|
|
(map "m:s:left" "select-to-beginning-of-line")
|
|
(map "s:home" "select-to-beginning-of-line")
|
|
(map "s:c:a" "select-to-beginning-of-line")
|
|
|
|
(map "c:f" "forward-character")
|
|
(map "right" "forward-character")
|
|
(map "s:c:f" "forward-select")
|
|
(map "s:right" "forward-select")
|
|
|
|
(map "c:b" "backward-character")
|
|
(map "left" "backward-character")
|
|
(map "s:c:b" "backward-select")
|
|
(map "s:left" "backward-select")
|
|
|
|
(map-meta "f" "forward-word")
|
|
(map "a:right" "forward-word")
|
|
(map "c:right" "forward-word")
|
|
(map-meta "s:f" "forward-select-word")
|
|
(map "a:s:right" "forward-select-word")
|
|
(map "c:s:right" "forward-select-word")
|
|
|
|
(map-meta "b" "backward-word")
|
|
(map "a:left" "backward-word")
|
|
|
|
(map "c:left" "backward-word")
|
|
(map-meta "s:b" "backward-select-word")
|
|
(map "a:s:left" "backward-select-word")
|
|
(map "c:s:left" "backward-select-word")
|
|
|
|
(map-meta "<" "beginning-of-file")
|
|
(map "d:up" "beginning-of-file")
|
|
(map "c:home" "beginning-of-file")
|
|
(map "s:c:home" "select-to-beginning-of-file")
|
|
(map "s:d:up" "select-to-beginning-of-file")
|
|
|
|
(map-meta ">" "end-of-file")
|
|
(map "d:down" "end-of-file")
|
|
(map "c:end" "end-of-file")
|
|
(map "s:c:end" "select-to-end-of-file")
|
|
(map "s:d:down" "select-to-end-of-file")
|
|
|
|
(map "c:v" "next-page")
|
|
(map "a:down" "next-page")
|
|
(map "pagedown" "next-page")
|
|
(map "c:down" "next-page")
|
|
(map "s:c:v" "select-page-down")
|
|
(map "a:s:down" "select-page-down")
|
|
(map "s:pagedown" "select-page-down")
|
|
(map "s:c:down" "select-page-down")
|
|
|
|
(map-meta "v" "previous-page")
|
|
(map "a:up" "previous-page")
|
|
(map "pageup" "previous-page")
|
|
(map "c:up" "previous-page")
|
|
(map-meta "s:v" "select-page-up")
|
|
(map "s:a:up" "select-page-up")
|
|
(map "s:pageup" "select-page-up")
|
|
(map "s:c:up" "select-page-up")
|
|
|
|
(map "c:h" "delete-previous-character")
|
|
(map "c:d" "delete-next-character")
|
|
(map "del" "delete-key")
|
|
|
|
(map-meta "d" "kill-word")
|
|
(map-meta "del" "backward-kill-word")
|
|
(map-meta "c" "capitalize-word")
|
|
(map-meta "u" "upcase-word")
|
|
(map-meta "l" "downcase-word")
|
|
|
|
(map "c:l" "center-view-on-line")
|
|
|
|
(map "c:k" "delete-to-end-of-line")
|
|
(map "c:y" "paste-clipboard")
|
|
(map-meta "y" "paste-next")
|
|
(map "a:v" "paste-clipboard")
|
|
(map "d:v" "paste-clipboard")
|
|
(map "c:_" "undo")
|
|
(map "c:/" "undo")
|
|
(map (format "~a" (integer->char 31)) "undo") ; for Windows - strange
|
|
(map "c:+" "redo")
|
|
(map "a:z" "undo")
|
|
(map "d:z" "undo")
|
|
(map "c:x;u" "undo")
|
|
(map "c:w" "cut-clipboard")
|
|
(map "a:x" "cut-clipboard")
|
|
(map "d:x" "cut-clipboard")
|
|
(map-meta "w" "copy-clipboard")
|
|
(map "a:c" "copy-clipboard")
|
|
(map "d:c" "copy-clipboard")
|
|
|
|
(map "s:delete" "cut-clipboard")
|
|
(map "c:insert" "copy-clipboard")
|
|
(map "s:insert" "paste-clipboard")
|
|
|
|
(map-meta "space" "collapse-space")
|
|
;(map-meta "\\" "remove-space") ; Conflicts with european keyboards.
|
|
(map "c:x;c:o" "collapse-newline")
|
|
(map "c:o" "open-line")
|
|
(map "c:t" "transpose-chars")
|
|
(map-meta "t" "transpose-words")
|
|
|
|
(map "c:space" "toggle-anchor")
|
|
|
|
(map "insert" "toggle-overwrite")
|
|
(map-meta "o" "toggle-overwrite")
|
|
|
|
(map-meta "g" "goto-line")
|
|
(map-meta "p" "goto-position")
|
|
|
|
(map "c:u" "command-repeat-0")
|
|
(let loop ([n 9])
|
|
(unless (negative? n)
|
|
(let ([s (number->string n)])
|
|
(map-meta s (string-append "command-repeat-" s))
|
|
(loop (sub1 n)))))
|
|
|
|
(map "c:x;e" "keyboard-macro-run-saved")
|
|
(map "c:x;(" "keyboard-macro-start-record")
|
|
(map "c:x;)" "keyboard-macro-end-record")
|
|
|
|
(map "leftbuttontriple" "select-click-line")
|
|
(map "leftbuttondouble" "select-click-word")
|
|
|
|
;; the "roller ball" mice map clicking the ball to button 2.
|
|
(unless (eq? (system-type) 'windows)
|
|
(map "middlebutton" "paste-click-region"))
|
|
|
|
(map ":rightbuttonseq" "mouse-popup-menu")
|
|
|
|
(map "c:c;c:r" "make-read-only")
|
|
))))
|
|
|
|
(define setup-search
|
|
(let* ([send-frame
|
|
(λ (invoke-method)
|
|
(λ (edit event)
|
|
(let ([frame
|
|
(cond
|
|
[(is-a? edit editor<%>)
|
|
(let ([canvas (send edit get-active-canvas)])
|
|
(and canvas
|
|
(send canvas get-top-level-window)))]
|
|
[(is-a? edit area<%>)
|
|
(send edit get-top-level-window)]
|
|
[else #f])])
|
|
(if frame
|
|
(invoke-method frame)
|
|
(bell)))
|
|
#t))])
|
|
(λ (kmap)
|
|
(let* ([map (λ (key func)
|
|
(send kmap map-function key func))]
|
|
[map-meta (λ (key func)
|
|
(send-map-function-meta kmap key func))]
|
|
[add (λ (name func)
|
|
(send kmap add-function name func))]
|
|
[add-m (λ (name func)
|
|
(send kmap add-function name func))])
|
|
|
|
(add "move-to-search-or-search"
|
|
(send-frame (λ (f) (send f move-to-search-or-search)))) ;; key 1
|
|
(add "move-to-search-or-reverse-search"
|
|
(send-frame (λ (f) (send f move-to-search-or-reverse-search)))) ;; key 1b, backwards
|
|
(add "find-string-again"
|
|
(send-frame (λ (f) (send f search-again)))) ;; key 2
|
|
(add "toggle-search-focus"
|
|
(send-frame (λ (f) (send f toggle-search-focus)))) ;; key 3
|
|
(add "hide-search"
|
|
(send-frame (λ (f) (send f hide-search)))) ;; key 4
|
|
|
|
(case (system-type)
|
|
[(unix)
|
|
(map "c:s" "move-to-search-or-search")
|
|
(map-meta "%" "move-to-search-or-search")
|
|
(map "c:r" "move-to-search-or-reverse-search")
|
|
(map "f3" "find-string-again")
|
|
(map "c:i" "toggle-search-focus")
|
|
(map "c:g" "hide-search")]
|
|
[(windows)
|
|
(map "c:r" "move-to-search-or-reverse-search")
|
|
(map "f3" "find-string-again")
|
|
(map "c:g" "find-string-again")
|
|
|
|
;; covered by menu
|
|
;(map "c:f" "move-to-search-or-search")
|
|
|
|
(map "c:i" "toggle-search-focus")]
|
|
[(macos macosx)
|
|
(map "c:s" "move-to-search-or-search")
|
|
(map "c:g" "hide-search")
|
|
|
|
;; covered by menu
|
|
;(map "d:f" "move-to-search-or-search")
|
|
|
|
(map "c:r" "move-to-search-or-reverse-search")
|
|
(map "d:g" "find-string-again")
|
|
(map "c:i" "toggle-search-focus")])))))
|
|
|
|
(define setup-file
|
|
(let* ([get-outer-editor ;; : text% -> text%
|
|
;; returns the outermost editor, if this editor is nested in an editor snip.
|
|
(λ (edit)
|
|
(let loop ([edit edit])
|
|
(let ([admin (send edit get-admin)])
|
|
(cond
|
|
[(is-a? admin editor-snip-editor-admin<%>)
|
|
(loop (send (send (send admin get-snip) get-admin) get-editor))]
|
|
[else edit]))))]
|
|
[save-file-as
|
|
(λ (this-edit event)
|
|
(let ([edit (get-outer-editor this-edit)])
|
|
(parameterize ([finder:dialog-parent-parameter
|
|
(and (is-a? edit editor:basic<%>)
|
|
(send edit get-top-level-window))])
|
|
(let ([file (finder:put-file)])
|
|
(when file
|
|
(send edit save-file/gui-error file)))))
|
|
#t)]
|
|
[save-file
|
|
(λ (this-edit event)
|
|
(let ([edit (get-outer-editor this-edit)])
|
|
(if (send edit get-filename)
|
|
(send edit save-file/gui-error)
|
|
(save-file-as edit event)))
|
|
#t)]
|
|
[load-file
|
|
(λ (edit event)
|
|
(handler:open-file)
|
|
#t)])
|
|
(λ (kmap)
|
|
(let* ([map (λ (key func)
|
|
(send kmap map-function key func))]
|
|
[map-meta (λ (key func)
|
|
(send-map-function-meta kmap key func))]
|
|
[add (λ (name func)
|
|
(send kmap add-function name func))]
|
|
[add-m (λ (name func)
|
|
(send kmap add-function name func))])
|
|
|
|
(add "save-file" save-file)
|
|
(add "save-file-as" save-file-as)
|
|
(add "load-file" load-file)
|
|
|
|
(map "c:x;c:s" "save-file")
|
|
(map "d:s" "save-file")
|
|
(map "c:x;c:w" "save-file-as")
|
|
(map "c:x;c:f" "load-file")))))
|
|
|
|
(define (setup-editor kmap)
|
|
(let ([add/map
|
|
(λ (func op key)
|
|
(send kmap add-function
|
|
func
|
|
(λ (editor evt)
|
|
(send editor do-edit-operation op)))
|
|
(send kmap map-function
|
|
(string-append
|
|
(case (system-type)
|
|
[(macosx macos) "d:"]
|
|
[(windows) "c:"]
|
|
[(unix) "a:"]
|
|
[else (error 'keymap.ss "unknown platform: ~s" (system-type))])
|
|
key)
|
|
func))])
|
|
(add/map "editor-undo" 'undo "z")
|
|
(add/map "editor-redo" 'redo "y")
|
|
(add/map "editor-cut" 'cut "x")
|
|
(add/map "editor-copy" 'copy "c")
|
|
(add/map "editor-paste" 'paste "v")
|
|
(add/map "editor-select-all" 'select-all "a")))
|
|
|
|
(define (generic-setup keymap)
|
|
(add-editor-keymap-functions keymap)
|
|
(add-pasteboard-keymap-functions keymap)
|
|
(add-text-keymap-functions keymap))
|
|
|
|
(define global (make-object aug-keymap%))
|
|
(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%))
|
|
(setup-file file)
|
|
(generic-setup file)
|
|
(define (-get-file) file)
|
|
|
|
(define search (make-object aug-keymap%))
|
|
(generic-setup search)
|
|
(setup-search search)
|
|
(define (get-search) search)
|
|
|
|
(define editor (make-object aug-keymap%))
|
|
(setup-editor editor)
|
|
(define (get-editor) editor)
|
|
|
|
(define (call/text-keymap-initializer thunk)
|
|
(let ([ctki (current-text-keymap-initializer)])
|
|
(parameterize ([current-text-keymap-initializer
|
|
(λ (keymap)
|
|
(send keymap chain-to-keymap global #t)
|
|
(ctki keymap))])
|
|
(thunk)))))))
|