syntax-browser.rkt
1 #lang racket/base 2 (module+ test (require rackunit)) 3 4 #| 5 6 needed to really make this work: 7 8 - marshallable syntax objects (compile and write out the compiled form) 9 10 |# 11 12 (require racket/pretty 13 racket/class 14 racket/gui/base 15 racket/match 16 racket/contract 17 (only-in racket/base [read :read]) 18 "expandable-snip.rkt") 19 20 (define orig-output-port (current-output-port)) 21 (define (oprintf . args) (apply fprintf orig-output-port args)) 22 23 (provide 24 (contract-out 25 [render-syntax/snip 26 (-> syntax? (is-a?/c snip%))] 27 [render-syntax/window 28 (-> syntax? void?)]) 29 render-syntax-subtitle-color-style-name 30 render-syntax-focused-syntax-color-style-name 31 snip-class) 32 33 ;; this is doing the same thing as the class in 34 ;; the framework by the same name, but we don't 35 ;; use the framework here because it would 36 ;; introduce a cyclic dependency 37 (define text:hide-caret/selection% 38 (class text% 39 (inherit get-start-position get-end-position hide-caret) 40 (define/augment (after-set-position) 41 (hide-caret (= (get-start-position) (get-end-position)))) 42 (super-new))) 43 44 (define (render-syntax/window syntax) 45 (define es (render-syntax/snip syntax)) 46 (define f (new frame% [label "frame"] [width 850] [height 500])) 47 (define mb (new menu-bar% [parent f])) 48 (define edit-menu (new menu% [label "Edit"] [parent mb])) 49 (define t (new text%)) 50 (define ec (new editor-canvas% [parent f] [editor t])) 51 (append-editor-operation-menu-items edit-menu) 52 (send t insert es) 53 (send f show #t)) 54 55 (define (render-syntax/snip stx) (make-object syntax-snip% stx)) 56 57 (define syntax-snipclass% 58 (class snip-class% 59 (define/override (read stream) 60 (make-object syntax-snip% 61 (unmarshall-syntax (:read (open-input-bytes (send stream get-bytes)))))) 62 (super-new))) 63 64 (define snip-class (new syntax-snipclass%)) 65 (send snip-class set-version 1) 66 (send snip-class set-classname (format "~s" '(lib "syntax-browser.ss" "mrlib"))) 67 (send (get-the-snip-class-list) add snip-class) 68 69 (define-struct range (stx start end)) 70 71 (define Syntax\ Info "Syntax Info") 72 73 (define syntax-snip% 74 (class expandable-snip% 75 (init-field main-stx) 76 77 (unless (syntax? main-stx) 78 (error 'syntax-snip% "got non-syntax object")) 79 80 (define/public (get-syntax) main-stx) 81 82 (define/override (copy) (make-object syntax-snip% main-stx)) 83 (define/override (write stream) 84 (send stream put (string->bytes/utf-8 (format "~s" (marshall-syntax main-stx))))) 85 86 (define output-text (new text:hide-caret/selection%)) 87 (define output-text-filled-in? #f) 88 (define info-text (new text:hide-caret/selection%)) 89 (define info-port (make-text-port info-text)) 90 91 (define/private (show-info stx) 92 (insert-subtitle (string-append Syntax\ Info "\n")) 93 (piece-of-info "Source" (syntax-source stx)) 94 (piece-of-info "Source module" (syntax-source-module stx)) 95 (piece-of-info "Position" (syntax-position stx)) 96 (piece-of-info "Line" (syntax-line stx)) 97 (piece-of-info "Column" (syntax-column stx)) 98 (piece-of-info "Span" (syntax-span stx)) 99 (piece-of-info "Original?" (syntax-original? stx)) 100 (when (identifier? stx) 101 (piece-of-info "Identifier-binding" (identifier-binding stx)) 102 (piece-of-info "Identifier-transformer-binding" (identifier-transformer-binding stx)) 103 (piece-of-info "Identifier-template-binding" (identifier-template-binding stx))) 104 105 (let ([properties (syntax-property-symbol-keys stx)]) 106 (unless (null? properties) 107 (insert-subtitle "Known properties\n") 108 (for-each 109 (λ (prop) (show-property stx prop)) 110 properties)))) 111 112 (define/private (render-mpi mpi) 113 (string-append 114 "#<module-path-index " 115 (let loop ([mpi mpi]) 116 (cond 117 [(module-path-index? mpi) 118 (let-values ([(x y) (module-path-index-split mpi)]) 119 (string-append 120 "(" 121 (format "~s" x) 122 " . " 123 (loop y) 124 ")"))] 125 [else (format "~s" mpi)])) 126 ">")) 127 128 (define/private (show-property stx prop) 129 (piece-of-info (format "'~a" prop) (syntax-property stx prop))) 130 131 (define/private (piece-of-info label info) 132 (let ([small-newline 133 (λ (port text) 134 (let ([before-newline (send text last-position)]) 135 (newline port) 136 (send info-text change-style 137 (make-object style-delta% 'change-size 4) 138 before-newline 139 (+ before-newline 1))))]) 140 141 (insert/bold label) 142 (newline info-port) 143 144 ;; should just be using generic `print' 145 ;; but won't work without built-in support for 146 ;; editors as output ports 147 (parameterize ([pretty-print-size-hook 148 (λ (val d/p port) 149 (if (is-a? val syntax-snip%) 150 (+ (string-length (format "~a" (send val get-syntax))) 2) 151 #f))] 152 [pretty-print-print-hook 153 (λ (val d/p port) 154 (send info-text insert (send val copy) 155 (send info-text last-position) 156 (send info-text last-position)))]) 157 (define start-position (send info-text last-position)) 158 (pretty-print (replace-syntaxes info) info-port) 159 (change-the-style info-text 160 plain-color-style-name 161 start-position 162 (send info-text last-position))) 163 164 (optional-newline) 165 (small-newline info-port info-text))) 166 167 (define/private (replace-syntaxes obj) 168 (let loop ([obj obj]) 169 (cond 170 [(pair? obj) (cons (loop (car obj)) (loop (cdr obj)))] 171 [(syntax? obj) (make-object syntax-snip% obj)] 172 [(hash? obj) 173 (for/hash ([(k v) (in-hash obj)]) 174 (values (loop k) (loop v)))] 175 [(vector? obj) 176 (for/vector ([v (in-vector obj)]) 177 (loop v))] 178 [else obj]))) 179 180 (define/private (insert/bold str) 181 (let ([pos (send info-text last-position)]) 182 (send info-text insert str 183 (send info-text last-position) 184 (send info-text last-position)) 185 (change-the-style info-text 186 plain-color-style-name 187 pos 188 (send info-text last-position)) 189 (send info-text change-style 190 (make-object style-delta% 'change-bold) 191 pos 192 (send info-text last-position)))) 193 194 (define/private (insert-subtitle str) 195 (define pos (send info-text last-position)) 196 (send info-text insert str pos pos) 197 (change-the-style info-text 198 subtitle-style-name 199 pos 200 (send info-text last-position))) 201 202 (define/private (optional-newline) 203 (unless (equal? 204 (send info-text get-character (- (send info-text last-position) 1)) 205 #\newline) 206 (send info-text insert "\n" (send info-text last-position)))) 207 208 (define/private (show-range stx start end) 209 (send output-text begin-edit-sequence) 210 (send output-text lock #f) 211 (change-the-style output-text plain-color-style-name 0 (send output-text last-position)) 212 (change-the-style output-text render-syntax-focused-syntax-style-name start end) 213 (send output-text lock #t) 214 (send output-text end-edit-sequence) 215 216 (send info-text begin-edit-sequence) 217 (send info-text lock #f) 218 (send info-text erase) 219 (show-info stx) 220 (send info-text lock #t) 221 (send info-text end-edit-sequence)) 222 223 ;; ---- 224 225 (inherit show-border set-tight-text-fit) 226 227 (define/override (update-style-list sl) 228 (super update-style-list sl) 229 (send summary-t set-style-list sl) 230 (send inner-t set-style-list sl) 231 (send info-text set-style-list sl) 232 (send info-header-t set-style-list sl) 233 (send info-snip update-style-list sl) 234 (send output-text set-style-list sl)) 235 236 (define summary-t (new text:hide-caret/selection%)) 237 (define inner-t (new text:hide-caret/selection%)) 238 (define info-header-t (new text:hide-caret/selection%)) 239 240 (super-new 241 (with-border? #f) 242 (closed-editor summary-t) 243 (open-editor inner-t) 244 (left-margin 3) 245 (top-margin 0) 246 (right-margin 0) 247 (bottom-margin 0) 248 (left-inset 1) 249 (top-inset 0) 250 (right-inset 0) 251 (bottom-inset 0) 252 (callback 253 (lambda (details-shown?) 254 (fill-in-output-text) 255 (show-border details-shown?) 256 (set-tight-text-fit (not details-shown?))))) 257 258 (send summary-t insert (format "~s" main-stx)) 259 (change-the-style summary-t plain-color-style-name 260 0 (send summary-t last-position)) 261 262 (send info-header-t insert Syntax\ Info) 263 (change-the-style info-header-t subtitle-style-name 264 0 (send info-header-t last-position)) 265 (send info-header-t lock #t) 266 (define info-snip (new expandable-snip% 267 (closed-editor info-header-t) 268 (open-editor info-text) 269 (layout 'replace) 270 (with-border? #t))) 271 272 (let ([es (new editor-snip% 273 (editor output-text) 274 (with-border? #f) 275 (left-margin 0) 276 (top-margin 0) 277 (right-margin 0) 278 (bottom-margin 0) 279 (left-inset 0) 280 (top-inset 0) 281 (right-inset 0) 282 (bottom-inset 0))]) 283 (send es use-style-background #t) 284 (send inner-t insert es)) 285 (send inner-t insert " ") 286 (send inner-t insert info-snip) 287 (change-the-style inner-t plain-color-style-name 288 (- (send inner-t last-position) 1) 289 (send inner-t last-position)) 290 (send inner-t change-style (make-object style-delta% 'change-alignment 'top) 291 0 (send inner-t last-position)) 292 293 (send output-text lock #t) 294 (send info-text lock #t) 295 (send inner-t lock #t) 296 (send summary-t lock #t) 297 298 (define/private (fill-in-output-text) 299 (unless output-text-filled-in? 300 (set! output-text-filled-in? #t) 301 (send output-text begin-edit-sequence) 302 (send output-text lock #f) 303 (define-values (range-start-ht range-ht) 304 (populate-range-ht main-stx output-text)) 305 (define ranges 306 (sort 307 (apply append 308 (hash-map 309 range-ht 310 (λ (k vs) 311 (map (λ (v) (make-range k (car v) (cdr v))) 312 vs)))) 313 (λ (x y) 314 (>= (- (range-end x) (range-start x)) 315 (- (range-end y) (range-start y)))))) 316 (for ([range (in-list ranges)]) 317 (define stx (range-stx range)) 318 (define start (range-start range)) 319 (define end (range-end range)) 320 (when (syntax? stx) 321 (send output-text set-clickback start end 322 (λ (_1 _2 _3) 323 (show-range stx start end))))) 324 (send info-text auto-wrap #t) 325 (send info-text set-styles-sticky #f) 326 (unless (null? ranges) 327 (let ([rng (car ranges)]) 328 (show-range (range-stx rng) (range-start rng) (range-end rng)))) 329 (send output-text end-edit-sequence) 330 (send output-text lock #t))) 331 332 (inherit set-snipclass use-style-background) 333 (set-snipclass snip-class) 334 (use-style-background #t))) 335 336 ;; ------------------------------------------------------------ 337 338 ;; record-paths : val -> hash-table[path -o> syntax-object] 339 (define (syntax-object->datum/record-paths val) 340 (define path '()) 341 (define next-push 0) 342 (define (push!) 343 (set! path (cons next-push path)) 344 (set! next-push 0)) 345 (define (pop!) 346 (set! next-push (+ (car path) 1)) 347 (set! path (cdr path))) 348 (let* ([ht (make-hash)] 349 [record 350 (λ (val enclosing-stx) 351 (hash-set! ht path enclosing-stx))]) 352 (values 353 (let loop ([val val] 354 [enclosing-stx #f]) 355 (cond 356 [(syntax? val) 357 (loop (syntax-e val) 358 val)] 359 [(pair? val) 360 (push!) 361 (record val enclosing-stx) 362 (begin0 363 (let lst-loop ([val val]) 364 (cond 365 [(pair? val) 366 (cons (loop (car val) #f) 367 (lst-loop (cdr val)))] 368 [(null? val) '()] 369 [(and (syntax? val) (pair? (syntax-e val))) 370 (define pr (syntax-e val)) 371 (lst-loop pr)] 372 [else 373 (loop val enclosing-stx)])) 374 (pop!))] 375 [(vector? val) 376 (push!) 377 (record val enclosing-stx) 378 (begin0 379 (apply 380 vector 381 (let lst-loop ([val (vector->list val)]) 382 (cond 383 [(pair? val) 384 (cons (loop (car val) #f) 385 (lst-loop (cdr val)))] 386 [(null? val) '()]))) 387 (pop!))] 388 [(hash? val) 389 (push!) 390 (record val enclosing-stx) 391 (begin0 392 (for/hash ([(k v) (in-hash val)]) 393 (values (loop k #f) 394 (loop v #f))) 395 (pop!))] 396 [else 397 (push!) 398 (record val enclosing-stx) 399 (pop!) 400 val])) 401 ht))) 402 403 ;; populate-range-ht : Datum text% 404 ;; -> (values Hash[Datum -> Nat] Hash[Datum -> (listof (cons Nat Nat))]) 405 (define (populate-range-ht main-stx output-text) 406 (define-values (datum paths-ht) (syntax-object->datum/record-paths main-stx)) 407 408 ;; range-start-ht : hash-table[obj -o> number] 409 (define range-start-ht (make-hasheq)) 410 411 ;; range-ht : hash-table[obj -o> (listof (cons number number))] 412 (define range-ht (make-hasheq)) 413 414 (define path '()) 415 (define next-push 0) 416 (define (push!) 417 (set! path (cons next-push path)) 418 (set! next-push 0)) 419 (define (pop!) 420 (set! next-push (+ (car path) 1)) 421 (set! path (cdr path))) 422 423 (let* ([range-pretty-print-pre-hook 424 (λ (x port) 425 (push!) 426 (let ([stx-object (hash-ref paths-ht path (λ () #f))]) 427 (hash-set! range-start-ht stx-object (send output-text last-position))))] 428 [range-pretty-print-post-hook 429 (λ (x port) 430 (let ([stx-object (hash-ref paths-ht path (λ () #f))]) 431 (when stx-object 432 (let ([range-start (hash-ref range-start-ht stx-object (λ () #f))]) 433 (when range-start 434 (hash-set! range-ht 435 stx-object 436 (cons 437 (cons 438 range-start 439 (send output-text last-position)) 440 (hash-ref range-ht stx-object (λ () null)))))))) 441 (pop!))]) 442 443 ;; reset `path' and `next-push' for use in pp hooks. 444 (set! path '()) 445 (set! next-push 0) 446 (parameterize ([current-output-port (make-text-port output-text)] 447 [pretty-print-pre-print-hook range-pretty-print-pre-hook] 448 [pretty-print-post-print-hook range-pretty-print-post-hook] 449 [pretty-print-columns 30]) 450 (pretty-write datum))) 451 452 (values range-start-ht range-ht)) 453 454 (module+ test 455 (let ([x (datum->syntax #f 'x #f #f)] 456 [y (datum->syntax #f 'y #f #f)]) 457 (check-equal? (call-with-values 458 (λ () 459 (syntax-object->datum/record-paths (list x y))) 460 list) 461 (list '(x y) 462 (make-hash `(((0) . #f) ((1 0) . ,y) ((0 0) . ,x)))))) 463 464 (let* ([x (datum->syntax #f 'x #f #f)] 465 [y (datum->syntax #f 'y #f #f)] 466 [ly (datum->syntax #f (list y) #f #f)]) 467 (check-equal? (call-with-values 468 (λ () 469 (syntax-object->datum/record-paths (cons x ly))) 470 list) 471 (list '(x y) 472 (make-hash `(((0) . #f) ((1 0) . ,y) ((0 0) . ,x))))))) 473 474 ;; make-text-port : text -> port 475 ;; builds a port from a text object. 476 (define (make-text-port text) 477 (make-output-port #f 478 always-evt 479 (λ (s start end flush? breaks?) 480 (send text insert (bytes->string/utf-8 (subbytes s start end)) 481 (send text last-position) 482 (send text last-position)) 483 (- end start)) 484 void)) 485 486 ;; marshall-syntax : syntax -> printable 487 (define (marshall-syntax stx) 488 (unless (syntax? stx) 489 (error 'marshall-syntax "not syntax: ~s\n" stx)) 490 `(syntax 491 (source ,(marshall-object (syntax-source stx))) 492 (source-module ,(marshall-object (syntax-source-module stx))) 493 (position ,(syntax-position stx)) 494 (line ,(syntax-line stx)) 495 (column ,(syntax-column stx)) 496 (span ,(syntax-span stx)) 497 (original? ,(syntax-original? stx)) 498 (properties 499 ,@(map (λ (x) `(,x ,(marshall-object (syntax-property stx x)))) 500 (syntax-property-symbol-keys stx))) 501 (contents 502 ,(marshall-object (syntax-e stx))))) 503 504 ;; marshall-object : any -> printable 505 ;; really only intended for use with marshall-syntax 506 (define (marshall-object obj) 507 (cond 508 [(syntax? obj) (marshall-syntax obj)] 509 [(pair? obj) 510 `(pair ,(cons (marshall-object (car obj)) 511 (marshall-object (cdr obj))))] 512 [(or (symbol? obj) 513 (char? obj) 514 (number? obj) 515 (string? obj) 516 (boolean? obj) 517 (null? obj)) 518 `(other ,obj)] 519 [else (string->symbol (format "unknown-object: ~s" obj))])) 520 521 (define (unmarshall-syntax stx) 522 (match stx 523 [`(syntax 524 (source ,src) 525 (source-module ,source-module) ;; marshalling 526 (position ,pos) 527 (line ,line) 528 (column ,col) 529 (span ,span) 530 (original? ,original?) 531 (properties ,properties ...) 532 (contents ,contents)) 533 (foldl 534 add-properties 535 (datum->syntax 536 #'here ;; ack 537 (unmarshall-object contents) 538 (list (unmarshall-object src) 539 line 540 col 541 pos 542 span)) 543 properties)] 544 [else #'unknown-syntax-object])) 545 546 ;; add-properties : syntax any -> syntax 547 (define (add-properties prop-spec stx) 548 (match prop-spec 549 [`(,(and sym (? symbol?)) 550 ,prop) 551 (syntax-property stx sym (unmarshall-object prop))] 552 [else stx])) 553 554 (define (unmarshall-object obj) 555 (let ([unknown (λ () (string->symbol (format "unknown: ~s" obj)))]) 556 (if (and (pair? obj) 557 (symbol? (car obj))) 558 (case (car obj) 559 [(pair) 560 (if (pair? (cdr obj)) 561 (let ([raw-obj (cadr obj)]) 562 (if (pair? raw-obj) 563 (cons (unmarshall-object (car raw-obj)) 564 (unmarshall-object (cdr raw-obj))) 565 (unknown))) 566 (unknown))] 567 [(other) 568 (if (pair? (cdr obj)) 569 (cadr obj) 570 (unknown))] 571 [(syntax) (unmarshall-syntax obj)] 572 [else (unknown)]) 573 (unknown)))) 574 575 (define (change-the-style text style-name start end) 576 (define st (find/create-style style-name (send text get-style-list))) 577 (send text change-style st start end)) 578 579 (define plain-color-style-name "framework:default-color") 580 (define render-syntax-subtitle-color-style-name "mrlib/syntax-browser:subtitle-color") 581 (define render-syntax-focused-syntax-color-style-name "mrlib/syntax-browser:focused-syntax-color") 582 583 ;; these names are not actually added to the style list 584 (define render-syntax-focused-syntax-style-name "mrlib/syntax-browser:focused-syntax") 585 (define subtitle-style-name "mrlib/syntax-browser:subtitle") 586 587 (define (find/create-style style-name sl) 588 (cond 589 [(equal? style-name subtitle-style-name) 590 (create-combined-style sl 591 "Standard" 592 render-syntax-subtitle-color-style-name 593 (make-object style-delta% 'change-bold))] 594 [(equal? style-name render-syntax-focused-syntax-style-name) 595 (create-combined-style sl 596 "Standard" 597 render-syntax-focused-syntax-color-style-name)] 598 599 [(send sl find-named-style style-name) => values] 600 601 [(equal? style-name plain-color-style-name) 602 (create-colored-named-style sl style-name "black")] 603 [(equal? style-name render-syntax-subtitle-color-style-name) 604 (create-colored-named-style sl style-name "navy")] 605 [(equal? style-name render-syntax-focused-syntax-color-style-name) 606 (create-colored-named-style sl style-name "forestgreen")] 607 608 [else (error 'syntax-browser.rkt:find/create-style "unknown style name ~s" style-name)])) 609 610 (define (create-colored-named-style sl style-name color) 611 (define st (send sl new-named-style style-name (send sl basic-style))) 612 (define sd (send (make-object style-delta%) set-delta-foreground color)) 613 (send st set-delta sd) 614 st) 615 616 (define (create-combined-style sl style-name1 style-name2 [extra-sd #f]) 617 (define st1 (find/create-style style-name1 sl)) 618 (define st2 (find/create-style style-name2 sl)) 619 (define join-st (send sl find-or-create-join-style st1 st2)) 620 (cond 621 [extra-sd 622 (send sl find-or-create-style join-st extra-sd)] 623 [else join-st]))