adjust the handling of the scheme mode keymap so that it can go
before the plain text-mode keymap. Add a doubleleftclick binding to the scheme mode keymap so that we can have sexp-sensitive double clicking in the drracket editor original commit: 1c2f9cd721588affa82b0a5497c3580e846a0892
This commit is contained in:
Robby Findler
parent
2eb9dede6a
commit
ade72045be
|
|
@ -1358,6 +1358,23 @@
|
|||
@racket[(send editor get-keymap)] That is, @racket[keymap] must be chained
|
||||
to some keymap attached to the editor.})
|
||||
|
||||
(proc-doc/names
|
||||
keymap:region-click
|
||||
(-> any/c any/c (-> number? boolean? number? number? any)
|
||||
any)
|
||||
(text mouse-event f)
|
||||
@{Calls @racket[f] after computing where the @racket[event]
|
||||
corresponds to in the @racket[text]. If @racket[event] is
|
||||
not a @racket[mouse-event%] object or if @racket[text] is not a
|
||||
@racket[text%] object, this function does nothing, returning
|
||||
@racket[(void)].
|
||||
|
||||
The arguments to @racket[f] are:
|
||||
@itemize[@item{the position where the click occurred}
|
||||
@item{a boolean indicating if the position is at
|
||||
the right-hand edge of the screen (to
|
||||
cover the eol ambiguity)}]})
|
||||
|
||||
(proc-doc/names
|
||||
scheme:text-balanced?
|
||||
(->* ((is-a?/c text%))
|
||||
|
|
|
|||
|
|
@ -623,39 +623,20 @@
|
|||
(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
|
||||
(region-click/internal 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
|
||||
(region-click/internal edit event
|
||||
(λ (click eol start end)
|
||||
(send edit cut #f 0 start end))))]
|
||||
[paste-click-region
|
||||
(λ (edit event)
|
||||
(region-click edit event
|
||||
(region-click/internal edit event
|
||||
(λ (click eol start end)
|
||||
(send edit set-position click)
|
||||
(send edit paste-x-selection 0 click))))]
|
||||
|
|
@ -675,7 +656,7 @@
|
|||
[select-click-word
|
||||
(λ (edit event)
|
||||
(region-click edit event
|
||||
(λ (click eol start end)
|
||||
(λ (click eol)
|
||||
(let ([start-box (box click)]
|
||||
[end-box (box click)])
|
||||
(send edit find-wordbreak
|
||||
|
|
@ -688,7 +669,7 @@
|
|||
[select-click-line
|
||||
(λ (edit event)
|
||||
(region-click edit event
|
||||
(λ (click eol start end)
|
||||
(λ (click eol)
|
||||
(let* ([line (send edit position-line
|
||||
click eol)]
|
||||
[start (send edit line-start-position
|
||||
|
|
@ -1473,3 +1454,27 @@
|
|||
(send keymap chain-to-keymap global #t)
|
||||
(ctki keymap))])
|
||||
(thunk))))
|
||||
|
||||
(define (region-click text event f)
|
||||
(region-click/internal text event
|
||||
(λ (click-pos eol start end) (f click-pos eol))))
|
||||
|
||||
(define (region-click/internal text event f)
|
||||
(when (and (is-a? event mouse-event%)
|
||||
(send event button-down?)
|
||||
(is-a? text text%))
|
||||
(define x-box (box (send event get-x)))
|
||||
(define y-box (box (send event get-y)))
|
||||
(define eol-box (box #f))
|
||||
(send text global-to-local x-box y-box)
|
||||
(define click-pos (send text find-position
|
||||
(unbox x-box)
|
||||
(unbox y-box)
|
||||
eol-box))
|
||||
(define start-pos (send text get-start-position))
|
||||
(define end-pos (send text get-end-position))
|
||||
(define 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))))
|
||||
|
||||
|
|
@ -34,7 +34,9 @@
|
|||
(init-depend mred^ framework:keymap^ framework:color^ framework:mode^
|
||||
framework:text^ framework:editor^)
|
||||
|
||||
(define-local-member-name stick-to-next-sexp?)
|
||||
(define-local-member-name
|
||||
stick-to-next-sexp?
|
||||
get-private-scheme-container-keymap)
|
||||
|
||||
(define (scheme-paren:get-paren-pairs)
|
||||
'(("(" . ")")
|
||||
|
|
@ -409,7 +411,7 @@
|
|||
(send style-list find-named-style "Matching Parenthesis Style")))
|
||||
|
||||
(define text-mixin
|
||||
(mixin (text:basic<%> mode:host-text<%> color:text<%> text:autocomplete<%>) (-text<%>)
|
||||
(mixin (text:basic<%> mode:host-text<%> color:text<%> text:autocomplete<%> editor:keymap<%>) (-text<%>)
|
||||
(inherit begin-edit-sequence
|
||||
delete
|
||||
end-edit-sequence
|
||||
|
|
@ -452,6 +454,13 @@
|
|||
(inherit has-focus? find-snip split-snip
|
||||
position-location get-dc)
|
||||
|
||||
(define private-scheme-container-keymap (new keymap%))
|
||||
(define/public (get-private-scheme-container-keymap) private-scheme-container-keymap)
|
||||
|
||||
(define/override (get-keymaps)
|
||||
(editor:add-after-user-keymap private-scheme-container-keymap
|
||||
(super get-keymaps)))
|
||||
|
||||
(define/override (get-word-at current-pos)
|
||||
(let ([no-word ""])
|
||||
(cond
|
||||
|
|
@ -1216,7 +1225,6 @@
|
|||
[else first-non-whitespace]))
|
||||
new-pos)
|
||||
|
||||
|
||||
(super-new)))
|
||||
|
||||
(define -text-mode<%>
|
||||
|
|
@ -1233,9 +1241,7 @@
|
|||
(define/override (on-enable-surrogate text)
|
||||
(send text begin-edit-sequence)
|
||||
(super on-enable-surrogate text)
|
||||
(let ([km (send text get-keymap)])
|
||||
(when km
|
||||
(send km chain-to-keymap keymap #f)))
|
||||
(send (send text get-private-scheme-container-keymap) chain-to-keymap keymap #f)
|
||||
|
||||
;; I don't know about these editor flag settings.
|
||||
;; maybe they belong in drscheme?
|
||||
|
|
@ -1356,6 +1362,37 @@
|
|||
(add-edit-function "uncomment"
|
||||
(λ (x) (send x uncomment-selection)))
|
||||
|
||||
(send keymap add-function "paren-double-select"
|
||||
(λ (text event)
|
||||
(keymap:region-click
|
||||
text event
|
||||
(λ (click-pos eol?)
|
||||
(define str1 (string (send text get-character click-pos)))
|
||||
(define sexp-based-start/end
|
||||
(cond
|
||||
[(ormap (λ (pr) (equal? (cdr pr) str1))
|
||||
(scheme-paren:get-paren-pairs))
|
||||
(define start (send text get-backward-sexp (+ click-pos 1)))
|
||||
(and start
|
||||
(cons start (+ click-pos 1)))]
|
||||
[else
|
||||
(let ([end (send text get-forward-sexp click-pos)])
|
||||
(and end
|
||||
(let ([beginning (send text get-backward-sexp end)])
|
||||
(and beginning
|
||||
(cons beginning end)))))]))
|
||||
(cond
|
||||
[sexp-based-start/end
|
||||
(send text set-position
|
||||
(car sexp-based-start/end)
|
||||
(cdr sexp-based-start/end))]
|
||||
[else
|
||||
(define start-box (box click-pos))
|
||||
(define end-box (box click-pos))
|
||||
(send text find-wordbreak start-box end-box 'selection)
|
||||
(send text set-position (unbox start-box) (unbox end-box))])))))
|
||||
|
||||
|
||||
(let ([add/map-non-clever
|
||||
(λ (name keystroke char)
|
||||
(add-edit-function
|
||||
|
|
@ -1387,6 +1424,8 @@
|
|||
(send keymap map-function "]" "balance-parens")
|
||||
(send keymap map-function "}" "balance-parens")
|
||||
|
||||
(send keymap map-function "leftbuttondouble" "paren-double-select")
|
||||
|
||||
(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))
|
||||
|
|
|
|||
|
|
@ -383,7 +383,9 @@
|
|||
call/text-keymap-initializer
|
||||
|
||||
add-user-keybindings-file
|
||||
remove-user-keybindings-file))
|
||||
remove-user-keybindings-file
|
||||
|
||||
region-click))
|
||||
|
||||
(define-signature color-class^
|
||||
(text<%>
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user