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

..

Browse Source 
original commit: bcf8165f200e02e9ed2ebd7bfe7af6b538c9e160
This commit is contained in:
Robby Findler 2002-02-16 14:30:16 +00:00
parent a6da57796d
commit 2a1ecc6448
1 changed files with 195 additions and 186 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -77,11 +77,11 @@
(define aug-keymap% (aug-keymap-mixin keymap%)) (define aug-keymap% (aug-keymap-mixin keymap%))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;; ;;;;;;;; ;;;;;;; ;;;;;;;;
;;;;;;; canonicalize-keybinding-string ;;;;;;;; ;;;;;;; canonicalize-keybinding-string ;;;;;;;;
;;;;;;; ;;;;;;;; ;;;;;;; ;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; canonicalize-keybinding-string : string -> string ;; canonicalize-keybinding-string : string -> string
;; The result can be used with string=? to determine ;; The result can be used with string=? to determine
@ -106,11 +106,11 @@
(car strs) (car strs)
(let loop ([sepd-strs (cdr strs)]) (let loop ([sepd-strs (cdr strs)])
(cond (cond
[(null? sepd-strs) null] [(null? sepd-strs) null]
[else (list* [else (list*
sep sep
(car sepd-strs) (car sepd-strs)
(loop (cdr sepd-strs)))])))))) (loop (cdr sepd-strs)))]))))))
;; canonicalize-single-keybinding-string : (listof char) -> string ;; canonicalize-single-keybinding-string : (listof char) -> string
(define (canonicalize-single-keybinding-string chars) (define (canonicalize-single-keybinding-string chars)
@ -119,9 +119,9 @@
[mods [mods
(let loop ([mods mods/key]) (let loop ([mods mods/key])
(cond (cond
[(null? mods) null] [(null? mods) null]
[(null? (cdr mods)) null] [(null? (cdr mods)) null]
[else (cons (car mods) (loop (cdr mods)))]))] [else (cons (car mods) (loop (cdr mods)))]))]
[key (car (last-pair mods/key))] [key (car (last-pair mods/key))]
[shift (if neg? #f 'd/c)] [shift (if neg? #f 'd/c)]
[control (if neg? #f 'd/c)] [control (if neg? #f 'd/c)]
@ -132,9 +132,9 @@
[do-key [do-key
(lambda (char val) (lambda (char val)
(cond (cond
[(eq? val #t) (string char)] [(eq? val #t) (string char)]
[(eq? val #f) (string #\~ char)] [(eq? val #f) (string #\~ char)]
[(eq? val 'd/c) #f]))]) [(eq? val 'd/c) #f]))])
(for-each (lambda (mod) (for-each (lambda (mod)
(let ([val (not (char=? (car mod) #\~))]) (let ([val (not (char=? (car mod) #\~))])
@ -167,28 +167,28 @@
[this-split null] [this-split null]
[all-split null]) [all-split null])
(cond (cond
[(null? chars) [(null? chars)
(reverse (cons (reverse this-split) all-split))] (reverse (cons (reverse this-split) all-split))]
[else (let ([char (car chars)]) [else (let ([char (car chars)])
(cond (cond
[(char=? split-char char) [(char=? split-char char)
(if (null? (cdr chars)) (if (null? (cdr chars))
(loop null (loop null
(cons char this-split) (cons char this-split)
all-split) all-split)
(loop (cdr chars) (loop (cdr chars)
null null
(cons (reverse this-split) all-split)))] (cons (reverse this-split) all-split)))]
[else [else
(loop (cdr chars) (loop (cdr chars)
(cons char this-split) (cons char this-split)
all-split)]))]))) all-split)]))])))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;; ;;;;;;;; ;;;;;;; ;;;;;;;;
;;;;;;; end canonicalize-keybinding-string ;;;;;;;; ;;;;;;; end canonicalize-keybinding-string ;;;;;;;;
;;;;;;; ;;;;;;;; ;;;;;;; ;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (make-meta-prefix-list key) (define (make-meta-prefix-list key)
(list (string-append "m:" key) (list (string-append "m:" key)
@ -203,7 +203,7 @@
(define add-to-right-button-menu/before (make-parameter void)) (define add-to-right-button-menu/before (make-parameter void))
(define setup-global (define setup-global
; Define some useful keyboard functions ; Define some useful keyboard functions
(let* ([ring-bell (let* ([ring-bell
(lambda (edit event) (lambda (edit event)
(bell))] (bell))]
@ -302,47 +302,56 @@
(send edit flash-on pos (+ 1 pos)))) (send edit flash-on pos (+ 1 pos))))
#t)] #t)]
[collapse-variable-space [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.
(lambda (leave-one? edit event) (lambda (leave-one? edit event)
(letrec ([end-pos (send edit last-position)] (letrec ([last-pos (send edit last-position)]
[find-nonwhite [sel-start (send edit get-start-position)]
(lambda (pos d) [sel-end (send edit get-end-position)]
[collapsible? (lambda (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).)
(lambda (pos dir)
(let loop ([pos pos]) (let loop ([pos pos])
(if (or (and (= d -1) (cond [(< pos 0) -1]
(= pos 0)) [(>= pos last-pos) last-pos]
(and (= pos end-pos) [(collapsible? (send edit get-character pos))
(= d 1))) (loop (+ pos dir))]
pos [else pos])))])
(let ([c (send edit get-character pos)]) (when (= sel-start sel-end) ; Only when no selection:
(cond (let* ([start (add1 (find-noncollapsible (sub1 sel-start) -1))]
[(char=? #\newline c) pos] [end-heeding-eol (find-noncollapsible sel-start +1)]
[(char-whitespace? c) (loop (+ pos d))] ; This is the end of the range, were we to always heed newlines.
[else pos])))))])
(let ([sel-start (send edit get-start-position)] ; Special case: if we're sitting at EOL,
[sel-end (send edit get-end-position)]) ; and we're not affecting much else,
(when (= sel-start sel-end) ; then delete that EOL and collapse spaces
(let ([start ; at the start of next line, too:
(if (= sel-start 0) [end (if (and (<= (- end-heeding-eol start)
0 (if leave-one? 1 0))
(+ (find-nonwhite (- sel-start 1) -1) 1))] (char=? #\newline (send edit get-character end-heeding-eol))
[end (find-nonwhite sel-start 1)]) ; If you wish to avoid deleting an newline at EOF, do so here.
(send edit begin-edit-sequence) )
(cond (find-noncollapsible (add1 end-heeding-eol) +1)
;; funny case when to delete the newline end-heeding-eol)]
[(and leave-one? [making-no-difference?
(= (+ start 1) end) ; Don't introduce edits into undo-chain, if no effect.
(< end end-pos) (if leave-one?
(char=? #\space (send edit get-character start)) (and (= (- end start) 1)
(char=? #\newline (send edit get-character end))) (char=? #\space (send edit get-character start)))
(send edit delete end (+ end 1))] (= (- end start) 0))])
[else (unless making-no-difference?
(send edit delete start end) (send edit begin-edit-sequence)
(cond (send edit set-position end) ; Even after delete, caret will be at "end".
[leave-one? (send edit delete start end)
(send edit insert #\space start) (when leave-one? (send edit insert #\space start))
(send edit set-position (+ start 1))] (send edit end-edit-sequence))))))]
[else
(send edit set-position start)])])
(send edit end-edit-sequence))))))]
[collapse-space [collapse-space
(lambda (edit event) (lambda (edit event)
@ -365,12 +374,12 @@
(escape pos) (escape pos)
(let ([c (send edit get-character (+ pos offset))]) (let ([c (send edit get-character (+ pos offset))])
(cond (cond
[(char=? #\newline c) [(char=? #\newline c)
(loop (+ pos d)) (loop (+ pos d))
(escape pos)] (escape pos)]
[(char-whitespace? c) [(char-whitespace? c)
(loop (+ pos d))] (loop (+ pos d))]
[else pos])))))))]) [else pos])))))))])
(let ([sel-start (send edit get-start-position)] (let ([sel-start (send edit get-start-position)]
[sel-end (send edit get-end-position)]) [sel-end (send edit get-end-position)])
(when (= sel-start sel-end) (when (= sel-start sel-end)
@ -397,22 +406,22 @@
[end-line-start [end-line-start
(send edit line-start-position (add1 end-line))]) (send edit line-start-position (add1 end-line))])
(cond (cond
[(and whiteline? [(and whiteline?
(= start-line pos-line) (= start-line pos-line)
(= end-line pos-line)) (= end-line pos-line))
; Special case: just delete this line ; Special case: just delete this line
(send edit delete pos-line-start (add1 pos-line-end))] (send edit delete pos-line-start (add1 pos-line-end))]
[(and whiteline? (< start-line pos-line)) [(and whiteline? (< start-line pos-line))
; Can delete before & after ; Can delete before & after
(send* edit (send* edit
(begin-edit-sequence) (begin-edit-sequence)
(delete (add1 pos-line-end) end-line-start) (delete (add1 pos-line-end) end-line-start)
(delete start-line-start pos-line-start) (delete start-line-start pos-line-start)
(end-edit-sequence))] (end-edit-sequence))]
[else [else
; Only delete after ; Only delete after
(send edit delete (add1 pos-line-end) (send edit delete (add1 pos-line-end)
end-line-start)]))))))] end-line-start)]))))))]
[open-line [open-line
(lambda (edit event) (lambda (edit event)
@ -420,8 +429,8 @@
[sel-end (send edit get-end-position)]) [sel-end (send edit get-end-position)])
(if (= sel-start sel-end) (if (= sel-start sel-end)
(send* edit (send* edit
(insert #\newline) (insert #\newline)
(set-position sel-start)))))] (set-position sel-start)))))]
[transpose-chars [transpose-chars
(lambda (edit event) (lambda (edit event)
@ -440,11 +449,11 @@
(let ([s (send edit get-text (let ([s (send edit get-text
sel-start (add1 sel-start))]) sel-start (add1 sel-start))])
(send* edit (send* edit
(begin-edit-sequence) (begin-edit-sequence)
(delete sel-start (add1 sel-start)) (delete sel-start (add1 sel-start))
(insert s (- sel-start 1)) (insert s (- sel-start 1))
(set-position (add1 sel-start)) (set-position (add1 sel-start))
(end-edit-sequence)))))))] (end-edit-sequence)))))))]
[transpose-words [transpose-words
(lambda (edit event) (lambda (edit event)
@ -466,15 +475,15 @@
(unbox word-2-start) (unbox word-2-start)
(unbox word-2-end))]) (unbox word-2-end))])
(send* edit (send* edit
(begin-edit-sequence) (begin-edit-sequence)
(insert text-1 (insert text-1
(unbox word-2-start) (unbox word-2-start)
(unbox word-2-end)) (unbox word-2-end))
(insert text-2 (insert text-2
(unbox word-1-start) (unbox word-1-start)
(unbox word-1-end)) (unbox word-1-end))
(set-position (unbox word-2-end)) (set-position (unbox word-2-end))
(end-edit-sequence))))))))))] (end-edit-sequence))))))))))]
[capitalize-it [capitalize-it
(lambda (edit char-case1 char-case2) (lambda (edit char-case1 char-case2)
@ -491,17 +500,17 @@
(when (< pos word-end) (when (< pos word-end)
(let ([c (send edit get-character pos)]) (let ([c (send edit get-character pos)])
(cond (cond
[(char-alphabetic? c) [(char-alphabetic? c)
(send edit insert (send edit insert
(list->string (list->string
(list (char-case c))) (list (char-case c)))
pos (add1 pos)) pos (add1 pos))
(loop (add1 pos) char-case2)] (loop (add1 pos) char-case2)]
[else [else
(loop (add1 pos) char-case)])))) (loop (add1 pos) char-case)]))))
(send* edit (send* edit
(end-edit-sequence) (end-edit-sequence)
(set-position word-end))))))] (set-position word-end))))))]
[capitalize-word [capitalize-word
(lambda (edit event) (lambda (edit event)
@ -613,19 +622,19 @@
(when (string? num-str) (when (string? num-str)
(let ([line-num (inexact->exact (string->number num-str))]) (let ([line-num (inexact->exact (string->number num-str))])
(cond (cond
[(and (number? line-num) [(and (number? line-num)
(= line-num (floor line-num)) (= line-num (floor line-num))
(<= 1 line-num (+ (send edit last-line) 1))) (<= 1 line-num (+ (send edit last-line) 1)))
(let ([pos (send edit line-start-position (let ([pos (send edit line-start-position
(sub1 line-num))]) (sub1 line-num))])
(send edit set-position pos))] (send edit set-position pos))]
[else [else
(message-box (message-box
(string-constant goto-line) (string-constant goto-line)
(format (format
(string-constant goto-line-invalid-number) (string-constant goto-line-invalid-number)
num-str num-str
(+ (send edit last-line) 1)))])))) (+ (send edit last-line) 1)))]))))
#t)] #t)]
[goto-position [goto-position
@ -698,7 +707,7 @@
[do-macro [do-macro
(lambda (edit event) (lambda (edit event)
; If c:x;e during record, copy the old macro ; If c:x;e during record, copy the old macro
(when building-macro (when building-macro
(set! building-macro (append (reverse current-macro) (set! building-macro (append (reverse current-macro)
(cdr building-macro)))) (cdr building-macro))))
@ -788,7 +797,7 @@
[add-m (lambda (name func) [add-m (lambda (name func)
(send kmap add-function name func))]) (send kmap add-function name func))])
; Map names to keyboard functions ; Map names to keyboard functions
(add "toggle-overwrite" toggle-overwrite) (add "toggle-overwrite" toggle-overwrite)
(add "exit" (lambda (edit event) (add "exit" (lambda (edit event)
@ -847,7 +856,7 @@
(add "mouse-popup-menu" mouse-popup-menu) (add "mouse-popup-menu" mouse-popup-menu)
; Map keys to functions ; Map keys to functions
(map "c:g" "ring-bell") (map "c:g" "ring-bell")
(map-meta "c:g" "ring-bell") (map-meta "c:g" "ring-bell")
(map "c:x;c:g" "ring-bell") (map "c:x;c:g" "ring-bell")
@ -976,7 +985,7 @@
(map "s:insert" "paste-clipboard") (map "s:insert" "paste-clipboard")
(map-meta "space" "collapse-space") (map-meta "space" "collapse-space")
;(map-meta "\\" "remove-space") ;; conflicts with european keyboards ;(map-meta "\\" "remove-space") ; Conflicts with european keyboards.
(map "c:x;c:o" "collapse-newline") (map "c:x;c:o" "collapse-newline")
(map "c:o" "open-line") (map "c:o" "open-line")
(map "c:t" "transpose-chars") (map "c:t" "transpose-chars")
@ -1020,13 +1029,13 @@
(lambda (edit event) (lambda (edit event)
(let ([frame (let ([frame
(cond (cond
[(is-a? edit editor<%>) [(is-a? edit editor<%>)
(let ([canvas (send edit get-active-canvas)]) (let ([canvas (send edit get-active-canvas)])
(and canvas (and canvas
(send canvas get-top-level-window)))] (send canvas get-top-level-window)))]
[(is-a? edit area<%>) [(is-a? edit area<%>)
(send edit get-top-level-window)] (send edit get-top-level-window)]
[else #f])]) [else #f])])
(if frame (if frame
(invoke-method frame) (invoke-method frame)
(bell))) (bell)))
@ -1066,7 +1075,7 @@
(map "c:g" "find-string-again") (map "c:g" "find-string-again")
;; covered by menu ;; covered by menu
;(map "c:f" "move-to-search-or-search") ;(map "c:f" "move-to-search-or-search")
(map "c:i" "toggle-search-focus")] (map "c:i" "toggle-search-focus")]
[(macos macosx) [(macos macosx)
@ -1074,7 +1083,7 @@
(map "c:g" "hide-search") (map "c:g" "hide-search")
;; covered by menu ;; covered by menu
;(map "d:f" "move-to-search-or-search") ;(map "d:f" "move-to-search-or-search")
(map "d:r" "move-to-search-or-reverse-search") (map "d:r" "move-to-search-or-reverse-search")
(map "d:g" "find-string-again") (map "d:g" "find-string-again")