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

Fix collapse-newline in the case that the insertion point

Browse Source 
is at the first position of the text.

closes PR 14043

Also, Rackety.

original commit: 88d61e096c37344747d3ead6dcbe3f36e2aa27e8
This commit is contained in:
Robby Findler 2013-10-12 09:54:10 -05:00
parent 3b456234fd
commit aeb68d32ab
2 changed files with 65 additions and 59 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

111
pkgs/gui-pkgs/gui-lib/framework/private/keymap.rkt
View File

@ -458,65 +458,58 @@
[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)]))))))]
(define (find-nonwhite pos d offset)
(define done (if (= offset -1) 0 (send edit last-position)))
(let/ec escape
(let loop ([pos pos])
(cond
[(= pos done) (escape pos)]
[else
(define c (send edit get-character (+ pos offset)))
(cond
[(char=? #\newline c)
(loop (+ pos d))
(escape pos)]
[(char-whitespace? c)
(loop (+ pos d))]
[else pos])]))))
(define sel-start (send edit get-start-position))
(define sel-end (send edit get-end-position))
(when (= sel-start sel-end)
(define pos-para (send edit position-paragraph sel-start #f))
(define pos-para-start (send edit paragraph-start-position pos-para))
(define pos-para-end (send edit paragraph-end-position pos-para))
(define whitepara?
(let loop ([pos pos-para-start])
(if (>= pos pos-para-end)
#t
(and (char-whitespace? (send edit get-character pos))
(loop (add1 pos))))))
(define start (find-nonwhite pos-para-start -1 -1))
(define end (find-nonwhite pos-para-end 1 0))
(define start-para (send edit position-paragraph start #f))
(define start-para-start (send edit paragraph-start-position start-para))
(define end-para (send edit position-paragraph end #f))
(define end-para-start (send edit paragraph-start-position (add1 end-para)))
(cond
[(and whitepara?
(= start-para pos-para)
(= end-para pos-para))
; Special case: just delete this para
(send edit delete pos-para-start (add1 pos-para-end))]
[(and whitepara? (< start-para pos-para))
; Can delete before & after
(send* edit
(begin-edit-sequence)
(delete (add1 pos-para-end) end-para-start)
(delete start-para-start pos-para-start)
(end-edit-sequence))]
[else
; Only delete after
(send edit delete (add1 pos-para-end) end-para-start)])))]
[open-line
(λ (edit event)

13
pkgs/gui-pkgs/gui-test/framework/tests/keys.rkt
View File

@ -128,6 +128,19 @@
(list '((#\f control)) '((right)))
(list '((#\f control)) '((right))))
(make-key-spec/allplatforms (build-buff-spec "\n\n\n\n" 2 2)
(build-buff-spec "\n" 0 0)
'(((#\x control) (#\o control))))
(make-key-spec/allplatforms (build-buff-spec " \n \n \n \n" 7 7)
(build-buff-spec " \n" 1 1)
'(((#\x control) (#\o control))))
(make-key-spec/allplatforms (build-buff-spec "\n\n\n\n" 0 0)
(build-buff-spec "\n" 0 0)
'(((#\x control) (#\o control))))
(make-key-spec/allplatforms (build-buff-spec "abcdef\n\n\n\nxyzpdq\n" 8 8)
(build-buff-spec "abcdef\n\nxyzpdq\n" 7 7)
'(((#\x control) (#\o control))))
;; TeX-compress tests
(make-key-spec/allplatforms
(build-buff-spec "\\ome" 4 4)