1#lang racket/base 2(require racket/class 3 racket/gui/base 4 data/interval-map 5 racket/draw/arrow 6 framework 7 data/interval-map 8 macro-debugger/syntax-browser/interfaces) 9 10(provide text:hover<%> 11 text:hover-drawings<%> 12 text:arrows<%> 13 14 text:hover-mixin 15 text:hover-drawings-mixin 16 text:tacking-mixin 17 text:arrows-mixin 18 text:region-data-mixin 19 text:clickregion-mixin 20 browser-text%) 21 22(define arrow-cursor (make-object cursor% 'arrow)) 23 24(define arrow-brush 25 (send the-brush-list find-or-create-brush "white" 'solid)) 26(define (tacked-arrow-brush color) 27 (send the-brush-list find-or-create-brush color 'solid)) 28 29(define billboard-brush 30 (send the-brush-list find-or-create-brush "white" 'solid)) 31 32(define white (send the-color-database find-color "white")) 33 34;; A Drawing is (make-drawing (??? -> void) (box boolean)) 35(define-struct drawing (draw tacked?)) 36 37(define-struct idloc (start end id)) 38 39(define (mean x y) 40 (/ (+ x y) 2)) 41 42;; save+restore pen, brush, also smoothing 43(define-syntax with-saved-pen&brush 44 (syntax-rules () 45 [(with-saved-pen&brush dc . body) 46 (save-pen&brush dc (lambda () . body))])) 47 48(define (save-pen&brush dc thunk) 49 (let ([old-pen (send dc get-pen)] 50 [old-brush (send dc get-brush)] 51 [old-smoothing (send dc get-smoothing)]) 52 (begin0 (thunk) 53 (send* dc 54 (set-pen old-pen) 55 (set-brush old-brush) 56 (set-smoothing old-smoothing))))) 57 58(define-syntax with-saved-text-config 59 (syntax-rules () 60 [(with-saved-text-config dc . body) 61 (save-text-config dc (lambda () . body))])) 62 63(define (save-text-config dc thunk) 64 (let ([old-font (send dc get-font)] 65 [old-color (send dc get-text-foreground)] 66 [old-background (send dc get-text-background)] 67 [old-mode (send dc get-text-mode)]) 68 (begin0 (thunk) 69 (send* dc 70 (set-font old-font) 71 (set-text-foreground old-color) 72 (set-text-background old-background) 73 (set-text-mode old-mode))))) 74 75;; Interfaces 76 77(define text:region-data<%> 78 (interface (text:basic<%>) 79 get-region-mapping)) 80 81(define text:hover<%> 82 (interface (text:basic<%>) 83 update-hover-position)) 84 85(define text:hover-drawings<%> 86 (interface (text:basic<%>) 87 add-hover-drawing 88 get-position-drawings)) 89 90(define text:arrows<%> 91 (interface (text:hover-drawings<%>) 92 add-arrow 93 add-billboard)) 94 95;; Mixins 96 97(define text:region-data-mixin 98 (mixin (text:basic<%>) (text:region-data<%>) 99 100 (define table (make-hasheq)) 101 102 (define/public (get-region-mapping key) 103 (hash-ref! table key (lambda () (make-interval-map)))) 104 105 (define/augment (after-delete start len) 106 (for ([im (in-hash-values table)]) 107 (interval-map-contract! im start (+ start len))) 108 (inner (void) after-delete start len)) 109 110 (define/augment (after-insert start len) 111 (for ([im (in-hash-values table)]) 112 (interval-map-expand! im start (+ start len))) 113 (inner (void) after-insert start len)) 114 115 (super-new))) 116 117(define text:hover-mixin 118 (mixin (text:basic<%>) (text:hover<%>) 119 (inherit dc-location-to-editor-location 120 find-position) 121 122 (define/override (on-default-event ev) 123 (super on-default-event ev) 124 (case (send ev get-event-type) 125 ((enter motion leave) 126 (define-values (x y) 127 (let ([gx (send ev get-x)] 128 [gy (send ev get-y)]) 129 (dc-location-to-editor-location gx gy))) 130 (define on-it? (box #f)) 131 (define pos (find-position x y #f on-it?)) 132 (update-hover-position (and (unbox on-it?) pos))))) 133 134 (define/public (update-hover-position pos) 135 (void)) 136 137 (super-new))) 138 139(define text:hover-drawings-mixin 140 (mixin (text:hover<%> text:region-data<%>) (text:hover-drawings<%>) 141 (inherit dc-location-to-editor-location 142 find-position 143 invalidate-bitmap-cache 144 get-region-mapping) 145 (super-new) 146 147 ;; interval-map of Drawings 148 (define drawings-list (get-region-mapping 'hover-drawings)) 149 150 (field [hover-position #f]) 151 152 (define/override (update-hover-position pos) 153 (define old-pos hover-position) 154 (super update-hover-position pos) 155 (set! hover-position pos) 156 (unless (same-drawings? old-pos pos) 157 (invalidate-bitmap-cache 0.0 0.0 +inf.0 +inf.0))) 158 159 (define/public (add-hover-drawing start end draw [tack-box (box #f)]) 160 (let ([drawing (make-drawing draw tack-box)]) 161 (interval-map-cons*! drawings-list 162 start (add1 end) 163 drawing 164 null))) 165 166 (define/override (on-paint before? dc left top right bottom dx dy draw-caret) 167 (super on-paint before? dc left top right bottom dx dy draw-caret) 168 (unless before? 169 (for ([d (get-position-drawings hover-position)]) 170 ((drawing-draw d) this dc left top right bottom dx dy)))) 171 172 (define/public (get-position-drawings pos) 173 (if pos (interval-map-ref drawings-list pos null) null)) 174 175 (define/private (same-drawings? old-pos pos) 176 ;; relies on order drawings added & list-of-eq?-struct equality 177 (equal? (get-position-drawings old-pos) 178 (get-position-drawings pos))))) 179 180(define text:tacking-mixin 181 (mixin (text:basic<%> text:hover-drawings<%>) () 182 (inherit get-canvas 183 get-keymap 184 get-position-drawings) 185 (inherit-field hover-position) 186 (super-new) 187 188 (define tacked-table (make-hasheq)) 189 190 (define/override (on-local-event ev) 191 (case (send ev get-event-type) 192 ((right-down) 193 (if (pair? (get-position-drawings hover-position)) 194 (send (get-canvas) popup-menu 195 (make-tack/untack-menu (get-position-drawings hover-position)) 196 (send ev get-x) 197 (send ev get-y)) 198 (super on-local-event ev))) 199 (else 200 (super on-local-event ev)))) 201 202 ;; Clear tacked-table on any modification. 203 ;; FIXME: possible to be more precise? (but not needed for macro stepper) 204 (define/augment (after-delete start len) 205 (set! tacked-table (make-hasheq)) 206 (inner (void) after-delete start len)) 207 (define/augment (after-insert start len) 208 (set! tacked-table (make-hasheq)) 209 (inner (void) after-insert start len)) 210 211 (define/override (on-paint before? dc left top right bottom dx dy draw-caret) 212 (super on-paint before? dc left top right bottom dx dy draw-caret) 213 (unless before? 214 (for ([draw (in-hash-keys tacked-table)]) 215 (draw this dc left top right bottom dx dy)))) 216 217 (define/private (make-tack/untack-menu drawings) 218 (define menu (new popup-menu%)) 219 (define keymap (get-keymap)) 220 (define tack-item 221 (new menu-item% (label "Tack") 222 (parent menu) 223 (callback (lambda _ (tack drawings))))) 224 (define untack-item 225 (new menu-item% (label "Untack") 226 (parent menu) 227 (callback (lambda _ (untack drawings))))) 228 (send tack-item enable 229 (for/or ([d (in-list drawings)]) (not (unbox (drawing-tacked? d))))) 230 (send untack-item enable 231 (for/or ([d (in-list drawings)]) (unbox (drawing-tacked? d)))) 232 (when (is-a? keymap keymap/popup<%>) 233 (new separator-menu-item% (parent menu)) 234 (send keymap add-context-menu-items menu)) 235 menu) 236 237 (define/private (tack drawings) 238 (for ([d (in-list drawings)]) 239 (hash-set! tacked-table (drawing-draw d) #t) 240 (set-box! (drawing-tacked? d) #t))) 241 (define/private (untack drawings) 242 (for ([d (in-list drawings)]) 243 (hash-remove! tacked-table (drawing-draw d)) 244 (set-box! (drawing-tacked? d) #f))))) 245 246(define text:arrows-mixin 247 (mixin (text:hover-drawings<%>) (text:arrows<%>) 248 (inherit position-location 249 add-hover-drawing 250 find-wordbreak) 251 252 (define/public (add-billboard pos1 pos2 str color-name) 253 (define color (send the-color-database find-color color-name)) 254 (let ([draw 255 (lambda (text dc left top right bottom dx dy) 256 (let-values ([(x y) (range->mean-loc pos1 pos1)] 257 [(fw fh _d _v) (send dc get-text-extent "y")]) 258 (with-saved-pen&brush dc 259 (with-saved-text-config dc 260 (send* dc 261 (set-pen color 1 'solid) 262 (set-brush billboard-brush) 263 (set-text-mode 'solid) 264 (set-font (billboard-font dc)) 265 (set-text-foreground color)) 266 (let-values ([(w h d v) (send dc get-text-extent str)] 267 [(adj-y) fh] 268 [(mini) _d]) 269 (send* dc 270 (set-smoothing 'smoothed) 271 (draw-rounded-rectangle 272 (+ x dx) 273 (+ y dy adj-y) 274 (+ w mini mini) 275 (+ h mini mini)) 276 (draw-text str (+ x dx mini) (+ y dy mini adj-y))))))))]) 277 (add-hover-drawing pos1 pos2 draw))) 278 279 (define/public (add-arrow from1 from2 to1 to2 color-name label where) 280 (define color (send the-color-database find-color color-name)) 281 (define tack-box (box #f)) 282 (unless (and (= from1 to1) (= from2 to2)) 283 (let ([draw 284 (lambda (text dc left top right bottom dx dy) 285 (let-values ([(startx starty) (range->mean-loc from1 from2)] 286 [(endx endy) (range->mean-loc to1 to2)] 287 [(fw fh _d _v) (send dc get-text-extent "x")] 288 [(lw lh ld _V) (send dc get-text-extent (or label "x"))]) 289 (with-saved-pen&brush dc 290 (with-saved-text-config dc 291 (send dc set-pen color 1 'solid) 292 (send dc set-brush 293 (if (unbox tack-box) 294 (tacked-arrow-brush color) 295 arrow-brush)) 296 (draw-arrow dc startx 297 (+ starty (/ fh 2)) 298 endx 299 (+ endy (/ fh 2)) 300 dx dy) 301 (when label 302 (let* ([lx (+ endx dx fw)] 303 [ly (+ (+ endy dy) fh)]) 304 (send* dc 305 (set-brush billboard-brush) 306 (set-font (billboard-font dc)) 307 (set-text-foreground color) 308 (set-smoothing 'smoothed) 309 (draw-rounded-rectangle (- lx ld) (- ly ld) 310 (+ lw ld ld) (+ lh ld ld)) 311 (draw-text label lx ly))))))))]) 312 (add-hover-drawing from1 from2 draw tack-box) 313 (add-hover-drawing to1 to2 draw tack-box)))) 314 315 (define/private (position->location p) 316 (define xbox (box 0.0)) 317 (define ybox (box 0.0)) 318 (position-location p xbox ybox) 319 (values (unbox xbox) (unbox ybox))) 320 321 (define/private (?-font dc) 322 (let ([size (send (send dc get-font) get-point-size)]) 323 (send the-font-list find-or-create-font size 'default 'normal 'bold))) 324 325 (define/private (billboard-font dc) 326 (let ([size (send (send dc get-font) get-point-size)]) 327 (send the-font-list find-or-create-font size 'default 'normal))) 328 329 (define/private (range->mean-loc pos1 pos2) 330 (let*-values ([(loc1x loc1y) (position->location pos1)] 331 [(loc2x loc2y) (position->location pos2)] 332 [(locx) (mean loc1x loc2x)] 333 [(locy) (mean loc1y loc2y)]) 334 (values locx locy))) 335 336 (super-new))) 337 338#| 339text:clickregion-mixin 340 341Like clickbacks, but: 342 - use interval-map to avoid linear search 343 (major problem w/ macro stepper and large expansions!) 344 - callback takes position of click, not (start, end) 345 - different rules for removal 346 - TODO: extend to double-click 347|# 348(define text:clickregion-mixin 349 (mixin (text:region-data<%>) () 350 (inherit get-admin 351 get-region-mapping 352 dc-location-to-editor-location 353 find-position) 354 355 (super-new) 356 357 ;; Two mappings: one for left clicks, another for right 358 ;; mouse-downs. Rationale: macro stepper wants to handle left 359 ;; clicks normally, but wants to insert behavior (ie, change 360 ;; focus) before normal processing of right-down (ie, editor 361 ;; passes to keymap, opens popup menu). 362 (define clickbacks (get-region-mapping 'click-region)) 363 (define right-clickbacks (get-region-mapping 'right-click-region)) 364 (define tracking #f) 365 366 (define/public (set-clickregion start end callback [region 'click]) 367 (let ([mapping 368 (case region 369 ((click) clickbacks) 370 ((right-down) right-clickbacks) 371 (else (error 'set-clickregion 372 "bad region symbol: expected 'click or 'right-down, got ~e" 373 region)))]) 374 (if callback 375 (interval-map-set! mapping start end callback) 376 (interval-map-remove! mapping start end)))) 377 378 (define/private (get-event-position ev) 379 (define-values (x y) 380 (let ([gx (send ev get-x)] 381 [gy (send ev get-y)]) 382 (dc-location-to-editor-location gx gy))) 383 (define on-it? (box #f)) 384 (define pos (find-position x y #f on-it?)) 385 (and (unbox on-it?) pos)) 386 387 ;; on-default-event called if keymap does not handle event 388 (define/override (on-default-event ev) 389 (define admin (get-admin)) 390 (when admin 391 (define pos (get-event-position ev)) 392 (case (send ev get-event-type) 393 ((left-down) 394 (set! tracking (and pos (interval-map-ref clickbacks pos #f))) 395 (send admin update-cursor)) 396 ((left-up) 397 (when tracking 398 (let ([cb (and pos (interval-map-ref clickbacks pos #f))] 399 [tracking* tracking]) 400 (set! tracking #f) 401 (when (eq? tracking* cb) 402 (cb pos))) 403 (send admin update-cursor))))) 404 (super on-default-event ev)) 405 406 ;; on-local-event called before keymap consulted 407 (define/override (on-local-event ev) 408 (case (send ev get-event-type) 409 ((right-down) 410 (when (get-admin) 411 (define pos (get-event-position ev)) 412 (let ([cb (and pos (interval-map-ref right-clickbacks pos #f))]) 413 (when cb (cb pos)))))) 414 (super on-local-event ev)) 415 416 (define/override (adjust-cursor ev) 417 (define pos (get-event-position ev)) 418 (define cb (and pos (interval-map-ref clickbacks pos #f))) 419 (if cb 420 arrow-cursor 421 (super adjust-cursor ev))))) 422 423 424#| 425(define text:hover-identifier<%> 426 (interface () 427 get-hovered-identifier 428 set-hovered-identifier 429 listen-hovered-identifier)) 430 431(define text:hover-identifier-mixin 432 (mixin (text:hover<%>) (text:hover-identifier<%>) 433 (define-notify hovered-identifier (new notify-box% (value #f))) 434 435 (define idlocs null) 436 437 (define/public (add-identifier-location start end id) 438 (set! idlocs (cons (make-idloc start end id) idlocs))) 439 440 (define/public (delete-all-identifier-locations) 441 (set! idlocs null) 442 (set-hovered-identifier #f)) 443 444 (define/override (update-hover-position pos) 445 (super update-hover-position pos) 446 (let search ([idlocs idlocs]) 447 (cond [(null? idlocs) (set-hovered-identifier #f)] 448 [(and (<= (idloc-start (car idlocs)) pos) 449 (< pos (idloc-end (car idlocs)))) 450 (set-hovered-identifier (idloc-id (car idlocs)))] 451 [else (search (cdr idlocs))]))) 452 (super-new))) 453|# 454 455 456(define browser-text% 457 (let ([browser-text-default-style-name "widget.rkt::browser-text% basic"]) 458 (class (text:clickregion-mixin 459 (text:arrows-mixin 460 (text:tacking-mixin 461 (text:hover-drawings-mixin 462 (text:hover-mixin 463 (text:region-data-mixin 464 (text:hide-caret/selection-mixin 465 (text:foreground-color-mixin 466 (text:searching-mixin 467 (editor:keymap-mixin 468 (editor:standard-style-list-mixin text:basic%))))))))))) 469 (init-field keymap) 470 (inherit set-autowrap-bitmap get-style-list) 471 (define/override (get-keymaps) (list keymap)) 472 (define/override (default-style-name) browser-text-default-style-name) 473 (super-new (auto-wrap #t)) 474 (let* ([sl (get-style-list)] 475 [standard (send sl find-named-style (editor:get-default-color-style-name))] 476 [browser-basic (send sl find-or-create-style standard 477 (make-object style-delta% 'change-family 'default))]) 478 (send sl new-named-style browser-text-default-style-name browser-basic)) 479 (set-autowrap-bitmap #f)))) 480