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

fixed PR 8518

Browse Source 
svn: r5566

original commit: a1c88e3ac2a8cb94b5dcdbed9b99aebc2dbf17b8
This commit is contained in:
Robby Findler 2007-02-06 18:17:39 +00:00
parent 67b287d2d9
commit af1953707d
2 changed files with 42 additions and 20 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
collects/framework/private/frame.ss
View File

@ -1,4 +1,3 @@
(module frame (lib "a-unit.ss")
(require (lib "string-constant.ss" "string-constants")
(lib "class.ss")

61
collects/framework/private/text.ss
View File

@ -44,6 +44,7 @@ WARNING: printf is rebound in the body of the unit to always
(define basic<%>
(interface (editor:basic<%> (class->interface text%))
highlight-range
unhighlight-range
get-highlighted-ranges
get-styles-fixed
get-fixed-style
@ -239,17 +240,28 @@ WARNING: printf is rebound in the body of the unit to always
(set! ranges (if (eq? priority 'high) (cons l ranges) (append ranges (list l))))
(recompute-range-rectangles)
(invalidate-rectangles range-rectangles)
(λ ()
(let ([old-rectangles range-rectangles])
(set! ranges
(let loop ([r ranges])
(cond
[(null? r) r]
[else (if (eq? (car r) l)
(cdr r)
(cons (car r) (loop (cdr r))))])))
(recompute-range-rectangles)
(invalidate-rectangles old-rectangles))))))
(λ () (unhighlight-range start end color bitmap caret-space?)))))
(define/public unhighlight-range
(opt-lambda (start end color [bitmap #f] [caret-space? #f])
(let ([old-rectangles range-rectangles])
(set! ranges
(let loop ([r ranges])
(cond
[(null? r) r]
[else (if (matching-rectangle? (car r) start end color bitmap caret-space?)
(cdr r)
(cons (car r) (loop (cdr r))))])))
(recompute-range-rectangles)
(invalidate-rectangles old-rectangles))))
(define/private (matching-rectangle? r start end color bitmap caret-space?)
(and (equal? start (range-start r))
(equal? end (range-end r))
(eq? bitmap (range-b/w-bitmap r))
(equal? color (range-color r))
(equal? caret-space? (range-caret-space? r))))
(define/override (on-paint before dc left-margin top-margin right-margin bottom-margin dx dy draw-caret)
(super on-paint before dc left-margin top-margin right-margin bottom-margin dx dy draw-caret)
(recompute-range-rectangles)
@ -652,6 +664,15 @@ WARNING: printf is rebound in the body of the unit to always
(send delegate last-position)
(send delegate last-position))
(loop (send snip next)))))
(for-each
(λ (range)
(send delegate unhighlight-range
(range-start range)
(range-end range)
(range-color range)
(range-b/w-bitmap range)
(range-caret-space? range)))
(send delegate get-highlighted-ranges))
(for-each
(λ (range)
(send delegate highlight-range
@ -667,14 +688,16 @@ WARNING: printf is rebound in the body of the unit to always
(define/override highlight-range
(opt-lambda (start end color [bitmap #f] [caret-space? #f] [priority 'low])
(let ([res (super highlight-range start end color bitmap caret-space? priority)])
(if delegate
(let ([delegate-res (send delegate highlight-range
start end color bitmap caret-space? priority)])
(λ ()
(res)
(delegate-res)))
res))))
(when delegate
(send delegate highlight-range
start end color bitmap caret-space? priority))
(super highlight-range start end color bitmap caret-space? priority)))
(define/override unhighlight-range
(opt-lambda (start end color [bitmap #f] [caret-space? #f])
(when delegate
(send delegate unhighlight-range start end color bitmap caret-space?))
(super unhighlight-range start end color bitmap caret-space?)))
(inherit get-canvases get-active-canvas has-focus?)
(define/override (on-paint before? dc left top right bottom dx dy draw-caret?)