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

fix the interaction between the automatic insertion of matching parens

Browse Source 
and the magic fixup of opening parentheses.

This commit moves the automatic insertion of matching parens to the
scheme mode keymap, so it will now take affect in Racket mode editing,
only. Also, Rackety.
This commit is contained in:
Robby Findler 2011-11-16 19:35:13 -06:00
parent 3345415d71
commit b726209dc5
5 changed files with 252 additions and 239 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

71
collects/framework/private/keymap.rkt
View File

@ -387,29 +387,7 @@
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.
@ -1093,22 +1071,7 @@
(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)
;; HACK: in order to allow disabling of insert-pair bindings,
;; I'm adding functions that simply insert the corresponding
;; character. I bet there's a much cleaner way to do this;
;; there may be existing functions that insert single characters,
;; or a way to "pop" bindings off of a keybindings.
(add "insert (" (lambda (txt evt) (send txt insert #\()))
(add "insert {" (lambda (txt evt) (send txt insert #\{)))
(add "insert \"" (lambda (txt evt) (send txt insert #\")))
(add "toggle-anchor" toggle-anchor)
(add "center-view-on-line" center-view-on-line)
(add "collapse-space" collapse-space)
@ -1198,13 +1161,6 @@
(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")
@ -1354,28 +1310,7 @@
(map "c:x;p" "shift-focus-backwards")
(map "c:f6" "shift-focus")
(map "a:tab" "shift-focus")
(map "a:s:tab" "shift-focus-backwards")
(let ()
(define (add-automatic-paren-bindings)
(map "~c:s:(" "insert-()-pair")
(map "~c:s:{" "insert-{}-pair")
(map "~c:s:\"" "insert-\"\"-pair"))
(define (remove-automatic-paren-bindings)
;; how the heck is this going to work? we want to "pop" these bindings off...
;; this is a crude approximation:
(map "~c:s:(" "insert (")
(map "~c:s:{" "insert {")
(map "~c:s:\"" "insert \""))
(when (preferences:get 'framework:automatic-parens)
(add-automatic-paren-bindings))
(preferences:add-callback
'framework:automatic-parens
(lambda (id new-val)
(cond [new-val (add-automatic-paren-bindings)]
[else (remove-automatic-paren-bindings)])))
(void))
))))
(map "a:s:tab" "shift-focus-backwards")))))
(define setup-search
(let* ([send-frame

378
collects/framework/private/scheme.rkt
View File

@ -427,6 +427,8 @@
get-end-position
flash-on
insert
is-frozen?
is-stopped?
kill
last-position
paragraph-start-position
@ -1197,18 +1199,6 @@
[define get-tab-size (λ () tab-size)]
[define set-tab-size (λ (s) (set! tab-size s))]
(inherit is-frozen? is-stopped?)
(define/public (rewrite-square-paren)
(cond
[(or (not (preferences:get 'framework:fixup-open-parens))
(is-frozen?)
(is-stopped?))
(insert #\[
(get-start-position)
(get-end-position))]
[else
(insert-paren this)]))
(define/override (get-start-of-line pos)
(define para (position-paragraph pos))
(define para-start (paragraph-start-position para))
@ -1323,160 +1313,208 @@
(define text-mode% (text-mode-mixin color:text-mode%))
(define (setup-keymap keymap)
(let ([add-pos-function
(λ (name call-method)
(send keymap add-function name
(λ (edit event)
(call-method
edit
(send edit get-start-position)))))])
(add-pos-function "remove-sexp" (λ (e p) (send e remove-sexp p)))
(add-pos-function "forward-sexp" (λ (e p) (send e forward-sexp p)))
(add-pos-function "backward-sexp" (λ (e p) (send e backward-sexp p)))
(add-pos-function "up-sexp" (λ (e p) (send e up-sexp p)))
(add-pos-function "down-sexp" (λ (e p) (send e down-sexp p)))
(add-pos-function "flash-backward-sexp" (λ (e p) (send e flash-backward-sexp p)))
(add-pos-function "flash-forward-sexp" (λ (e p) (send e flash-forward-sexp p)))
(add-pos-function "remove-parens-forward" (λ (e p) (send e remove-parens-forward p)))
(add-pos-function "transpose-sexp" (λ (e p) (send e transpose-sexp p)))
(add-pos-function "mark-matching-parenthesis"
(λ (e p) (send e mark-matching-parenthesis p)))
(add-pos-function "introduce-let-ans"
(λ (e p) (send e introduce-let-ans p)))
(add-pos-function "move-sexp-out"
(λ (e p) (send e move-sexp-out p)))
(add-pos-function "kill-enclosing-parens"
(lambda (e p) (send e kill-enclosing-parens p)))
(add-pos-function "toggle-round-square-parens"
(lambda (e p) (send e toggle-round-square-parens p)))
(let ([add-edit-function
(λ (name call-method)
(send keymap add-function name
(λ (edit event)
(call-method edit))))])
(add-edit-function "select-forward-sexp"
(λ (x) (send x select-forward-sexp)))
(add-edit-function "select-backward-sexp"
(λ (x) (send x select-backward-sexp)))
(add-edit-function "select-down-sexp"
(λ (x) (send x select-down-sexp)))
(add-edit-function "select-up-sexp"
(λ (x) (send x select-up-sexp)))
(add-edit-function "tabify-at-caret"
(λ (x) (send x tabify-selection)))
(add-edit-function "do-return"
(λ (x)
(send x insert-return)))
(add-edit-function "comment-out"
(λ (x) (send x comment-out-selection)))
(add-edit-function "box-comment-out"
(λ (x) (send x box-comment-out-selection)))
(add-edit-function "uncomment"
(λ (x) (send x uncomment-selection)))
(add-edit-function "rewrite-square-paren"
(λ (x) (send x rewrite-square-paren)))
(let ([add/map-non-clever
(λ (name keystroke char)
(add-edit-function
name
(λ (e) (send e insert char (send e get-start-position) (send e get-end-position))))
(send keymap map-function keystroke name))])
(add/map-non-clever "non-clever-open-square-bracket" "c:[" #\[)
(add/map-non-clever "non-clever-close-square-bracket" "c:]" #\])
(add/map-non-clever "non-clever-close-curley-bracket" "c:}" #\})
(add/map-non-clever "non-clever-close-round-paren" "c:)" #\))))
(send keymap add-function "balance-parens"
(define (add-edit-function name f)
(send keymap add-function name (λ (edit event) (f edit))))
(define (add-pos-function name f)
(send keymap add-function name
(λ (edit event)
(send edit balance-parens event)))
(send keymap map-function "TAB" "tabify-at-caret")
(send keymap map-function "return" "do-return")
(send keymap map-function "s:return" "do-return")
(send keymap map-function "s:c:return" "do-return")
(send keymap map-function "a:return" "do-return")
(send keymap map-function "s:a:return" "do-return")
(send keymap map-function "c:a:return" "do-return")
(send keymap map-function "c:s:a:return" "do-return")
(send keymap map-function "c:return" "do-return")
(send keymap map-function "d:return" "do-return")
(send keymap map-function ")" "balance-parens")
(send keymap map-function "]" "balance-parens")
(send keymap map-function "}" "balance-parens")
(send keymap map-function "[" "rewrite-square-paren")
(let ([map-meta
(λ (key func)
(keymap:send-map-function-meta keymap key func))]
[map
(λ (key func)
(send keymap map-function key func))])
(map-meta "up" "up-sexp")
(map-meta "c:u" "up-sexp")
(map "a:up" "up-sexp")
(map-meta "s:up" "select-up-sexp")
(map "a:s:up" "select-up-sexp")
(map-meta "s:c:u" "select-up-sexp")
(map-meta "down" "down-sexp")
(map "a:down" "down-sexp")
(map-meta "s:down" "select-down-sexp")
(map "a:s:down" "select-down-sexp")
(map-meta "s:c:down" "select-down-sexp")
(map-meta "right" "forward-sexp")
(map "a:right" "forward-sexp")
(map "m:right" "forward-sexp")
(map-meta "s:right" "select-forward-sexp")
(map "a:s:right" "select-forward-sexp")
(map "m:s:right" "select-forward-sexp")
(map-meta "left" "backward-sexp")
(map "a:left" "backward-sexp")
(map "m:left" "backward-sexp")
(map-meta "s:left" "select-backward-sexp")
(map "a:s:left" "select-backward-sexp")
(map "m:s:left" "select-backward-sexp")
(map-meta "return" "do-return")
(map-meta "s:return" "do-return")
(map-meta "s:c:return" "do-return")
(map-meta "a:return" "do-return")
(map-meta "s:a:return" "do-return")
(map-meta "c:a:return" "do-return")
(map-meta "c:s:a:return" "do-return")
(map-meta "c:return" "do-return")
(map-meta "c:semicolon" "comment-out")
(map-meta "c:=" "uncomment")
(map-meta "c:k" "remove-sexp")
(map-meta "c:f" "forward-sexp")
(map-meta "s:c:f" "select-forward-sexp")
(map-meta "c:b" "backward-sexp")
(map-meta "s:c:b" "select-backward-sexp")
(map-meta "c:p" "flash-backward-sexp")
(map-meta "s:c:n" "flash-forward-sexp")
(map-meta "c:space" "select-forward-sexp")
(map-meta "c:t" "transpose-sexp")
(f edit (send edit get-start-position)))))
(add-pos-function "remove-sexp" (λ (e p) (send e remove-sexp p)))
(add-pos-function "forward-sexp" (λ (e p) (send e forward-sexp p)))
(add-pos-function "backward-sexp" (λ (e p) (send e backward-sexp p)))
(add-pos-function "up-sexp" (λ (e p) (send e up-sexp p)))
(add-pos-function "down-sexp" (λ (e p) (send e down-sexp p)))
(add-pos-function "flash-backward-sexp" (λ (e p) (send e flash-backward-sexp p)))
(add-pos-function "flash-forward-sexp" (λ (e p) (send e flash-forward-sexp p)))
(add-pos-function "remove-parens-forward" (λ (e p) (send e remove-parens-forward p)))
(add-pos-function "transpose-sexp" (λ (e p) (send e transpose-sexp p)))
(add-pos-function "mark-matching-parenthesis"
(λ (e p) (send e mark-matching-parenthesis p)))
(add-pos-function "introduce-let-ans"
(λ (e p) (send e introduce-let-ans p)))
(add-pos-function "move-sexp-out"
(λ (e p) (send e move-sexp-out p)))
(add-pos-function "kill-enclosing-parens"
(lambda (e p) (send e kill-enclosing-parens p)))
(add-pos-function "toggle-round-square-parens"
(lambda (e p) (send e toggle-round-square-parens p)))
(add-edit-function "select-forward-sexp"
(λ (x) (send x select-forward-sexp)))
(add-edit-function "select-backward-sexp"
(λ (x) (send x select-backward-sexp)))
(add-edit-function "select-down-sexp"
(λ (x) (send x select-down-sexp)))
(add-edit-function "select-up-sexp"
(λ (x) (send x select-up-sexp)))
(add-edit-function "tabify-at-caret"
(λ (x) (send x tabify-selection)))
(add-edit-function "do-return"
(λ (x) (send x insert-return)))
(add-edit-function "comment-out"
(λ (x) (send x comment-out-selection)))
(add-edit-function "box-comment-out"
(λ (x) (send x box-comment-out-selection)))
(add-edit-function "uncomment"
(λ (x) (send x uncomment-selection)))
(let ([add/map-non-clever
(λ (name keystroke char)
(add-edit-function
name
(λ (e) (send e insert char (send e get-start-position) (send e get-end-position))))
(send keymap map-function keystroke name))])
(add/map-non-clever "non-clever-open-square-bracket" "c:[" #\[)
(add/map-non-clever "non-clever-close-square-bracket" "c:]" #\])
(add/map-non-clever "non-clever-close-curley-bracket" "c:}" #\})
(add/map-non-clever "non-clever-close-round-paren" "c:)" #\)))
(send keymap add-function "balance-parens"
(λ (edit event)
(send edit balance-parens event)))
(send keymap map-function "TAB" "tabify-at-caret")
(send keymap map-function "return" "do-return")
(send keymap map-function "s:return" "do-return")
(send keymap map-function "s:c:return" "do-return")
(send keymap map-function "a:return" "do-return")
(send keymap map-function "s:a:return" "do-return")
(send keymap map-function "c:a:return" "do-return")
(send keymap map-function "c:s:a:return" "do-return")
(send keymap map-function "c:return" "do-return")
(send keymap map-function "d:return" "do-return")
(send keymap map-function ")" "balance-parens")
(send keymap map-function "]" "balance-parens")
(send keymap map-function "}" "balance-parens")
(define (insert-brace-pair text open-brace close-brace)
(define selection-start (send text get-start-position))
(send text set-position (send text get-end-position))
(send text insert close-brace)
(send text set-position selection-start)
(send text insert open-brace))
(define (maybe-insert-brace-pair text open-brace close-brace)
(cond
[(preferences:get 'framework:automatic-parens)
(insert-brace-pair text open-brace close-brace)]
[else
(send text insert open-brace)]))
(add-edit-function "insert-()-pair" (λ (text) (insert-brace-pair text #\( #\))))
(add-edit-function "insert-[]-pair" (λ (text) (insert-brace-pair text #\[ #\])))
(add-edit-function "insert-{}-pair" (λ (text) (insert-brace-pair text #\{ #\})))
(add-edit-function "insert-\"\"-pair" (λ (text) (insert-brace-pair text #\" #\")))
(add-edit-function "insert-||-pair" (λ (text) (insert-brace-pair text #\| #\|)))
(add-edit-function "maybe-insert-()-pair" (λ (text) (maybe-insert-brace-pair text #\( #\))))
(add-edit-function "maybe-insert-[]-pair" (λ (text) (maybe-insert-brace-pair text #\[ #\])))
(add-edit-function "maybe-insert-{}-pair" (λ (text) (maybe-insert-brace-pair text #\{ #\})))
(add-edit-function "maybe-insert-\"\"-pair" (λ (text) (maybe-insert-brace-pair text #\" #\")))
(add-edit-function "maybe-insert-||-pair" (λ (text) (maybe-insert-brace-pair text #\| #\|)))
(add-edit-function "maybe-insert-[]-pair-maybe-fixup-[]"
(λ (text)
(cond
[(or (not (preferences:get 'framework:fixup-open-parens))
(send text is-frozen?)
(send text is-stopped?))
(maybe-insert-brace-pair text #\[ #\])]
[else
(insert-paren text)])))
(define (insert-lambda-template edit)
(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))
(add-edit-function "insert-lambda-template" insert-lambda-template)
(define (map-meta key func) (keymap:send-map-function-meta keymap key func))
(define (map key func) (send keymap map-function key func))
(map-meta "up" "up-sexp")
(map-meta "c:u" "up-sexp")
(map "a:up" "up-sexp")
(map-meta "s:up" "select-up-sexp")
(map "a:s:up" "select-up-sexp")
(map-meta "s:c:u" "select-up-sexp")
(map-meta "down" "down-sexp")
(map "a:down" "down-sexp")
(map-meta "s:down" "select-down-sexp")
(map "a:s:down" "select-down-sexp")
(map-meta "s:c:down" "select-down-sexp")
(map-meta "right" "forward-sexp")
(map "a:right" "forward-sexp")
(map "m:right" "forward-sexp")
(map-meta "s:right" "select-forward-sexp")
(map "a:s:right" "select-forward-sexp")
(map "m:s:right" "select-forward-sexp")
(map-meta "left" "backward-sexp")
(map "a:left" "backward-sexp")
(map "m:left" "backward-sexp")
(map-meta "s:left" "select-backward-sexp")
(map "a:s:left" "select-backward-sexp")
(map "m:s:left" "select-backward-sexp")
(map-meta "return" "do-return")
(map-meta "s:return" "do-return")
(map-meta "s:c:return" "do-return")
(map-meta "a:return" "do-return")
(map-meta "s:a:return" "do-return")
(map-meta "c:a:return" "do-return")
(map-meta "c:s:a:return" "do-return")
(map-meta "c:return" "do-return")
(map-meta "c:semicolon" "comment-out")
(map-meta "c:=" "uncomment")
(map-meta "c:k" "remove-sexp")
(map-meta "c:f" "forward-sexp")
(map-meta "s:c:f" "select-forward-sexp")
(map-meta "c:b" "backward-sexp")
(map-meta "s:c:b" "select-backward-sexp")
(map-meta "c:p" "flash-backward-sexp")
(map-meta "s:c:n" "flash-forward-sexp")
(map-meta "c:space" "select-forward-sexp")
(map-meta "c:t" "transpose-sexp")
;(map-meta "c:m" "mark-matching-parenthesis")
; this keybinding doesn't interact with the paren colorer
(map-meta "(" "insert-()-pair")
(map-meta "[" "insert-[]-pair")
(map-meta "{" "insert-{}-pair")
(map-meta "\"" "insert-\"\"-pair")
(map-meta "|" "insert-||-pair")
;(map-meta "c:m" "mark-matching-parenthesis")
; this keybinding doesn't interact with the paren colorer
)
(send keymap map-function "c:c;c:b" "remove-parens-forward")
(send keymap map-function "c:c;c:l" "introduce-let-ans")
(send keymap map-function "c:c;c:o" "move-sexp-out")
(send keymap map-function "c:c;c:e" "kill-enclosing-parens")
(send keymap map-function "c:c;c:[" "toggle-round-square-parens")))
(map "(" "maybe-insert-()-pair")
(map "[" "maybe-insert-[]-pair-maybe-fixup-[]")
(map "{" "maybe-insert-{}-pair")
(map "\"" "maybe-insert-\"\"-pair")
(map "|" "maybe-insert-||-pair")
(map-meta "s:l" "insert-lambda-template")
(map "c:c;c:b" "remove-parens-forward")
(map "c:c;c:l" "introduce-let-ans")
(map "c:c;c:o" "move-sexp-out")
(map "c:c;c:e" "kill-enclosing-parens")
(map "c:c;c:[" "toggle-round-square-parens"))
(define keymap (make-object keymap:aug-keymap%))
(setup-keymap keymap)
@ -1580,7 +1618,17 @@
(change-to 6 #\()]))])))
(send text delete pos (+ pos 1) #f)
(send text end-edit-sequence)
(send text insert real-char start-pos end-pos)))
(cond
[(preferences:get 'framework:automatic-parens)
(send text insert (case real-char
[(#\() #\)]
[(#\[) #\]]
[(#\{) #\}])
end-pos end-pos)
(send text insert real-char start-pos start-pos)
(send text set-position (+ start-pos 1))]
[else
(send text insert real-char start-pos end-pos)])))
;; find-keyword-and-distance : -> (union #f (cons string number))
(define (find-keyword-and-distance before-whitespace-pos text)

34
collects/tests/framework/keys.rkt
View File

@ -87,7 +87,7 @@
;; buffer after the keypress. The keypress(es) in question are specified
;; independently for the three platforms by the respective 'macos', 'unix',
;; and 'windows' fields.
(define-struct key-spec (before after macos unix windows))
(define-struct key-spec (before after macos unix windows) #:prefab)
;; an abstraction to use when all platforms have the same sequence of keys
(define (make-key-spec/allplatforms before after keys)
@ -96,7 +96,7 @@
;; a buff-spec is (make-buff-spec string nat nat)
;; a buff-spec represents a buffer state; the content of the buffer,
;; and the start and end of the highlighted region.
(define-struct buff-spec (string start end))
(define-struct buff-spec (string start end) #:prefab)
;; the keybindings test cases applied to frame:text% editors
(define global-specs
@ -257,10 +257,25 @@
(make-key-spec/allplatforms
(make-buff-spec "[a]" 3 3)
(make-buff-spec "[a]" 3 3)
(list '((#\c control) (#\[ control))))
))
(list '((#\c control) (#\[ control))))))
(define automatic-scheme-specs
(list (make-key-spec/allplatforms (make-buff-spec "" 0 0)
(make-buff-spec "()" 1 1)
'(((#\())))
(make-key-spec/allplatforms (make-buff-spec "" 0 0)
(make-buff-spec "[]" 1 1)
'(((#\[))))
(make-key-spec/allplatforms (make-buff-spec "" 0 0)
(make-buff-spec "{}" 1 1)
'(((#\{))))
(make-key-spec/allplatforms (make-buff-spec "" 0 0)
(make-buff-spec "\"\"" 1 1)
'(((#\"))))
(make-key-spec/allplatforms (make-buff-spec "" 0 0)
(make-buff-spec "||" 1 1)
'(((#\|))))))
(queue-sexp-to-mred `(preferences:set 'framework:fixup-open-parens #t))
(queue-sexp-to-mred `(send (make-object frame:basic% "dummy to trick frame group") show #t))
(wait-for-frame "dummy to trick frame group")
@ -307,9 +322,18 @@
(test-key spec i))
(queue-sexp-to-mred `(send (get-top-level-focus-window) close)))
(queue-sexp-to-mred `(preferences:set 'framework:fixup-open-parens #t))
(queue-sexp-to-mred `(preferences:set 'framework:automatic-parens #f))
(test-specs "global keybindings test" 'frame:text% global-specs)
(test-specs "scheme mode keybindings test"
'(class frame:editor%
(define/override (get-editor%) scheme:text%)
(super-new))
scheme-specs)
(queue-sexp-to-mred `(preferences:set 'framework:automatic-parens #t))
(queue-sexp-to-mred `(preferences:set 'framework:fixup-open-parens #f))
(test-specs "scheme mode automatic-parens on keybindings test"
'(class frame:editor%
(define/override (get-editor%) scheme:text%)
(super-new))
automatic-scheme-specs)

4
collects/tests/framework/scheme.rkt
View File

@ -66,9 +66,11 @@
[ec (new editor-canvas% [parent f] [editor t])])
(send f reflow-container)
(send t insert ,before)
(send t rewrite-square-paren)
(send (scheme:get-keymap) call-function "maybe-insert-[]-pair-maybe-fixup-[]" t (new event%))
(send t get-text))))))
(queue-sexp-to-mred `(preferences:set 'framework:automatic-parens #f))
(queue-sexp-to-mred `(preferences:set 'framework:fixup-open-parens #t))
(test-magic-square-bracket 'mt "" "(")
(test-magic-square-bracket 'mt2 "(() " "(() (")
(test-magic-square-bracket 'mt3 "([] " "([] [")

4
doc/release-notes/drracket/HISTORY.txt
View File

@ -5,6 +5,10 @@
. DrRacket no longer shows a stacktrace for syntax errors in the REPL.
. The preference that makes a single "(" keystroke insert "()"
(and similarly for [ { " and |) now only takes effect in Racket mode,
instead of taking effect in all of the modes, as it used to.
------------------------------
Version 5.2
------------------------------