display.rkt (15298B)
1 #lang racket/base 2 (require racket/class 3 racket/gui/base 4 racket/promise 5 data/interval-map 6 framework 7 racket/class/iop 8 "pretty-printer.rkt" 9 macro-debugger/syntax-browser/interfaces 10 "prefs.rkt" 11 "util.rkt" 12 "../util/logger.rkt") 13 (provide print-syntax-to-editor 14 code-style) 15 16 (define-syntax-rule (uninterruptible e ...) 17 ;; (coarsely) prevent breaks within editor operations 18 (parameterize-break #f (begin e ...)) 19 #| 20 (parameterize-break #f 21 (let ([ta (now)]) 22 (begin0 (begin e ...) 23 (let ([tb (now)]) 24 (eprintf "****\n") 25 (pretty-write '(begin e ...) (current-error-port)) 26 (eprintf " -- ~s ms\n\n" (- tb ta)))))) 27 |#) 28 29 (define (now) (current-inexact-milliseconds)) 30 31 ;; FIXME: assumes text never moves 32 33 ;; print-syntax-to-editor : syntax text controller<%> config number number 34 ;; -> display<%> 35 ;; Note: must call display<%>::refresh to finish styling. 36 (define (print-syntax-to-editor stx text controller config columns 37 [insertion-point (send text last-position)]) 38 (define output-port (open-output-string/count-lines)) 39 (define range 40 (with-log-time "** pretty-print-syntax" 41 (pretty-print-syntax stx output-port 42 (send/i controller controller<%> get-primary-partition) 43 (length (send/i config config<%> get-colors)) 44 (send/i config config<%> get-suffix-option) 45 (send config get-pretty-styles) 46 columns 47 (send config get-pretty-abbrev?)))) 48 (define output-string (get-output-string output-port)) 49 (define output-length (sub1 (string-length output-string))) ;; skip final newline 50 (log-macro-stepper-debug "size of pretty-printed text: ~s" output-length) 51 (with-log-time "fixup-parentheses" 52 (fixup-parentheses output-string range)) 53 (with-unlock text 54 (with-log-time "inserting pretty-printed text" 55 (uninterruptible 56 (send text insert output-length output-string insertion-point))) 57 (new display% 58 (text text) 59 (controller controller) 60 (config config) 61 (range range) 62 (start-position insertion-point) 63 (end-position (+ insertion-point output-length))))) 64 65 ;; display% 66 ;; Note: must call refresh method to finish styling. 67 (define display% 68 (class* object% (display<%>) 69 (init-field/i [controller controller<%>] 70 [config config<%>] 71 [range range<%>]) 72 (init-field text 73 start-position 74 end-position) 75 76 (define base-style 77 (code-style text (send/i config config<%> get-syntax-font-size))) 78 79 ;; on-next-refresh : (listof (cons stx style-delta)) 80 ;; Styles to be applied on next refresh only. (eg, underline) 81 (define on-next-refresh null) 82 83 ;; extra-styles : hash[stx => (listof style-delta)] 84 ;; Styles to be re-applied on every refresh. 85 (define extra-styles (make-hasheq)) 86 87 ;; to-undo-styles : (listof (cons nat nat)) 88 ;; Ranges to unbold or unhighlight when selection changes. 89 ;; FIXME: ought to be managed by text:region-data (to auto-update ranges) 90 ;; until then, positions are relative 91 (define to-undo-styles null) 92 93 ;; initialize : -> void 94 (define/private (initialize) 95 (with-log-time "changing base style" 96 (uninterruptible 97 (send text change-style base-style start-position end-position #f))) 98 (with-log-time "applying primary styles" 99 (uninterruptible (apply-primary-partition-styles))) 100 (with-log-time "adding clickbacks" 101 (uninterruptible (add-clickbacks)))) 102 103 ;; add-clickbacks : -> void 104 (define/private (add-clickbacks) 105 (define mapping (send text get-region-mapping 'syntax)) 106 (define lazy-interval-map-init 107 (delay 108 (with-log-time "forcing clickback mapping" 109 (uninterruptible 110 (for ([range (send/i range range<%> all-ranges)]) 111 (let ([stx (range-obj range)] 112 [start (range-start range)] 113 [end (range-end range)]) 114 (interval-map-set! mapping (+ start-position start) (+ start-position end) stx))))))) 115 (define (the-callback position) 116 (force lazy-interval-map-init) 117 (send/i controller selection-manager<%> set-selected-syntax 118 (interval-map-ref mapping position #f))) 119 (send text set-clickregion start-position end-position the-callback) 120 (send text set-clickregion start-position end-position the-callback 'right-down)) 121 122 ;; refresh : -> void 123 ;; Clears all highlighting and reapplies all non-foreground styles. 124 (define/public (refresh) 125 (with-log-time "refresh" 126 (with-unlock text 127 (uninterruptible 128 (let ([undo-select/highlight-d (get-undo-select/highlight-d)]) 129 (for ([r (in-list to-undo-styles)]) 130 (send text change-style undo-select/highlight-d 131 (relative->text-position (car r)) 132 (relative->text-position (cdr r))))) 133 (set! to-undo-styles null)) 134 (uninterruptible 135 (for ([stx+delta (in-list on-next-refresh)]) 136 (for ([r (in-list (send/i range range<%> get-ranges (car stx+delta)))]) 137 (restyle-range r (cdr stx+delta) #f))) 138 (set! on-next-refresh null)) 139 (uninterruptible 140 (apply-extra-styles)) 141 (let ([selected-syntax 142 (send/i controller selection-manager<%> 143 get-selected-syntax)]) 144 (uninterruptible 145 (apply-secondary-relation-styles selected-syntax)) 146 (uninterruptible 147 (apply-selection-styles selected-syntax)))))) 148 149 ;; get-range : -> range<%> 150 (define/public (get-range) range) 151 152 ;; get-start-position : -> number 153 (define/public (get-start-position) start-position) 154 155 ;; get-end-position : -> number 156 (define/public (get-end-position) end-position) 157 158 ;; highlight-syntaxes : (list-of syntax) string -> void 159 (define/public (highlight-syntaxes stxs hi-color) 160 (let ([delta (highlight-style-delta hi-color)]) 161 (for ([stx (in-list stxs)]) 162 (hash-set! extra-styles stx 163 (cons delta (hash-ref extra-styles stx null)))))) 164 165 ;; underline-syntaxes : (listof syntax) -> void 166 (define/public (underline-syntaxes stxs) 167 (for ([stx (in-list stxs)]) 168 (set! on-next-refresh 169 (cons (cons stx underline-d) on-next-refresh)))) 170 171 ;; Primary styles 172 ;; (Done once on initialization, never repeated) 173 174 ;; apply-primary-partition-styles : -> void 175 ;; Changes the foreground color according to the primary partition. 176 ;; Only called once, when the syntax is first drawn. 177 (define/private (apply-primary-partition-styles) 178 (define style-list (send text get-style-list)) 179 (define (color-style color) 180 (let ([delta (new style-delta%)]) 181 (send delta set-delta-foreground color) 182 (send style-list find-or-create-style base-style delta))) 183 (define color-styles 184 (list->vector 185 (map color-style 186 (map translate-color 187 (send/i config config<%> get-colors))))) 188 (define overflow-style (color-style (translate-color "darkgray"))) 189 (define color-partition 190 (send/i controller controller<%> get-primary-partition)) 191 (define offset start-position) 192 ;; Optimization: don't call change-style when new style = old style 193 (let tr*loop ([trs (send/i range range<%> get-treeranges)] [old-style #f]) 194 (for ([tr trs]) 195 (define stx (treerange-obj tr)) 196 (define start (treerange-start tr)) 197 (define end (treerange-end tr)) 198 (define subs (treerange-subs tr)) 199 (define new-style 200 (primary-style stx color-partition color-styles overflow-style)) 201 (unless (eq? old-style new-style) 202 (send text change-style new-style (+ offset start) (+ offset end) #f)) 203 (tr*loop subs new-style))) 204 (void)) 205 206 ;; primary-style : syntax partition (vector-of style-delta%) style-delta% 207 ;; -> style-delta% 208 (define/private (primary-style stx partition color-vector overflow) 209 (let ([n (send/i partition partition<%> get-partition stx)]) 210 (cond [(< n (vector-length color-vector)) 211 (vector-ref color-vector n)] 212 [else 213 overflow]))) 214 215 ;; Secondary Styling 216 ;; May change in response to user actions 217 218 ;; apply-extra-styles : -> void 219 ;; Applies externally-added styles (such as highlighting) 220 (define/private (apply-extra-styles) 221 (for ([(stx deltas) (in-hash extra-styles)]) 222 (for ([r (in-list (send/i range range<%> get-ranges stx))]) 223 (for ([delta (in-list deltas)]) 224 (restyle-range r delta #t))))) 225 226 ;; apply-selection-styles : syntax -> void 227 ;; Styles subterms eq to the selected syntax 228 (define/private (apply-selection-styles selected-syntax) 229 (for ([r (in-list (send/i range range<%> get-ranges selected-syntax))]) 230 (restyle-range r select-d #t))) 231 232 ;; apply-secondary-relation-styles : selected-syntax -> void 233 ;; If the selected syntax is an identifier, then styles all identifiers 234 ;; in the relation with it. 235 (define/private (apply-secondary-relation-styles selected-syntax) 236 (when (identifier? selected-syntax) 237 (let* ([relation (send/i controller controller<%> get-identifier=?)] 238 [secondary-highlight-d (get-secondary-highlight-d)]) 239 (when relation 240 (for ([id (in-list (send/i range range<%> get-identifier-list))]) 241 (when (relation selected-syntax id) 242 (for ([r (in-list (send/i range range<%> get-ranges id))]) 243 (restyle-range r secondary-highlight-d #t)))))))) 244 245 ;; restyle-range : (cons num num) style-delta% boolean -> void 246 (define/private (restyle-range r style need-undo?) 247 (when need-undo? (set! to-undo-styles (cons r to-undo-styles))) 248 (send text change-style style 249 (relative->text-position (car r)) 250 (relative->text-position (cdr r)))) 251 252 ;; relative->text-position : number -> number 253 (define/private (relative->text-position pos) 254 (+ pos start-position)) 255 256 ;; Initialize 257 (super-new) 258 (send/i controller controller<%> add-syntax-display this) 259 (initialize))) 260 261 ;; fixup-parentheses : string range -> void 262 (define (fixup-parentheses string range) 263 (for ([r (send/i range range<%> all-ranges)]) 264 (let ([stx (range-obj r)] 265 [start (range-start r)] 266 [end (range-end r)]) 267 (when (and (syntax? stx) (pair? (syntax-e stx))) 268 (case (syntax-property stx 'paren-shape) 269 ((#\[) 270 (string-set! string start #\[) 271 (string-set! string (sub1 end) #\])) 272 ((#\{) 273 (string-set! string start #\{) 274 (string-set! string (sub1 end) #\}))))))) 275 276 (define (open-output-string/count-lines) 277 (let ([os (open-output-string)]) 278 (port-count-lines! os) 279 os)) 280 281 ;; code-style : text<%> number/#f -> style<%> 282 (define (code-style text font-size) 283 (let* ([style-list (send text get-style-list)] 284 [style (send style-list find-named-style (editor:get-default-color-style-name))]) 285 (if font-size 286 (send style-list find-or-create-style 287 style 288 (make-object style-delta% 'change-size font-size)) 289 style))) 290 291 ;; anchor-snip% 292 (define anchor-snip% 293 (class snip% 294 (define/override (copy) 295 (make-object string-snip% "")) 296 (super-instantiate ()))) 297 298 ;; Color translation 299 300 ;; translate-color : color-string -> color% 301 (define (translate-color color-string) 302 (let ([c (make-object color% color-string)]) 303 (if (pref:invert-colors?) 304 (let-values ([(r* g* b*) 305 (lightness-invert (send c red) (send c green) (send c blue))]) 306 #| 307 (printf "translate: ~s -> ~s\n" 308 (list (send c red) (send c green) (send c blue)) 309 (list r* g* b*)) 310 |# 311 (make-object color% r* g* b*)) 312 c))) 313 314 ;; lightness-invert : uint8 uint8 uint8 -> (values uint8 uint8 uint8) 315 (define (lightness-invert r g b) 316 (define (c x) 317 (/ (exact->inexact x) 255.0)) 318 (define (d x) 319 (inexact->exact (round (* x 255)))) 320 (let-values ([(r g b) (lightness-invert* (c r) (c g) (c b))]) 321 (values (d r) (d g) (d b)))) 322 323 (define (lightness-invert* R G B) 324 (let-values ([(Hp Sl L) (rgb->hsl* R G B)]) 325 (hsl*->rgb Hp Sl (- 1.0 L)))) 326 327 (define (rgb->hsl* R G B) 328 (define M (max R G B)) 329 (define m (min R G B)) 330 (define C (- M m)) 331 (define Hp 332 (cond [(zero? C) 333 ;; Undefined, but use 0 334 0.0] 335 [(= M R) 336 (realmod* (/ (- G B) C) 6)] 337 [(= M G) 338 (+ (/ (- B R) C) 2)] 339 [(= M B) 340 (+ (/ (- R G) C) 4)])) 341 (define L (* 0.5 (+ M m))) 342 (define Sl 343 (cond [(zero? C) 0.0] 344 [(>= L 0.5) (/ C (* 2 L))] 345 [else (/ C (- 2 (* 2 L)))])) 346 347 (values Hp Sl L)) 348 349 (define (hsl*->rgb Hp Sl L) 350 (define C 351 (cond [(>= L 0.5) (* 2 L Sl)] 352 [else (* (- 2 (* 2 L)) Sl)])) 353 (define X (* C (- 1 (abs (- (realmod Hp 2) 1))))) 354 (define-values (R1 G1 B1) 355 (cond [(< Hp 1) (values C X 0)] 356 [(< Hp 2) (values X C 0)] 357 [(< Hp 3) (values 0 C X)] 358 [(< Hp 4) (values 0 X C)] 359 [(< Hp 5) (values X 0 C)] 360 [(< Hp 6) (values C 0 X)])) 361 (define m (- L (* 0.5 C))) 362 (values (+ R1 m) (+ G1 m) (+ B1 m))) 363 364 ;; realmod : real integer -> real 365 ;; Adjusts a real number to [0, base] 366 (define (realmod x base) 367 (define xint (ceiling x)) 368 (define m (modulo xint base)) 369 (realmod* (- m (- xint x)) base)) 370 371 ;; realmod* : real real -> real 372 ;; Adjusts a number in [-base, base] to [0,base] 373 ;; Not a real mod, but faintly reminiscent. 374 (define (realmod* x base) 375 (if (negative? x) 376 (+ x base) 377 x)) 378 379 ;; Styles 380 381 (define select-d 382 (make-object style-delta% 'change-weight 'bold)) 383 384 (define underline-d 385 (make-object style-delta% 'change-underline #t)) 386 387 (define (highlight-style-delta raw-color #:translate-color? [translate-color? #t]) 388 (let ([sd (new style-delta%)] 389 [color (if translate-color? (translate-color raw-color) raw-color)]) 390 (send sd set-delta-background color) 391 sd)) 392 393 (define (mk-2-constant-style bow-color [wob-color (translate-color bow-color)]) 394 (let ([wob-version (highlight-style-delta wob-color #:translate-color? #f)] 395 [bow-version (highlight-style-delta bow-color #:translate-color? #f)]) 396 (λ () 397 (if (pref:invert-colors?) 398 wob-version 399 bow-version)))) 400 401 (define get-secondary-highlight-d 402 (mk-2-constant-style "yellow" "darkgoldenrod")) 403 404 #| 405 (define undo-select-d 406 (make-object style-delta% 'change-weight 'normal)) 407 (define get-undo-highlight-d 408 (mk-2-constant-style "white" "black")) 409 |# 410 411 (define (get-undo-select/highlight-d) 412 (let ([sd (make-object style-delta% 'change-weight 'normal)] 413 [bg (if (pref:invert-colors?) "black" "white")]) 414 (send sd set-delta-background bg) 415 sd))