text-delegate.rkt
1 #lang racket/base 2 (require racket/unit 3 racket/class 4 mred/mred-sig 5 "text-sig.rkt" 6 "sig.rkt") 7 8 (provide text-delegate@) 9 10 (define-unit text-delegate@ 11 (import mred^ 12 text-basic^ 13 [prefix racket: framework:racket^]) 14 (export text-delegate^) 15 16 (define delegate<%> (interface (basic<%>) 17 get-delegate 18 set-delegate)) 19 20 (define small-version-of-snip% 21 (class snip% 22 (init-field big-snip) 23 (define width 0) 24 (define height 0) 25 (define/override (get-extent dc x y wb hb db sb lb rb) 26 (set/f! db 0) 27 (set/f! sb 0) 28 (set/f! lb 0) 29 (set/f! rb 0) 30 (let ([bwb (box 0)] 31 [bhb (box 0)]) 32 (send big-snip get-extent dc x y bwb bhb #f #f #f #f) 33 (let* ([cw (send dc get-char-width)] 34 [ch (send dc get-char-height)] 35 [w (floor (/ (unbox bwb) cw))] 36 [h (floor (/ (unbox bhb) ch))]) 37 (set/f! wb w) 38 (set/f! hb h) 39 (set! width w) 40 (set! height h)))) 41 42 (define/override (draw dc x y left top right bottom dx dy draw-caret) 43 (send dc draw-rectangle x y width height)) 44 (define/override (copy) (instantiate small-version-of-snip% () (big-snip big-snip))) 45 (super-instantiate ()))) 46 47 (define 1-pixel-string-snip% 48 (class string-snip% 49 (init-rest args) 50 (inherit get-text get-count set-count get-flags) 51 (define/override (split position first second) 52 (let* ([str (get-text 0 (get-count))] 53 [new-second (make-object 1-pixel-string-snip% 54 (substring str position (string-length str)))]) 55 (set-box! first this) 56 (set-box! second new-second) 57 (set-count position) 58 (void))) 59 (define/override (copy) 60 (let ([cpy (make-object 1-pixel-string-snip% 61 (get-text 0 (get-count)))]) 62 (send cpy set-flags (get-flags)))) 63 (define/override (partial-offset dc x y len) 64 len) 65 (define/override (get-extent dc x y wb hb db sb lb rb) 66 (cond 67 [(memq 'invisible (get-flags)) 68 (set/f! wb 0)] 69 [else 70 (set/f! wb (get-count))]) 71 (set/f! hb 1) 72 (set/f! db 0) 73 (set/f! sb 0) 74 (set/f! lb 0) 75 (set/f! rb 0)) 76 77 (define cache-function void) 78 (define cache-str (make-string 1 #\space)) 79 (define container-str (make-string 1 #\space)) 80 81 (inherit get-text!) 82 83 (define/override (draw dc x y left top right bottom dx dy draw-caret) 84 (let ([len (get-count)]) 85 (unless (= len (string-length container-str)) 86 (set! container-str (make-string len #\space)) 87 (set! cache-function void)) 88 (get-text! container-str 0 len 0) 89 (unless (string=? container-str cache-str) 90 (set! cache-function (for-each/sections container-str)) 91 (set! cache-str (make-string len #\space)) 92 (get-text! cache-str 0 len 0))) 93 (when (<= top y bottom) 94 (cache-function dc x y))) 95 96 (apply super-make-object args))) 97 98 ;; for-each/sections : string -> dc number number -> void 99 (define (for-each/sections str) 100 (let ([str-len (string-length str)]) 101 (cond 102 [(zero? str-len) 103 void] 104 [else 105 (let loop ([i 1] 106 [len 1] 107 [start 0] 108 [blank? (char-whitespace? (string-ref str 0))]) 109 (cond 110 [(= i str-len) 111 (if blank? 112 void 113 (λ (dc x y) 114 (send dc draw-line (+ x start) y (+ x start (- len 1)) y)))] 115 [else 116 (let ([white? (char-whitespace? (string-ref str i))]) 117 (cond 118 [(eq? white? blank?) 119 (loop (+ i 1) (+ len 1) start blank?)] 120 [else 121 (let ([res (loop (+ i 1) 1 i (not blank?))]) 122 (if blank? 123 res 124 (λ (dc x y) 125 (res dc x y) 126 (send dc draw-line (+ x start) y (+ x start (- len 1)) y))))]))]))]))) 127 128 129 #; 130 (let () 131 ;; test cases for for-each/section 132 (define (run-fe/s str) 133 (let ([calls '()]) 134 ((for-each/sections str) 135 (new (class object% 136 (define/public (draw-line x1 y1 x2 y2) 137 (set! calls (cons (list x1 x2) calls))) 138 (super-new))) 139 0 140 0) 141 calls)) 142 143 (printf "framework/private/text.rkt: ~s\n" 144 (list 145 (equal? (run-fe/s "") '()) 146 (equal? (run-fe/s "a") '((0 0))) 147 (equal? (run-fe/s " ") '()) 148 (equal? (run-fe/s "ab") '((0 1))) 149 (equal? (run-fe/s "ab c") '((0 1) (3 3))) 150 (equal? (run-fe/s "a bc") '((0 0) (2 3))) 151 (equal? (run-fe/s "a b c d") '((0 0) (2 2) (4 4) (6 6))) 152 (equal? (run-fe/s "a b c d ") '((0 0) (2 2) (4 4) (6 6))) 153 (equal? (run-fe/s "abc def ghi") '((0 2) (4 6) (8 10))) 154 (equal? (run-fe/s "abc def ghi") '((0 2) (6 8) (12 14)))))) 155 156 (define 1-pixel-tab-snip% 157 (class tab-snip% 158 (init-rest args) 159 (inherit get-text get-count set-count get-flags) 160 (define/override (split position first second) 161 (let* ([str (get-text 0 (get-count))] 162 [new-second (make-object 1-pixel-string-snip% 163 (substring str position (string-length str)))]) 164 (set-box! first this) 165 (set-box! second new-second) 166 (set-count position) 167 (void))) 168 (define/override (copy) 169 (let ([cpy (make-object 1-pixel-tab-snip%)]) 170 (send cpy set-flags (get-flags)))) 171 172 (inherit get-admin) 173 (define/override (get-extent dc x y wb hb db sb lb rb) 174 (set/f! wb 0) 175 (let ([admin (get-admin)]) 176 (when admin 177 (let ([ed (send admin get-editor)]) 178 (when (is-a? ed text%) 179 (let ([len-b (box 0)] 180 [tab-width-b (box 0)] 181 [in-units-b (box #f)]) 182 (send ed get-tabs len-b tab-width-b in-units-b) 183 (when (and (or (equal? (unbox len-b) 0) 184 (equal? (unbox len-b) null)) 185 (not (unbox in-units-b))) 186 (let ([tabspace (unbox tab-width-b)]) 187 (set/f! wb (tabspace . - . (x . modulo . tabspace)))))))))) 188 189 (set/f! hb 0) 190 (set/f! db 0) 191 (set/f! sb 0) 192 (set/f! lb 0) 193 (set/f! rb 0)) 194 195 (define/override (draw dc x y left top right bottom dx dy draw-caret) 196 (void)) 197 (apply super-make-object args))) 198 199 (define (set/f! b n) 200 (when (box? b) 201 (set-box! b n))) 202 203 (define delegate-mixin 204 (mixin (basic<%>) (delegate<%>) 205 (inherit split-snip find-snip 206 get-snip-position 207 find-first-snip 208 get-style-list set-tabs) 209 210 (define linked-snips #f) 211 212 (define/private (copy snip) 213 (let ([new-snip 214 (cond 215 [(is-a? snip tab-snip%) 216 (let ([new-snip (make-object 1-pixel-tab-snip%)]) 217 (send new-snip insert (string #\tab) 1) 218 new-snip)] 219 [(is-a? snip string-snip%) 220 (make-object 1-pixel-string-snip% 221 (send snip get-text 0 (send snip get-count)))] 222 [else 223 (let ([new-snip 224 (instantiate small-version-of-snip% () 225 (big-snip snip))]) 226 (hash-set! linked-snips snip new-snip) 227 new-snip)])]) 228 (send new-snip set-flags (send snip get-flags)) 229 (send new-snip set-style (send snip get-style)) 230 new-snip)) 231 232 (define delegate #f) 233 (inherit get-highlighted-ranges) 234 (define/public-final (get-delegate) delegate) 235 (define/public-final (set-delegate _d) 236 (when delegate 237 ;; the delegate may be in a bad state because we've killed the pending todo 238 ;; items; to clear out the bad state, end any edit sequences, and unhighlight 239 ;; any highlighted ranges. The rest of the state is reset if the editor 240 ;; is ever installed as a delegate again (by refresh-delegate) 241 (let loop () 242 (when (send delegate in-edit-sequence?) 243 (send delegate end-edit-sequence) 244 (loop))) 245 (for ([range (in-list (send delegate get-highlighted-ranges))]) 246 (send delegate unhighlight-range 247 (range-start range) 248 (range-end range) 249 (range-color range) 250 (range-caret-space? range) 251 (range-style range)))) 252 253 (set! delegate _d) 254 (set! linked-snips (if _d 255 (make-hasheq) 256 #f)) 257 (refresh-delegate)) 258 259 (define/private (refresh-delegate) 260 (when delegate 261 (refresh-delegate/do-work))) 262 263 (define/private (refresh-delegate/do-work) 264 (send delegate begin-edit-sequence) 265 (send delegate lock #f) 266 (when (is-a? this racket:text<%>) 267 (send delegate set-tabs null (send this get-tab-size) #f)) 268 (send delegate hide-caret #t) 269 (send delegate erase) 270 (send delegate set-style-list (get-style-list)) 271 (let loop ([snip (find-first-snip)]) 272 (when snip 273 (let ([copy-of-snip (copy snip)]) 274 (send delegate insert 275 copy-of-snip 276 (send delegate last-position) 277 (send delegate last-position)) 278 (loop (send snip next))))) 279 (for-each 280 (λ (range) 281 (send delegate unhighlight-range 282 (range-start range) 283 (range-end range) 284 (range-color range) 285 (range-caret-space? range) 286 (range-style range))) 287 (send delegate get-highlighted-ranges)) 288 (for-each 289 (λ (range) 290 (send delegate highlight-range 291 (range-start range) 292 (range-end range) 293 (range-color range) 294 (range-caret-space? range) 295 'high 296 (range-style range))) 297 (reverse (get-highlighted-ranges))) 298 (send delegate lock #t) 299 (send delegate end-edit-sequence)) 300 301 (define/override (highlight-range start end color 302 [caret-space? #f] 303 [priority 'low] 304 [style 'rectangle] 305 #:adjust-on-insert/delete? [adjust-on-insert/delete? #f] 306 #:key [key #f]) 307 (when delegate 308 (send delegate highlight-range start end color caret-space? priority style 309 #:adjust-on-insert/delete? adjust-on-insert/delete? 310 #:key key)) 311 (super highlight-range start end color caret-space? priority style 312 #:adjust-on-insert/delete? adjust-on-insert/delete? 313 #:key key)) 314 315 ;; only need to override this unhighlight-ranges, since 316 ;; all the other unhighlighting variants call this one 317 (define/override (unhighlight-ranges pred [just-one? #f]) 318 (when delegate 319 (send delegate unhighlight-ranges pred just-one?)) 320 (super unhighlight-ranges pred just-one?)) 321 322 (inherit get-canvases get-active-canvas has-focus?) 323 (define/override (on-paint before? dc left top right bottom dx dy draw-caret?) 324 (super on-paint before? dc left top right bottom dx dy draw-caret?) 325 (when delegate 326 (unless before? 327 (let ([active-canvas (get-active-canvas)]) 328 (when active-canvas 329 (send (send active-canvas get-top-level-window) delegate-moved)))))) 330 331 (define no-delegate-edit-sequence-depth 0) 332 333 (define/augment (on-edit-sequence) 334 (cond 335 [delegate 336 (send delegate begin-edit-sequence)] 337 [else 338 (set! no-delegate-edit-sequence-depth 339 (+ no-delegate-edit-sequence-depth 1))]) 340 (inner (void) on-edit-sequence)) 341 342 (define/augment (after-edit-sequence) 343 (cond 344 [(and delegate 345 (= 0 no-delegate-edit-sequence-depth)) 346 (send delegate end-edit-sequence)] 347 [else 348 (set! no-delegate-edit-sequence-depth 349 (- no-delegate-edit-sequence-depth 1))]) 350 (inner (void) after-edit-sequence)) 351 352 (define/override (resized snip redraw-now?) 353 (super resized snip redraw-now?) 354 (when (and delegate 355 (not (is-a? snip string-snip%))) 356 (when linked-snips 357 (let ([delegate-copy (hash-ref linked-snips snip (λ () #f))]) 358 (when delegate-copy 359 (send delegate resized delegate-copy redraw-now?)))))) 360 361 (define/augment (after-insert start len) 362 (when delegate 363 (send delegate begin-edit-sequence) 364 (send delegate lock #f) 365 (split-snip start) 366 (split-snip (+ start len)) 367 (let loop ([snip (find-snip (+ start len) 'before-or-none)]) 368 (when snip 369 (unless ((get-snip-position snip) . < . start) 370 (send delegate insert (copy snip) start start) 371 (loop (send snip previous))))) 372 (send delegate lock #t) 373 (send delegate end-edit-sequence)) 374 (inner (void) after-insert start len)) 375 376 (define/augment (after-delete start len) 377 (when delegate 378 (send delegate lock #f) 379 (send delegate begin-edit-sequence) 380 (send delegate delete start (+ start len)) 381 (send delegate end-edit-sequence) 382 (send delegate lock #t)) 383 (inner (void) after-delete start len)) 384 385 (define/augment (after-change-style start len) 386 (when delegate 387 (send delegate begin-edit-sequence) 388 (send delegate lock #f) 389 (split-snip start) 390 (let* ([snip (find-snip start 'after)] 391 [style (send snip get-style)]) 392 (send delegate change-style style start (+ start len))) 393 (send delegate lock #f) 394 (send delegate end-edit-sequence)) 395 (inner (void) after-change-style start len)) 396 397 (define/augment (after-load-file success?) 398 (when success? 399 (refresh-delegate)) 400 (inner (void) after-load-file success?)) 401 (super-new))))