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

fix editor bugs related to line-wrapping, tab insertion, and pasting to the end of an editor that has been line-wrapped in the past (merge to 4.2)

Browse Source 
svn: r14921
This commit is contained in:
Matthew Flatt 2009-05-22 16:24:17 +00:00
parent c1cc6328a5
commit 0b9730158e
8 changed files with 157 additions and 47 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
collects/mred/private/syntax.ss
View File

@ -10,7 +10,8 @@
method-name init-name
let-boxes
properties field-properties init-properties
->long)
->long
assert)
(define-syntax-parameter class-name #f)
@ -264,3 +265,7 @@
[(eqv? +inf.0 i) (expt 2 64)]
[(eqv? +nan.0 i) 0]
[else (inexact->exact (floor i))]))
(define-syntax-rule (assert e) (void))
; (define-syntax-rule (assert e) (unless e (error 'assert "failed: ~s" 'e)))

12
collects/mred/private/wxme/editor-snip.ss
View File

@ -544,17 +544,23 @@
(def/override (get-num-scroll-steps)
(if editor
(send editor num-scroll-lines)
(if (send editor locked-for-read?)
1
(send editor num-scroll-lines))
1))
(def/override (find-scroll-step [real? y])
(if editor
(send editor find-scroll-line (- y top-margin))
(if (send editor locked-for-read?)
0
(send editor find-scroll-line (- y top-margin)))
0))
(def/override (get-scroll-step-offset [exact-integer? n])
(if editor
(+ (send editor scroll-line-location n) top-margin)
(if (send editor locked-for-read?)
0
(+ (send editor scroll-line-location n) top-margin))
0))
(def/override (set-unmodified)

19
collects/mred/private/wxme/mline.ss
View File

@ -923,6 +923,7 @@ Debugging tools:
(let* ([first-line (box #f)]
[para (get-paragraph-style mline first-line)]
[line-max-width (get-line-max-width para max-width (unbox first-line))])
(assert (send media consistent-snip-lines 'pre-check-flow))
(if (send media check-flow line-max-width dc (get-location mline) (get-position mline) (mline-snip mline))
(do-flow)
(flow-right))))
@ -941,17 +942,20 @@ Debugging tools:
(let loop ([asnip (mline-snip mline)])
(if (eq? asnip (mline-last-snip mline))
(begin
(do-extend-line asnip)
(do-extend-line mline asnip)
(assert (send media consistent-snip-lines 'post-do-extend-line))
#t)
(if (has-flag? (snip->flags asnip) NEWLINE)
(begin
(do-new-line asnip)
(send media consistent-snip-lines 'post-do-new-line)
#t)
(begin
(set-snip-line! asnip mline)
(loop (snip->next asnip)))))))
(define (do-new-line asnip)
;; items pushed to next line or new line was inserted
;; items pushed to next line or new line was inserted;
;; current line now ends with ansip (which used to be in the middle of the current line)
(let ([next (mline-next mline)])
(let ([nextsnip (if next
(let loop ([nextsnip (snip->next asnip)])
@ -972,14 +976,15 @@ Debugging tools:
(snips-to-line! newline)
(notify-insert newline))
;; just pushed to next line
;; some of this line pushed to next line --- or maybe multiple lines pushed
;; together into a later line
(begin
(set-mline-last-snip! mline asnip)
(set-snip-line! asnip mline)
(set-mline-snip! next (snip->next asnip))
(snips-to-line! next)))
(let ([nextsnip (snip->next asnip)])
(set-mline-snip! next nextsnip)
(do-extend-line next nextsnip))))
(calc-line-length mline)
(mark-recalculate mline))))
@ -1001,7 +1006,7 @@ Debugging tools:
(notify-delete next)
#t)
#f))
(define (do-extend-line asnip)
(define (do-extend-line mline asnip)
;; this line was extended
(let ([asnip
(if asnip

3
collects/mred/private/wxme/private.ss
View File

@ -98,7 +98,8 @@
get-s-snips
refresh-box
add-back-clickback
do-insert-snips)
do-insert-snips
consistent-snip-lines)
;; editor-admin%
(define-local-member-name

6
collects/mred/private/wxme/snip.ss
View File

@ -643,7 +643,11 @@
(values n
tabs
space
(if units? 1 str-w)))
(if units?
1
(if (zero? str-w)
1.0
str-w))))
(values 0
#()
TAB-WIDTH

89
collects/mred/private/wxme/text.ss
View File

@ -238,6 +238,33 @@
(define/public (get-s-total-width) total-width)
(define/public (get-s-total-height) total-height)
(define/public (consistent-snip-lines who)
(unless (eq? first-line (mline-first (unbox line-root-box)))
(error who "bad first line"))
(unless (eq? last-line (mline-last (unbox line-root-box)))
(error who "bad last line"))
(let loop ([line first-line]
[snip snips])
(unless (eq? snips (mline-snip first-line))
(error who "bad start snip"))
(let sloop ([snip snip])
(unless (eq? line (snip->line snip))
(error who "snip's line is wrong: ~s ~s" snip (snip->line snip)))
(if (eq? snip (mline-last-snip line))
(if (mline-next line)
(begin
(unless (has-flag? (snip->flags snip) NEWLINE)
(error who "strange line ending"))
(loop (mline-next line) (snip->next snip)))
(unless (eq? last-snip snip)
(error who "bad last snip")))
(begin
(when (or (has-flag? (snip->flags snip) NEWLINE)
(has-flag? (snip->flags snip) HARD-NEWLINE))
(error who "mid-line NEWLINE"))
(sloop (snip->next snip))))))
#t)
(define caret-style #f)
(define dragstart 0)
@ -1184,6 +1211,7 @@
;; ----------------------------------------
(define/private (do-insert isnip str snipsl start end scroll-ok?)
(assert (consistent-snip-lines 'do-insert))
(unless (or write-locked?
s-user-locked?
(start . < . 0))
@ -1278,7 +1306,8 @@
(cond
[(or isnip snipsl)
(insert-snips (if isnip (list isnip) snipsl) start success-finish fail-finish)]
[else (insert-string str start success-finish fail-finish)])))))))
[else (insert-string str start success-finish fail-finish)])))))
(assert (consistent-snip-lines 'post-do-insert))))
(define/private (insert-snips snipsl start success-finish fail-finish)
(let ([addlen (for/fold ([addlen 0])
@ -1317,6 +1346,9 @@
(not (has-flag? (snip->flags isnip) HARD-NEWLINE)))
(set-snip-flags! isnip (remove-flag (snip->flags isnip) NEWLINE)))
(assert (consistent-snip-lines 'inner-insert))
(let-values ([(before-snip inserted-new-line?)
(if (and (zero? len) (not did-one?))
@ -1352,6 +1384,10 @@
(set! num-valid-lines (add1 num-valid-lines))
#t)
(begin
;; The former last snip might still have a NEWLINE
;; flag due to line-flowing
(when (has-flag? (snip->flags gsnip) NEWLINE)
(set-snip-flags! gsnip (remove-flag (snip->flags gsnip) NEWLINE)))
(set-snip-line! isnip last-line)
(when (not (mline-snip last-line))
(set-mline-snip! last-line isnip))
@ -1413,6 +1449,8 @@
(set! first-line (mline-first (unbox line-root-box)))
(set! last-line (mline-last (unbox line-root-box)))
(assert (consistent-snip-lines 'inner-insert2))
(loop #t
before-snip
(or inserted-line? inserted-new-line?)
@ -1526,9 +1564,8 @@
(set! first-line (mline-first (unbox line-root-box)))
(set! last-line (mline-last (unbox line-root-box)))
(set! len (+ len addlen))
(unless (= (last-position) (+ (mline-get-position last-line)
(mline-len last-line)))
(error "yuck out"))
(assert (= (last-position) (+ (mline-get-position last-line)
(mline-len last-line))))
(success-finish addlen inserted-line?))
(begin
(when (equal? (string-ref str sp) #\return)
@ -1607,6 +1644,8 @@
(when (has-flag? (snip->flags tabsnip) CAN-SPLIT)
(set-snip-flags! tabsnip
(remove-flag (snip->flags tabsnip) CAN-SPLIT)))
(when (has-flag? (snip->flags snip) NEWLINE)
(set-snip-flags! tabsnip (add-flag (snip->flags tabsnip) NEWLINE)))
(splice-snip tabsnip (snip->prev snip) (snip->next snip))
(set-snip-line! tabsnip (snip->line snip))
@ -1683,6 +1722,7 @@
(set! typing-streak? #t)))
(define/private (do-delete start end with-undo? [scroll-ok? #t])
(assert (consistent-snip-lines 'do-delete))
(unless (or write-locked? s-user-locked?)
(let-values ([(start end set-caret-style?)
(if (eq? end 'back)
@ -1774,7 +1814,8 @@
(set-mline-last-snip! line prev)
;; maybe deleted extra ghost line:
extra-line?))]
[else #f]))])
[else
#f]))])
(delete-snip snip)
(loop prev
(or deleted-line?
@ -1789,7 +1830,7 @@
(set! first-line (mline-first (unbox line-root-box)))
(set! last-line (mline-last (unbox line-root-box)))
(let-values ([(line moved-to-next?)
(if start-snip
(if (has-flag? (snip->flags start-snip) NEWLINE)
@ -1815,6 +1856,8 @@
(when (max-width . >= . 0)
(mline-mark-check-flow line)
(let ([next (mline-next line)])
(when next (mline-mark-check-flow next)))
(let ([prev (mline-prev line)])
(when (and prev
(has-flag? (snip->flags (mline-last-snip prev)) HARD-NEWLINE))
@ -1900,7 +1943,8 @@
(when update-cursor?
(when s-admin
(send s-admin update-cursor))))))))))))))
(send s-admin update-cursor))))))))))))
(assert (consistent-snip-lines 'post-do-delete))))
(define/public (delete . args)
(case-args
@ -3514,6 +3558,7 @@
;; ----------------------------------------
(define/private (do-change-style start end new-style delta restore-sel? counts-as-mod?)
(assert (consistent-snip-lines 'do-change-style))
(unless (or write-locked?
s-user-locked?
(and new-style
@ -3640,7 +3685,8 @@
(check-merge-snips start)
(check-merge-snips end)))
(after-change-style start (- end start))))))))]))))))
(after-change-style start (- end start))))))))]))))
(assert (consistent-snip-lines 'post-do-change-style))))
(def/public (change-style [(make-or-false (make-alts style<%> style-delta%)) st]
[(make-alts exact-nonnegative-integer? (symbol-in start)) [start 'start]]
@ -4507,6 +4553,8 @@
#t))]
[(and (c . < . 0) (b . > . startp))
;; overflow, but previous wordbreak was before this snip
(when had-newline?
(set-snip-flags! snip (add-flag (snip->flags snip) NEWLINE)))
b]
[else
;; overflow: we have to break the word anyway
@ -4570,17 +4618,20 @@
(let ([w (- max-width CURSOR-WIDTH)])
(let loop ([-changed? #f])
(if (mline-update-flow (unbox line-root-box) line-root-box this w dc
(lambda (del-line)
(when (eq? del-line first-line)
(set! first-line (mline-first (unbox line-root-box))))
(when (eq? del-line last-line)
(set! last-line (mline-last (unbox line-root-box)))))
(lambda (ins-line)
(when (not (mline-prev ins-line))
(set! first-line ins-line))
(when (not (mline-next ins-line))
(set! last-line ins-line))))
(if (begin0
(mline-update-flow (unbox line-root-box) line-root-box this w dc
(lambda (del-line)
(when (eq? del-line first-line)
(set! first-line (mline-first (unbox line-root-box))))
(when (eq? del-line last-line)
(set! last-line (mline-last (unbox line-root-box)))))
(lambda (ins-line)
(when (not (mline-prev ins-line))
(set! first-line ins-line))
(when (not (mline-next ins-line))
(set! last-line ins-line))))
(assert (consistent-snip-lines 'post-update-flow)))
(loop #t)
(begin

63
collects/tests/mred/wxme-random.ss
View File

@ -8,7 +8,10 @@
(define orig-t (new text%))
(define frame
(new frame% [label "Test"]
(new (class frame%
(define/augment (on-close) (exit))
(super-new))
[label "Test"]
[width 300]
[height 400]))
(define canvas
@ -24,16 +27,39 @@
(vector-ref v (random (vector-length v))))
(define (random-string)
(random-elem '#("a" "x\ny\nz\n" "hello there")))
(random-elem '#("a" "x\ny\nz\n" "(define (f x)\n (+ x x))\n" "hello there")))
(define seqs (make-hasheq))
(define ts (make-weak-hasheq))
(define ts-length 64)
(define ts-pos 0)
(define ts (make-vector ts-length orig-t))
(define (add-t! t2)
(if (= ts-pos ts-length)
(let ([v ts])
(set! ts (make-vector ts-length orig-t))
(set! ts-pos 0)
(for ([t3 (in-vector v)])
(when (zero? (random 2))
(add-t! t3)))
(add-t! t2))
(begin
(vector-set! ts ts-pos t2)
(set! ts-pos (add1 ts-pos)))))
;; Don't paste before copying, because that interferes with replay
(define copied? #f)
(define (set-copied?! t)
(unless (= (send t get-start-position)
(send t get-end-position))
(set! copied? #t)))
(define actions
(vector
(lambda (t) (send t undo))
(lambda (t) (send t redo))
(lambda (t) (send t insert (random-string) (random (add1 (send t last-position)))))
(lambda (t) (send t insert "\t" (random (add1 (send t last-position)))))
(lambda (t)
(let ([pos (random (add1 (send t last-position)))])
(send t delete pos (random (max 1 (- (send t last-position) pos))))))
@ -50,27 +76,38 @@
(lambda (t)
(let ([pos (random (add1 (send t last-position)))])
(send t set-position pos (random (max 1 (- (send t last-position) pos))))))
(lambda (t) (send t copy))
(lambda (t) (send t cut))
(lambda (t) (send t paste))
(lambda (t) (set-copied?! t) (send t copy))
(lambda (t) (set-copied?! t) (send t cut))
(lambda (t) (set-copied?! t) (send t kill))
(lambda (t) (when copied?
(send t paste)
(when (zero? (random 4))
(send t paste-next))))
(lambda (t) (send t change-style (make-object style-delta% 'change-size (add1 (random 42)))))
(lambda (t) (send t change-style
(send (make-object style-delta%) set-delta-foreground (make-object color%
(random 256)
(random 256)
(random 256)))))
(lambda (t)
(let ([t2 (new text%)])
(hash-set! ts t2 #t)
(add-t! t2)
(init t2)
(send t insert (make-object editor-snip% t2))))
(lambda (t)
(send t set-max-width (if (zero? (random 2)) 100.0 'none)))
(send t set-max-width (if (zero? (random 2))
(+ 50.0 (/ (random 500) 10.0))
'none)))
(lambda (t) (yield (system-idle-evt)))
))
(send canvas focus)
(let loop ()
(let ([act (random-elem actions)]
[t (if (zero? (random 2))
orig-t
(for/fold ([t orig-t])
([t (in-hash-keys ts)]
[n (in-range (random (add1 (hash-count ts))))])
t))])
(printf "~s: ~s\n" seed act)
(random-elem ts))])
(printf "~s: ~s ~s\n" seed (eq-hash-code t) act)
(act t)
(loop)))

5
collects/tests/mred/wxme.ss
View File

@ -606,15 +606,16 @@
(for-each
(lambda (str)
;; (printf ">> ~a <<\n" str)
;; (printf ">> ~s <<\n" str)
(for ([i (in-range (add1 (send t last-position)))])
;; (printf "~a\n" i)
(check-line-starts)
(send t insert str i)
(check-line-starts)
;; (printf "=> ~a ~s\n" i (send t get-text 0 'eof #t #t))
(send t last-line)
(send t delete i (+ i (string-length str)))
(check-line-starts)
;; (printf "~a ~s <=\n" i (send t get-text 0 'eof #t #t))
(check-ge&h-flow)))
'(" a" "a " "qvzxw " " qvxzw" "qqq qqqq" "a\nb"))