racket.rkt (69584B)
1 #lang racket/base 2 (require scribble/core 3 scribble/basic 4 scribble/search 5 scribble/private/manual-sprop 6 scribble/private/on-demand 7 scribble/html-properties 8 file/convertible 9 racket/extflonum 10 (for-syntax racket/base)) 11 12 (provide define-code 13 to-element 14 to-element/no-color 15 to-paragraph 16 to-paragraph/prefix 17 syntax-ize 18 syntax-ize-hook 19 current-keyword-list 20 current-variable-list 21 current-meta-list 22 23 input-color 24 output-color 25 input-background-color 26 no-color 27 reader-color 28 result-color 29 keyword-color 30 comment-color 31 paren-color 32 meta-color 33 value-color 34 symbol-color 35 variable-color 36 opt-color 37 error-color 38 syntax-link-color 39 value-link-color 40 syntax-def-color 41 value-def-color 42 module-color 43 module-link-color 44 block-color 45 highlighted-color 46 47 (struct-out var-id) 48 (struct-out shaped-parens) 49 (struct-out long-boolean) 50 (struct-out just-context) 51 (struct-out alternate-display) 52 (struct-out literal-syntax) 53 (for-syntax make-variable-id 54 variable-id? 55 make-element-id-transformer 56 element-id-transformer?)) 57 58 (define (make-racket-style s 59 #:tt? [tt? #t] 60 #:extras [extras null]) 61 (make-style s (if tt? 62 (cons 'tt-chars 63 (append extras 64 scheme-properties)) 65 (append extras 66 scheme-properties)))) 67 68 (define-on-demand output-color (make-racket-style "RktOut")) 69 (define-on-demand input-color (make-racket-style "RktIn")) 70 (define-on-demand input-background-color (make-racket-style "RktInBG")) 71 (define-on-demand no-color (make-racket-style "RktPlain")) 72 (define-on-demand reader-color (make-racket-style "RktRdr")) 73 (define-on-demand result-color (make-racket-style "RktRes")) 74 (define-on-demand keyword-color (make-racket-style "RktKw")) 75 (define-on-demand comment-color (make-racket-style "RktCmt")) 76 (define-on-demand paren-color (make-racket-style "RktPn")) 77 (define-on-demand meta-color (make-racket-style "RktMeta")) 78 (define-on-demand value-color (make-racket-style "RktVal")) 79 (define-on-demand symbol-color (make-racket-style "RktSym")) 80 (define-on-demand symbol-def-color (make-racket-style "RktSymDef" 81 #:extras (list (attributes '((class . "RktSym")))))) 82 (define-on-demand variable-color (make-racket-style "RktVar")) 83 (define-on-demand opt-color (make-racket-style "RktOpt")) 84 (define-on-demand error-color (make-racket-style "RktErr" #:tt? #f)) 85 (define-on-demand syntax-link-color (make-racket-style "RktStxLink")) 86 (define-on-demand value-link-color (make-racket-style "RktValLink")) 87 (define-on-demand syntax-def-color (make-racket-style "RktStxDef" 88 #:extras (list (attributes '((class . "RktStxLink")))))) 89 (define-on-demand value-def-color (make-racket-style "RktValDef" 90 #:extras (list (attributes '((class . "RktValLink")))))) 91 (define-on-demand module-color (make-racket-style "RktMod")) 92 (define-on-demand module-link-color (make-racket-style "RktModLink")) 93 (define-on-demand block-color (make-racket-style "RktBlk")) 94 (define-on-demand highlighted-color (make-racket-style "highlighted" #:tt? #f)) 95 96 (define current-keyword-list 97 (make-parameter null)) 98 (define current-variable-list 99 (make-parameter null)) 100 (define current-meta-list 101 (make-parameter null)) 102 103 (define defined-names (make-hasheq)) 104 105 (define-struct (sized-element element) (length)) 106 107 (define-struct (spaces element) (cnt)) 108 109 ;; We really don't want leading hypens (or minus signs) to 110 ;; create a line break after the hyphen. For interior hyphens, 111 ;; line breaking is usually fine. 112 (define (nonbreak-leading-hyphens s) 113 (let ([m (regexp-match-positions #rx"^-+" s)]) 114 (if m 115 (if (= (cdar m) (string-length s)) 116 (make-element 'no-break s) 117 (let ([len (add1 (cdar m))]) 118 (make-element #f (list (make-element 'no-break (substring s 0 len)) 119 (substring s len))))) 120 s))) 121 122 (define (literalize-spaces i [leading? #f]) 123 (let ([m (regexp-match-positions #rx" +" i)]) 124 (if m 125 (let ([cnt (- (cdar m) (caar m))]) 126 (make-spaces #f 127 (list 128 (literalize-spaces (substring i 0 (caar m)) #t) 129 (hspace cnt) 130 (literalize-spaces (substring i (cdar m)))) 131 cnt)) 132 (if leading? 133 (nonbreak-leading-hyphens i) 134 i)))) 135 136 137 (define line-breakable-space (make-element 'tt " ")) 138 139 ;; These caches intentionally record a key with the value. 140 ;; That way, when the value is no longer used, the key 141 ;; goes away, and the entry is gone. 142 143 (define id-element-cache (make-weak-hash)) 144 (define element-cache (make-weak-hash)) 145 146 (define-struct (cached-delayed-element delayed-element) (cache-key)) 147 (define-struct (cached-element element) (cache-key)) 148 149 (define qq-ellipses (string->uninterned-symbol "...")) 150 151 (define (make-id-element c s defn?) 152 (let* ([key (and id-element-cache 153 (let ([b (identifier-label-binding c)]) 154 (vector (syntax-e c) 155 (module-path-index->taglet (caddr b)) 156 (cadddr b) 157 (list-ref b 5) 158 (syntax-property c 'display-string) 159 defn?)))]) 160 (or (and key 161 (let ([b (hash-ref id-element-cache key #f)]) 162 (and b 163 (weak-box-value b)))) 164 (let ([e (make-cached-delayed-element 165 (lambda (renderer sec ri) 166 (let* ([tag (find-racket-tag sec ri c #f)]) 167 (if tag 168 (let ([tag (intern-taglet tag)]) 169 (list 170 (case (car tag) 171 [(form) 172 (make-link-element (if defn? 173 syntax-def-color 174 syntax-link-color) 175 (nonbreak-leading-hyphens s) 176 tag)] 177 [else 178 (make-link-element (if defn? 179 value-def-color 180 value-link-color) 181 (nonbreak-leading-hyphens s) 182 tag)]))) 183 (list 184 (make-element "badlink" 185 (make-element value-link-color s)))))) 186 (lambda () s) 187 (lambda () s) 188 (intern-taglet key))]) 189 (when key 190 (hash-set! id-element-cache key (make-weak-box e))) 191 e)))) 192 193 (define (make-element/cache style content) 194 (if (and element-cache 195 (string? content)) 196 (let ([key (vector style content)]) 197 (let ([b (hash-ref element-cache key #f)]) 198 (or (and b (weak-box-value b)) 199 (let ([e (make-cached-element style content key)]) 200 (hash-set! element-cache key (make-weak-box e)) 201 e)))) 202 (make-element style content))) 203 204 (define (to-quoted obj expr? quote-depth out color? inc!) 205 (if (and expr? 206 (zero? quote-depth) 207 (quotable? obj)) 208 (begin 209 (out "'" (and color? value-color)) 210 (inc!) 211 (add1 quote-depth)) 212 quote-depth)) 213 214 (define (to-unquoted expr? quote-depth out color? inc!) 215 (if (or (not expr?) (zero? quote-depth)) 216 quote-depth 217 (begin 218 (out "," (and color? meta-color)) 219 (inc!) 220 (to-unquoted expr? (sub1 quote-depth) out color? inc!)))) 221 222 (define iformat 223 (case-lambda 224 [(str val) (datum-intern-literal (format str val))] 225 [(str . vals) (datum-intern-literal (apply format str vals))])) 226 227 (define (typeset-atom c out color? quote-depth expr? escapes? defn?) 228 (if (and (var-id? (syntax-e c)) 229 (zero? quote-depth)) 230 (out (iformat "~s" (let ([v (var-id-sym (syntax-e c))]) 231 (if (syntax? v) 232 (syntax-e v) 233 v))) 234 variable-color) 235 (let*-values ([(is-var?) (and (identifier? c) 236 (memq (syntax-e c) (current-variable-list)))] 237 [(s it? sub?) 238 (let ([sc (syntax-e c)]) 239 (let ([s (cond 240 [(syntax-property c 'display-string) => values] 241 [(literal-syntax? sc) (iformat "~s" (literal-syntax-stx sc))] 242 [(var-id? sc) (iformat "~s" (var-id-sym sc))] 243 [(eq? sc #t) 244 (if (equal? (syntax-span c) 5) 245 "#true" 246 "#t")] 247 [(eq? sc #f) 248 (if (equal? (syntax-span c) 6) 249 "#false" 250 "#f")] 251 [(and (number? sc) 252 (inexact? sc)) 253 (define s (iformat "~s" sc)) 254 (if (= (string-length s) 255 (- (syntax-span c) 2)) 256 ;; There's no way to know whether the source used #i, 257 ;; but it should be ok to include it: 258 (string-append "#i" s) 259 s)] 260 [else (iformat "~s" sc)])]) 261 (if (and escapes? 262 (symbol? sc) 263 ((string-length s) . > . 1) 264 (char=? (string-ref s 0) #\_) 265 (not (or (identifier-label-binding c) 266 is-var?))) 267 (values (substring s 1) #t #f) 268 (values s #f #f))))]) 269 (let ([quote-depth (if (and expr? (identifier? c) (not (eq? qq-ellipses (syntax-e c)))) 270 (let ([quote-depth 271 (if (and (quote-depth . < . 2) 272 (memq (syntax-e c) '(unquote unquote-splicing))) 273 (to-unquoted expr? quote-depth out color? void) 274 quote-depth)]) 275 (to-quoted c expr? quote-depth out color? void)) 276 quote-depth)]) 277 (if (or (element? (syntax-e c)) 278 (delayed-element? (syntax-e c)) 279 (part-relative-element? (syntax-e c)) 280 (convertible? (syntax-e c))) 281 (out (syntax-e c) #f) 282 (out (if (and (identifier? c) 283 color? 284 (quote-depth . <= . 0) 285 (not (or it? is-var?))) 286 (if (pair? (identifier-label-binding c)) 287 (make-id-element c s defn?) 288 (let ([c (nonbreak-leading-hyphens s)]) 289 (if defn? 290 (make-element symbol-def-color c) 291 c))) 292 (literalize-spaces s #t)) 293 (cond 294 [(positive? quote-depth) value-color] 295 [(let ([v (syntax-e c)]) 296 (or (number? v) 297 (string? v) 298 (bytes? v) 299 (char? v) 300 (regexp? v) 301 (byte-regexp? v) 302 (boolean? v) 303 (extflonum? v))) 304 value-color] 305 [(identifier? c) 306 (cond 307 [is-var? 308 variable-color] 309 [(and (identifier? c) 310 (memq (syntax-e c) (current-keyword-list))) 311 keyword-color] 312 [(and (identifier? c) 313 (memq (syntax-e c) (current-meta-list))) 314 meta-color] 315 [it? variable-color] 316 [else symbol-color])] 317 [else paren-color]) 318 (string-length s))))))) 319 320 (define omitable (make-style #f '(omitable))) 321 322 (define (gen-typeset c multi-line? prefix1 prefix suffix color? expr? escapes? defn? elem-wrap) 323 (let* ([c (syntax-ize c 0 #:expr? expr?)] 324 [content null] 325 [docs null] 326 [first (if escapes? 327 (syntax-case c (code:line) 328 [(code:line e . rest) #'e] 329 [(code:line . rest) #'rest] 330 [else c]) 331 c)] 332 [init-col (or (syntax-column first) 0)] 333 [src-col init-col] 334 [inc-src-col (lambda () (set! src-col (add1 src-col)))] 335 [dest-col 0] 336 [highlight? #f] 337 [col-map (make-hash)] 338 [next-col-map (make-hash)] 339 [line (or (syntax-line first) 0)]) 340 (define (finish-line!) 341 (when multi-line? 342 (set! docs (cons (make-paragraph omitable 343 (if (null? content) 344 (list (hspace 1)) 345 (reverse content))) 346 docs)) 347 (set! content null))) 348 (define out 349 (case-lambda 350 [(v cls) 351 (out v cls (let sz-loop ([v v]) 352 (cond 353 [(string? v) (string-length v)] 354 [(list? v) (for/fold ([s 0]) ([v (in-list v)]) (+ s (sz-loop v)))] 355 [(sized-element? v) (sized-element-length v)] 356 [(element? v) 357 (sz-loop (element-content v))] 358 [(delayed-element? v) 359 (content-width v)] 360 [(part-relative-element? v) 361 (content-width v)] 362 [(spaces? v) 363 (+ (sz-loop (car (element-content v))) 364 (spaces-cnt v) 365 (sz-loop (caddr (element-content v))))] 366 [else 1])))] 367 [(v cls len) 368 (unless (equal? v "") 369 (cond 370 [(spaces? v) 371 (out (car (element-content v)) cls 0) 372 (out (cadr (element-content v)) #f 0) 373 (out (caddr (element-content v)) cls len)] 374 [(equal? v "\n") 375 (if multi-line? 376 (begin 377 (finish-line!) 378 (out prefix cls)) 379 (out " " cls))] 380 [else 381 (set! content (cons (elem-wrap 382 ((if highlight? 383 (lambda (c) 384 (make-element highlight? c)) 385 values) 386 (if (and color? cls) 387 (make-element/cache cls v) 388 v))) 389 content)) 390 (set! dest-col (+ dest-col len))]))])) 391 (define advance 392 (case-lambda 393 [(c init-line! srcless-step delta) 394 (let ([c (+ delta (or (syntax-column c) 395 (if srcless-step 396 (+ src-col srcless-step) 397 0)))] 398 [l (syntax-line c)]) 399 (let ([new-line? (and l (l . > . line))]) 400 (when new-line? 401 (for ([i (in-range (- l line))]) 402 (out "\n" #f)) 403 (set! line l) 404 (set! col-map next-col-map) 405 (set! next-col-map (make-hash)) 406 (init-line!)) 407 (let ([d-col (let ([def-val (+ dest-col (- c src-col))]) 408 (if new-line? 409 (hash-ref col-map c def-val) 410 def-val))]) 411 (let ([amt (- d-col dest-col)]) 412 (when (positive? amt) 413 (let ([old-dest-col dest-col]) 414 (out (if (and (= 1 amt) (not multi-line?)) 415 line-breakable-space ; allows a line break to replace the space 416 (hspace amt)) 417 #f) 418 (set! dest-col (+ old-dest-col amt)))))) 419 (set! src-col c) 420 (hash-set! next-col-map src-col dest-col)))] 421 [(c init-line! srcless-step) (advance c init-line! srcless-step 0)] 422 [(c init-line!) (advance c init-line! #f 0)])) 423 (define (for-each/i f l v) 424 (unless (null? l) 425 (f (car l) v) 426 (for-each/i f (cdr l) 1))) 427 (define (convert-infix c quote-depth expr?) 428 (let ([l (syntax->list c)]) 429 (and l 430 ((length l) . >= . 3) 431 ((or (syntax-position (car l)) -inf.0) 432 . > . 433 (or (syntax-position (cadr l)) +inf.0)) 434 (let ([a (car l)]) 435 (let loop ([l (cdr l)] 436 [prev null]) 437 (cond 438 [(null? l) #f] ; couldn't unwind 439 [else (let ([p2 (syntax-position (car l))]) 440 (if (and p2 441 (p2 . > . (syntax-position a))) 442 (datum->syntax c 443 (append 444 (reverse prev) 445 (list 446 (datum->syntax 447 a 448 (let ([val? (positive? quote-depth)]) 449 (make-sized-element 450 (if val? value-color #f) 451 (list 452 (make-element/cache (if val? value-color paren-color) '". ") 453 (typeset a #f "" "" "" (not val?) expr? escapes? defn? elem-wrap) 454 (make-element/cache (if val? value-color paren-color) '" .")) 455 (+ (syntax-span a) 4))) 456 (list (syntax-source a) 457 (syntax-line a) 458 (- (syntax-column a) 2) 459 (- (syntax-position a) 2) 460 (+ (syntax-span a) 4)) 461 a)) 462 l) 463 c 464 c) 465 (loop (cdr l) 466 (cons (car l) prev))))])))))) 467 (define (no-fancy-chars s) 468 (cond 469 [(eq? s 'rsquo) "'"] 470 [else s])) 471 (define (loop init-line! quote-depth expr? no-cons?) 472 (lambda (c srcless-step) 473 (define (lloop quote-depth l) 474 (let inner-lloop ([first-element? #t] 475 [l l] 476 [first-expr? (and expr? 477 (or (zero? quote-depth) 478 (not (struct-proxy? (syntax-e c)))) 479 (not no-cons?))] 480 [dotted? #f] 481 [srcless-step #f]) 482 (define (print-dot-separator l) 483 (unless (and expr? (zero? quote-depth)) 484 (advance l init-line! (and srcless-step (+ srcless-step 3)) -2) 485 (out ". " (if (positive? quote-depth) value-color paren-color)) 486 (set! src-col (+ src-col 3))) 487 (hash-set! next-col-map src-col dest-col)) 488 (cond 489 [(let ([el (if (syntax? l) (syntax-e l) l)]) 490 (and (pair? el) 491 (eq? (if (syntax? (car el)) 492 (syntax-e (car el)) 493 (car el)) 494 'code:hilite))) 495 (define l-stx 496 (if (syntax? l) 497 l 498 (datum->syntax #f l (list #f #f #f #f 0)))) 499 (print-dot-separator l-stx) 500 ((loop init-line! quote-depth first-expr? #f) l-stx (if (and expr? (zero? quote-depth)) 501 srcless-step 502 #f))] 503 [(and (syntax? l) 504 (pair? (syntax-e l)) 505 (not dotted?) 506 (not (and (memq (syntax-e (car (syntax-e l))) 507 '(quote unquote syntax unsyntax quasiquote quasiunsyntax)) 508 (let ([v (syntax->list l)]) 509 (and v (= 2 (length v)))) 510 (or (not expr?) 511 (quote-depth . > . 1) 512 (not (memq (syntax-e (car (syntax-e l))) 513 '(unquote unquote-splicing))))))) 514 (if first-element? 515 (inner-lloop #f (syntax-e l) first-expr? #f srcless-step) 516 (begin 517 (print-dot-separator l) 518 ((loop init-line! quote-depth first-expr? #f) l srcless-step)))] 519 [(and (or (null? l) 520 (and (syntax? l) 521 (null? (syntax-e l))))) 522 (void)] 523 [(and (pair? l) (not dotted?)) 524 ((loop init-line! quote-depth first-expr? #f) (car l) srcless-step) 525 (inner-lloop #f (cdr l) expr? #f 1)] 526 [(forced-pair? l) 527 ((loop init-line! quote-depth first-expr? #f) (forced-pair-car l) srcless-step) 528 (inner-lloop #f (forced-pair-cdr l) expr? #t 1)] 529 [(mpair? l) 530 ((loop init-line! quote-depth first-expr? #f) (mcar l) srcless-step) 531 (inner-lloop #f (mcdr l) expr? #t 1)] 532 [else 533 (print-dot-separator l) 534 ((loop init-line! quote-depth first-expr? #f) l (if (and expr? (zero? quote-depth)) 535 srcless-step 536 #f))]))) 537 (cond 538 [(and escapes? (eq? 'code:blank (syntax-e c))) 539 (advance c init-line! srcless-step)] 540 [(and escapes? 541 (pair? (syntax-e c)) 542 (eq? (syntax-e (car (syntax-e c))) 'code:comment)) 543 (let ([l (syntax->list c)]) 544 (unless (and l (= 2 (length l))) 545 (raise-syntax-error 546 #f 547 "does not have a single sub-form" 548 c))) 549 (advance c init-line! srcless-step) 550 (out ";" comment-color) 551 ;(out 'nbsp comment-color) 552 (let ([v (syntax->datum (cadr (syntax->list c)))]) 553 (if (paragraph? v) 554 (map (lambda (v) 555 (let ([v (no-fancy-chars v)]) 556 (if (or (string? v) (symbol? v)) 557 (out v comment-color) 558 (out v #f)))) 559 (paragraph-content v)) 560 (out (no-fancy-chars v) comment-color)))] 561 [(and escapes? 562 (pair? (syntax-e c)) 563 (eq? (syntax-e (car (syntax-e c))) 'code:contract)) 564 (advance c init-line! srcless-step) 565 (out "; " comment-color) 566 (let* ([l (cdr (syntax->list c))] 567 [s-col (or (syntax-column (car l)) src-col)]) 568 (set! src-col s-col) 569 (for-each/i (loop (lambda () 570 (set! src-col s-col) 571 (set! dest-col 0) 572 (out "; " comment-color)) 573 0 574 expr? 575 #f) 576 l 577 #f))] 578 [(and escapes? 579 (pair? (syntax-e c)) 580 (eq? (syntax-e (car (syntax-e c))) 'code:line)) 581 (lloop quote-depth 582 (cdr (syntax-e c)))] 583 [(and escapes? 584 (pair? (syntax-e c)) 585 (eq? (syntax-e (car (syntax-e c))) 'code:hilite)) 586 (let ([l (syntax->list c)] 587 [h? highlight?]) 588 (unless (and l (or (= 2 (length l)) (= 3 (length l)))) 589 (error "bad code:hilite: ~.s" (syntax->datum c))) 590 591 (advance c init-line! srcless-step) 592 (set! src-col (syntax-column (cadr l))) 593 (hash-set! next-col-map src-col dest-col) 594 595 (set! highlight? (if (= 3 (length l)) 596 (let ([the-style (syntax-e (caddr l))]) 597 (if (syntax? the-style) 598 (syntax->datum the-style) 599 the-style)) 600 highlighted-color)) 601 ((loop init-line! quote-depth expr? #f) (cadr l) #f) 602 (set! highlight? h?) 603 (unless (= (syntax-span c) 0) 604 (set! src-col (add1 src-col))))] 605 [(and escapes? 606 (pair? (syntax-e c)) 607 (eq? (syntax-e (car (syntax-e c))) 'code:quote)) 608 (advance c init-line! srcless-step) 609 (let ([quote-depth (to-quoted c expr? quote-depth out color? inc-src-col)]) 610 (out "(" (if (positive? quote-depth) value-color paren-color)) 611 (set! src-col (+ src-col 1)) 612 (hash-set! next-col-map src-col dest-col) 613 ((loop init-line! quote-depth expr? #f) 614 (datum->syntax #'here 'quote (car (syntax-e c))) 615 #f) 616 (for-each/i (loop init-line! (add1 quote-depth) expr? #f) 617 (cdr (syntax->list c)) 618 1) 619 (out ")" (if (positive? quote-depth) value-color paren-color)) 620 (set! src-col (+ src-col 1)) 621 #; 622 (hash-set! next-col-map src-col dest-col))] 623 [(and (pair? (syntax-e c)) 624 (memq (syntax-e (car (syntax-e c))) 625 '(quote quasiquote unquote unquote-splicing 626 quasisyntax syntax unsyntax unsyntax-splicing)) 627 (let ([v (syntax->list c)]) 628 (and v (= 2 (length v)))) 629 (or (not expr?) 630 (positive? quote-depth) 631 (quotable? c))) 632 (advance c init-line! srcless-step) 633 (let ([quote-depth (to-quoted c expr? quote-depth out color? inc-src-col)]) 634 (let-values ([(str quote-delta) 635 (case (syntax-e (car (syntax-e c))) 636 [(quote) (values "'" +inf.0)] 637 [(unquote) (values "," -1)] 638 [(unquote-splicing) (values ",@" -1)] 639 [(quasiquote) (values "`" +1)] 640 [(syntax) (values "#'" 0)] 641 [(quasisyntax) (values "#`" 0)] 642 [(unsyntax) (values "#," 0)] 643 [(unsyntax-splicing) (values "#,@" 0)])]) 644 (out str (if (positive? (+ quote-depth quote-delta)) 645 value-color 646 reader-color)) 647 (let ([i (cadr (syntax->list c))]) 648 (set! src-col (or (syntax-column i) src-col)) 649 (hash-set! next-col-map src-col dest-col) 650 ((loop init-line! (max 0 (+ quote-depth quote-delta)) expr? #f) i #f))))] 651 [(and (pair? (syntax-e c)) 652 (or (not expr?) 653 (positive? quote-depth) 654 (quotable? c)) 655 (convert-infix c quote-depth expr?)) 656 => (lambda (converted) 657 ((loop init-line! quote-depth expr? #f) converted srcless-step))] 658 [(or (pair? (syntax-e c)) 659 (mpair? (syntax-e c)) 660 (forced-pair? (syntax-e c)) 661 (null? (syntax-e c)) 662 (vector? (syntax-e c)) 663 (and (struct? (syntax-e c)) 664 (prefab-struct-key (syntax-e c))) 665 (struct-proxy? (syntax-e c))) 666 (let* ([sh (or (syntax-property c 'paren-shape) 667 (if (and (mpair? (syntax-e c)) 668 (not (and expr? (zero? quote-depth)))) 669 #\{ 670 #\())] 671 [quote-depth (if (and (not expr?) 672 (zero? quote-depth) 673 (or (vector? (syntax-e c)) 674 (struct? (syntax-e c)))) 675 1 676 quote-depth)] 677 [p-color (if (positive? quote-depth) 678 value-color 679 (if (eq? sh #\?) 680 opt-color 681 paren-color))]) 682 (advance c init-line! srcless-step) 683 (let ([quote-depth (if (struct-proxy? (syntax-e c)) 684 quote-depth 685 (to-quoted c expr? quote-depth out color? inc-src-col))]) 686 (when (and expr? (zero? quote-depth)) 687 (out "(" p-color) 688 (unless no-cons? 689 (out (let ([s (cond 690 [(pair? (syntax-e c)) 691 (if (syntax->list c) 692 "list" 693 (if (let ([d (cdr (syntax-e c))]) 694 (or (pair? d) 695 (and (syntax? d) 696 (pair? (syntax-e d))))) 697 "list*" 698 "cons"))] 699 [(vector? (syntax-e c)) "vector"] 700 [(mpair? (syntax-e c)) "mcons"] 701 [else (iformat "~a" 702 (if (struct-proxy? (syntax-e c)) 703 (syntax-e (struct-proxy-name (syntax-e c))) 704 (object-name (syntax-e c))))])]) 705 (set! src-col (+ src-col (if (struct-proxy? (syntax-e c)) 706 1 707 (string-length s)))) 708 s) 709 symbol-color) 710 (unless (and (struct-proxy? (syntax-e c)) 711 (null? (struct-proxy-content (syntax-e c)))) 712 (out " " #f)))) 713 (when (vector? (syntax-e c)) 714 (unless (and expr? (zero? quote-depth)) 715 (let ([vec (syntax-e c)]) 716 (out "#" p-color) 717 (if (zero? (vector-length vec)) 718 (set! src-col (+ src-col (- (syntax-span c) 2))) 719 (set! src-col (+ src-col (- (syntax-column (vector-ref vec 0)) 720 (syntax-column c) 721 1))))))) 722 (when (struct? (syntax-e c)) 723 (unless (and expr? (zero? quote-depth)) 724 (out "#s" p-color) 725 (set! src-col (+ src-col 2)))) 726 (unless (and expr? (zero? quote-depth)) 727 (out (case sh 728 [(#\[ #\?) "["] 729 [(#\{) "{"] 730 [else "("]) 731 p-color)) 732 (set! src-col (+ src-col 1)) 733 (hash-set! next-col-map src-col dest-col) 734 (lloop quote-depth 735 (cond 736 [(vector? (syntax-e c)) 737 (vector->short-list (syntax-e c) syntax-e)] 738 [(struct? (syntax-e c)) 739 (let ([l (vector->list (struct->vector (syntax-e c)))]) 740 ;; Need to build key datum, syntax-ize it internally, and 741 ;; set the overall width to fit right: 742 (if (and expr? (zero? quote-depth)) 743 (cdr l) 744 (cons (let ([key (syntax-ize (prefab-struct-key (syntax-e c)) 745 (+ 3 (or (syntax-column c) 0)) 746 (or (syntax-line c) 1))] 747 [end (if (pair? (cdr l)) 748 (and (equal? (syntax-line c) (syntax-line (cadr l))) 749 (syntax-column (cadr l))) 750 (and (syntax-column c) 751 (+ (syntax-column c) (syntax-span c))))]) 752 (if end 753 (datum->syntax #f 754 (syntax-e key) 755 (vector #f (syntax-line key) 756 (syntax-column key) 757 (syntax-position key) 758 (max 1 (- end 1 (syntax-column key))))) 759 end)) 760 (cdr l))))] 761 [(struct-proxy? (syntax-e c)) 762 (struct-proxy-content (syntax-e c))] 763 [(forced-pair? (syntax-e c)) 764 (syntax-e c)] 765 [(mpair? (syntax-e c)) 766 (syntax-e c)] 767 [else c])) 768 (out (case sh 769 [(#\[ #\?) "]"] 770 [(#\{) "}"] 771 [else ")"]) 772 p-color) 773 (set! src-col (+ src-col 1))))] 774 [(box? (syntax-e c)) 775 (advance c init-line! srcless-step) 776 (let ([quote-depth (to-quoted c expr? quote-depth out color? inc-src-col)]) 777 (if (and expr? (zero? quote-depth)) 778 (begin 779 (out "(" paren-color) 780 (out "box" symbol-color) 781 (out " " #f) 782 (set! src-col (+ src-col 5))) 783 (begin 784 (out "#&" value-color) 785 (set! src-col (+ src-col 2)))) 786 (hash-set! next-col-map src-col dest-col) 787 ((loop init-line! (if expr? quote-depth +inf.0) expr? #f) (unbox (syntax-e c)) #f) 788 (when (and expr? (zero? quote-depth)) 789 (out ")" paren-color)))] 790 [(hash? (syntax-e c)) 791 (advance c init-line! srcless-step) 792 (let ([equal-table? (hash-equal? (syntax-e c))] 793 [eqv-table? (hash-eqv? (syntax-e c))] 794 [quote-depth (to-quoted c expr? quote-depth out color? inc-src-col)]) 795 (unless (and expr? (zero? quote-depth)) 796 (out (if equal-table? 797 "#hash" 798 (if eqv-table? 799 "#hasheqv" 800 "#hasheq")) 801 value-color)) 802 (let ([delta (+ 5 (if equal-table? 0 (if eqv-table? 3 2)) 803 (if (and expr? (zero? quote-depth)) 1 0))] 804 [orig-col src-col]) 805 (set! src-col (+ src-col delta)) 806 (hash-set! next-col-map src-col dest-col) 807 ((loop init-line! (if expr? quote-depth +inf.0) expr? (and expr? (zero? quote-depth))) 808 (let*-values ([(l) (sort (hash-map (syntax-e c) cons) 809 (lambda (a b) 810 (< (or (syntax-position (cdr a)) -inf.0) 811 (or (syntax-position (cdr b)) -inf.0))))] 812 [(sep cap) (if (and expr? (zero? quote-depth)) 813 (values 1 0) 814 (values 3 1))] 815 [(col0) (+ (syntax-column c) delta cap 1)] 816 [(l2 pos line) (for/fold ([l2 null][col col0][line (syntax-line c)]) 817 ([p (in-list l)]) 818 (let* ([tentative (syntax-ize (car p) 0 819 #:expr? (and expr? (zero? quote-depth)))] 820 [width (syntax-span tentative)] 821 [col (if (= line (syntax-line (cdr p))) 822 col 823 col0)]) 824 (let ([key 825 (let ([e (syntax-ize (car p) 826 (max 0 (- (syntax-column (cdr p)) 827 width 828 sep)) 829 (syntax-line (cdr p)) 830 #:expr? (and expr? (zero? quote-depth)))]) 831 (if ((syntax-column e) . <= . col) 832 e 833 (datum->syntax #f 834 (syntax-e e) 835 (vector (syntax-source e) 836 (syntax-line e) 837 col 838 (syntax-position e) 839 (+ (syntax-span e) (- (syntax-column e) col))))))]) 840 (let ([elem 841 (datum->syntax 842 #f 843 (make-forced-pair key (cdr p)) 844 (vector 'here 845 (syntax-line (cdr p)) 846 (max 0 (- (syntax-column key) cap)) 847 (max 1 (- (syntax-position key) cap)) 848 (+ (syntax-span (cdr p)) (syntax-span key) sep cap cap)))]) 849 (values (cons elem l2) 850 (+ (syntax-column elem) (syntax-span elem) 2) 851 (syntax-line elem))))))]) 852 (if (and expr? (zero? quote-depth)) 853 ;; constructed: 854 (let ([l (apply append 855 (map (lambda (p) 856 (let ([p (syntax-e p)]) 857 (list (forced-pair-car p) 858 (forced-pair-cdr p)))) 859 (reverse l2)))]) 860 (datum->syntax 861 #f 862 (cons (let ([s (if equal-table? 863 'hash 864 (if eqv-table? 865 'hasheqv 866 'hasheq))]) 867 (datum->syntax #f 868 s 869 (vector (syntax-source c) 870 (syntax-line c) 871 (+ (syntax-column c) 1) 872 (+ (syntax-position c) 1) 873 (string-length (symbol->string s))))) 874 l) 875 c)) 876 ;; quoted: 877 (datum->syntax #f (reverse l2) (vector (syntax-source c) 878 (syntax-line c) 879 (+ (syntax-column c) delta) 880 (+ (syntax-position c) delta) 881 (max 1 (- (syntax-span c) delta)))))) 882 #f) 883 (set! src-col (+ orig-col (syntax-span c)))))] 884 [(graph-reference? (syntax-e c)) 885 (advance c init-line! srcless-step) 886 (out (iformat "#~a#" (unbox (graph-reference-bx (syntax-e c)))) 887 (if (positive? quote-depth) 888 value-color 889 paren-color)) 890 (set! src-col (+ src-col (syntax-span c)))] 891 [(graph-defn? (syntax-e c)) 892 (advance c init-line! srcless-step) 893 (let ([bx (graph-defn-bx (syntax-e c))]) 894 (out (iformat "#~a=" (unbox bx)) 895 (if (positive? quote-depth) 896 value-color 897 paren-color)) 898 (set! src-col (+ src-col 3)) 899 ((loop init-line! quote-depth expr? #f) (graph-defn-r (syntax-e c)) #f))] 900 [(and (keyword? (syntax-e c)) expr?) 901 (advance c init-line! srcless-step) 902 (let ([quote-depth (to-quoted c expr? quote-depth out color? inc-src-col)]) 903 (typeset-atom c out color? quote-depth expr? escapes? defn?) 904 (set! src-col (+ src-col (or (syntax-span c) 1))))] 905 [else 906 (advance c init-line! srcless-step) 907 (typeset-atom c out color? quote-depth expr? escapes? defn?) 908 (set! src-col (+ src-col (or (syntax-span c) 1))) 909 #; 910 (hash-set! next-col-map src-col dest-col)]))) 911 (out prefix1 #f) 912 (set! dest-col 0) 913 (hash-set! next-col-map init-col dest-col) 914 ((loop (lambda () (set! src-col init-col) (set! dest-col 0)) 0 expr? #f) c #f) 915 (if (list? suffix) 916 (map (lambda (sfx) 917 (finish-line!) 918 (out sfx #f)) 919 suffix) 920 (out suffix #f)) 921 (unless (null? content) 922 (finish-line!)) 923 (if multi-line? 924 (if (= 1 (length docs)) 925 (car docs) 926 (make-table block-color (map list (reverse docs)))) 927 (make-sized-element #f (reverse content) dest-col)))) 928 929 (define (typeset c multi-line? prefix1 prefix suffix color? expr? escapes? defn? elem-wrap) 930 (let* ([c (syntax-ize c 0 #:expr? expr?)] 931 [s (syntax-e c)]) 932 (if (or multi-line? 933 (and escapes? (eq? 'code:blank s)) 934 (pair? s) 935 (mpair? s) 936 (vector? s) 937 (struct? s) 938 (box? s) 939 (null? s) 940 (hash? s) 941 (graph-defn? s) 942 (graph-reference? s) 943 (struct-proxy? s) 944 (and expr? (or (identifier? c) 945 (keyword? (syntax-e c))))) 946 (gen-typeset c multi-line? prefix1 prefix suffix color? expr? escapes? defn? elem-wrap) 947 (typeset-atom c 948 (letrec ([mk 949 (case-lambda 950 [(elem color) 951 (mk elem color (or (syntax-span c) 1))] 952 [(elem color len) 953 (elem-wrap 954 (if (and (string? elem) 955 (= len (string-length elem))) 956 (make-element/cache (and color? color) elem) 957 (make-sized-element (and color? color) elem len)))])]) 958 mk) 959 color? 0 expr? escapes? defn?)))) 960 961 (define (to-element c 962 #:expr? [expr? #f] 963 #:escapes? [escapes? #t] 964 #:defn? [defn? #f]) 965 (typeset c #f "" "" "" #t expr? escapes? defn? values)) 966 967 (define (to-element/no-color c 968 #:expr? [expr? #f] 969 #:escapes? [escapes? #t]) 970 (typeset c #f "" "" "" #f expr? escapes? #f values)) 971 972 (define (to-paragraph c 973 #:expr? [expr? #f] 974 #:escapes? [escapes? #t] 975 #:color? [color? #t] 976 #:wrap-elem [elem-wrap (lambda (e) e)]) 977 (typeset c #t "" "" "" color? expr? escapes? #f elem-wrap)) 978 979 (define ((to-paragraph/prefix pfx1 pfx sfx) c 980 #:expr? [expr? #f] 981 #:escapes? [escapes? #t] 982 #:color? [color? #t] 983 #:wrap-elem [elem-wrap (lambda (e) e)]) 984 (typeset c #t pfx1 pfx sfx color? expr? escapes? #f elem-wrap)) 985 986 (begin-for-syntax 987 (define-struct variable-id (sym) 988 #:omit-define-syntaxes 989 #:property prop:procedure (lambda (self stx) 990 (raise-syntax-error 991 #f 992 (string-append 993 "misuse of an identifier (not in `racket', etc.) that is" 994 " bound as a code-typesetting variable") 995 stx))) 996 (define-struct element-id-transformer (proc) 997 #:omit-define-syntaxes 998 #:property prop:procedure (lambda (self stx) 999 (raise-syntax-error 1000 #f 1001 (string-append 1002 "misuse of an identifier (not in `racket', etc.) that is" 1003 " bound as an code-typesetting element transformer") 1004 stx)))) 1005 1006 (begin-for-syntax 1007 (require mutable-match-lambda) 1008 1009 (define mutable-match-element-id-transformer 1010 (make-mutable-match-lambda/infer-name)) 1011 1012 (define (try-mutable-match-element-id-transformer . vs) 1013 (apply (apply make-mutable-match-lambda 1014 (append (mutable-match-lambda-procedure-procs 1015 mutable-match-element-id-transformer) 1016 (list (clause->proc #:match-lambda [_ #f])))) 1017 vs)) 1018 1019 (provide mutable-match-element-id-transformer)) 1020 1021 (define-syntax (define-code stx) 1022 (syntax-case stx () 1023 [(the-id code typeset-code uncode d->s stx-prop) 1024 (syntax/loc stx 1025 (define-syntax (code stx) 1026 (define (wrap-loc v ctx e) 1027 `(,#'d->s ,ctx 1028 ,e 1029 #(code 1030 ,(syntax-line v) 1031 ,(syntax-column v) 1032 ,(syntax-position v) 1033 ,(syntax-span v)))) 1034 (define (stx->loc-s-expr/esc v uncode-id) 1035 (define (stx->loc-s-expr v) 1036 (let ([slv (and (identifier? v) 1037 (syntax-local-value v (lambda () #f)))]) 1038 (cond 1039 [(and (syntax? v) (syntax-property v 'scribble-render)) 1040 => (λ (renderer) 1041 (wrap-loc v #f (renderer v)))] 1042 [(and (syntax? v) (syntax-property v 'scribble-render-as)) 1043 => (λ (renderer) 1044 (stx->loc-s-expr 1045 (with-syntax ([splice 1046 (renderer v 1047 (quote-syntax the-id) 1048 (quote-syntax code) 1049 (quote-syntax typeset-code) 1050 (quote-syntax uncode) 1051 (quote-syntax d->s) 1052 (quote-syntax stx-prop))]) 1053 (syntax/loc #'splice 1054 (code:line . splice)))))] 1055 [(variable-id? slv) 1056 (wrap-loc v #f `(,#'make-var-id ',(variable-id-sym slv)))] 1057 [(element-id-transformer? slv) 1058 (wrap-loc v #f ((element-id-transformer-proc slv) v))] 1059 [(try-mutable-match-element-id-transformer v) 1060 => (λ (transformed) 1061 (wrap-loc v #f transformed))] 1062 [(syntax? v) 1063 (let ([mk (wrap-loc 1064 v 1065 `(quote-syntax ,(datum->syntax v 'defcode)) 1066 (syntax-case v () 1067 [(esc e) 1068 (and (identifier? #'esc) 1069 (free-identifier=? #'esc uncode-id)) 1070 #'e] 1071 [else (stx->loc-s-expr (syntax-e v))]))]) 1072 (let ([prop (syntax-property v 'paren-shape)]) 1073 (if prop 1074 `(,#'stx-prop ,mk 'paren-shape ,prop) 1075 mk)))] 1076 [(null? v) 'null] 1077 [(list? v) `(list . ,(map stx->loc-s-expr v))] 1078 [(pair? v) `(cons ,(stx->loc-s-expr (car v)) 1079 ,(stx->loc-s-expr (cdr v)))] 1080 [(vector? v) `(vector ,@(map 1081 stx->loc-s-expr 1082 (vector->list v)))] 1083 [(and (struct? v) (prefab-struct-key v)) 1084 `(make-prefab-struct (quote ,(prefab-struct-key v)) 1085 ,@(map 1086 stx->loc-s-expr 1087 (cdr (vector->list (struct->vector v)))))] 1088 [(box? v) `(box ,(stx->loc-s-expr (unbox v)))] 1089 [(hash? v) `(,(cond 1090 [(hash-eq? v) 'make-immutable-hasheq] 1091 [(hash-eqv? v) 'make-immutable-hasheqv] 1092 [else 'make-immutable-hash]) 1093 (list 1094 ,@(hash-map 1095 v 1096 (lambda (k v) 1097 `(cons (quote ,k) 1098 ,(stx->loc-s-expr v))))))] 1099 [else `(quote ,v)]))) 1100 (stx->loc-s-expr v)) 1101 (define (cvt s uncode-id) 1102 (datum->syntax #'here (stx->loc-s-expr/esc s uncode-id) #f)) 1103 (if (eq? (syntax-local-context) 'expression) 1104 (syntax-case stx () 1105 [(_ #:escape uncode-id expr) #`(typeset-code #,(cvt #'expr #'uncode-id))] 1106 [(_ expr) #`(typeset-code #,(cvt #'expr #'uncode))] 1107 [(_ #:escape uncode-id expr (... ...)) 1108 #`(typeset-code #,(cvt #'(code:line expr (... ...)) #'uncode-id))] 1109 [(_ expr (... ...)) 1110 #`(typeset-code #,(cvt #'(code:line expr (... ...)) #'uncode))]) 1111 (quasisyntax/loc stx 1112 (#%expression #,stx)))))] 1113 [(_ code typeset-code uncode d->s) 1114 #'(define-code code typeset-code uncode d->s syntax-property)] 1115 [(_ code typeset-code uncode) 1116 #'(define-code code typeset-code uncode datum->syntax syntax-property)] 1117 [(_ code typeset-code) #'(define-code code typeset-code unsyntax)])) 1118 1119 1120 (define syntax-ize-hook (make-parameter (lambda (v col) #f))) 1121 1122 (define (vector->short-list v extract) 1123 (vector->list v) 1124 #; 1125 (let ([l (vector->list v)]) 1126 (reverse (list-tail 1127 (reverse l) 1128 (- (vector-length v) 1129 (let loop ([i (sub1 (vector-length v))]) 1130 (cond 1131 [(zero? i) 1] 1132 [(eq? (extract (vector-ref v i)) 1133 (extract (vector-ref v (sub1 i)))) 1134 (loop (sub1 i))] 1135 [else (add1 i)]))))))) 1136 1137 (define (short-list->vector v l) 1138 (list->vector 1139 (let ([n (length l)]) 1140 (if (n . < . (vector-length v)) 1141 (reverse (let loop ([r (reverse l)][i (- (vector-length v) n)]) 1142 (if (zero? i) 1143 r 1144 (loop (cons (car r) r) (sub1 i))))) 1145 l)))) 1146 1147 (define-struct var-id (sym)) 1148 (define-struct shaped-parens (val shape)) 1149 (define-struct long-boolean (val)) 1150 (define-struct just-context (val ctx)) 1151 (define-struct alternate-display (id string)) 1152 (define-struct literal-syntax (stx)) 1153 (define-struct struct-proxy (name content)) 1154 1155 (define-struct graph-reference (bx)) 1156 (define-struct graph-defn (r bx)) 1157 1158 (define (syntax-ize v col [line 1] #:expr? [expr? #f]) 1159 (do-syntax-ize v col line (box #hasheq()) #f (and expr? 0) #f)) 1160 1161 (define (graph-count ht graph?) 1162 (and graph? 1163 (let ([n (hash-ref (unbox ht) '#%graph-count 0)]) 1164 (set-box! ht (hash-set (unbox ht) '#%graph-count (add1 n))) 1165 n))) 1166 1167 (define-struct forced-pair (car cdr)) 1168 1169 (define (quotable? v) 1170 (define graph (make-hasheq)) 1171 (let quotable? ([v v]) 1172 (if (hash-ref graph v #f) 1173 #t 1174 (begin 1175 (hash-set! graph v #t) 1176 (cond 1177 [(syntax? v) (quotable? (syntax-e v))] 1178 [(pair? v) (and (quotable? (car v)) 1179 (quotable? (cdr v)))] 1180 [(vector? v) (andmap quotable? (vector->list v))] 1181 [(hash? v) (for/and ([(k v) (in-hash v)]) 1182 (and (quotable? k) 1183 (quotable? v)))] 1184 [(box? v) (quotable? (unbox v))] 1185 [(and (struct? v) 1186 (prefab-struct-key v)) 1187 (andmap quotable? (vector->list (struct->vector v)))] 1188 [(struct? v) (if (custom-write? v) 1189 (case (or (and (custom-print-quotable? v) 1190 (custom-print-quotable-accessor v)) 1191 'self) 1192 [(self always) #t] 1193 [(never) #f] 1194 [(maybe) 1195 (andmap quotable? (vector->list (struct->vector v)))]) 1196 #f)] 1197 [(struct-proxy? v) #f] 1198 [(mpair? v) #f] 1199 [else #t]))))) 1200 1201 (define (do-syntax-ize v col line ht graph? qq no-cons?) 1202 (cond 1203 [((syntax-ize-hook) v col) 1204 => (lambda (r) r)] 1205 [(shaped-parens? v) 1206 (syntax-property (do-syntax-ize (shaped-parens-val v) col line ht #f qq #f) 1207 'paren-shape 1208 (shaped-parens-shape v))] 1209 [(long-boolean? v) 1210 (datum->syntax #f 1211 (and (long-boolean-val v) #t) 1212 (vector #f line col (+ 1 col) (if (long-boolean-val v) 5 6)))] 1213 [(just-context? v) 1214 (let ([s (do-syntax-ize (just-context-val v) col line ht #f qq #f)]) 1215 (datum->syntax (just-context-ctx v) 1216 (syntax-e s) 1217 s 1218 s 1219 (just-context-ctx v)))] 1220 [(alternate-display? v) 1221 (let ([s (do-syntax-ize (alternate-display-id v) col line ht #f qq #f)]) 1222 (syntax-property s 1223 'display-string 1224 (alternate-display-string v)))] 1225 [(hash-ref (unbox ht) v #f) 1226 => (lambda (m) 1227 (unless (unbox m) 1228 (set-box! m #t)) 1229 (datum->syntax #f 1230 (make-graph-reference m) 1231 (vector #f line col (+ 1 col) 1)))] 1232 [(and qq 1233 (zero? qq) 1234 (or (pair? v) 1235 (forced-pair? v) 1236 (vector? v) 1237 (hash? v) 1238 (box? v) 1239 (and (struct? v) 1240 (prefab-struct-key v))) 1241 (quotable? v) 1242 (not no-cons?)) 1243 ;; Add a quote: 1244 (let ([l (do-syntax-ize v (add1 col) line ht #f 1 #f)]) 1245 (datum->syntax #f 1246 (syntax-e l) 1247 (vector (syntax-source l) 1248 (syntax-line l) 1249 (sub1 (syntax-column l)) 1250 (max 0 (sub1 (syntax-position l))) 1251 (add1 (syntax-span l)))))] 1252 [(and (list? v) 1253 (pair? v) 1254 (or (not qq) 1255 (positive? qq) 1256 (quotable? v)) 1257 (let ([s (let ([s (car v)]) 1258 (if (just-context? s) 1259 (just-context-val s) 1260 s))]) 1261 (memq s '(quote unquote unquote-splicing))) 1262 (not no-cons?)) 1263 => (lambda (s) 1264 (let* ([delta (if (and qq (zero? qq)) 1265 1 1266 0)] 1267 [c (do-syntax-ize (cadr v) (+ col delta) line ht #f qq #f)]) 1268 (datum->syntax #f 1269 (list (do-syntax-ize (car v) col line ht #f qq #f) 1270 c) 1271 (vector #f line col (+ 1 col) 1272 (+ delta 1273 (syntax-span c))))))] 1274 [(or (list? v) 1275 (vector? v) 1276 (and (struct? v) 1277 (or (and qq 1278 ;; Watch out for partially transparent subtypes of `element' 1279 ;; or convertible values: 1280 (not (convertible? v)) 1281 (not (element? v))) 1282 (prefab-struct-key v)))) 1283 (let ([orig-ht (unbox ht)] 1284 [graph-box (box (graph-count ht graph?))]) 1285 (set-box! ht (hash-set (unbox ht) v graph-box)) 1286 (let* ([graph-sz (if graph? 1287 (+ 2 (string-length (format "~a" (unbox graph-box)))) 1288 0)] 1289 [vec-sz (cond 1290 [(vector? v) 1291 (if (and qq (zero? qq)) 0 1)] 1292 [(struct? v) 1293 (if (and (prefab-struct-key v) 1294 (or (not qq) (positive? qq))) 1295 2 1296 0)] 1297 [else 0])] 1298 [delta (if (and qq (zero? qq)) 1299 (cond 1300 [(vector? v) 8] ; `(vector ' 1301 [(struct? v) 1] ; '(' 1302 [no-cons? 1] ; '(' 1303 [else 6]) ; `(list ' 1304 1)] 1305 [r (let ([l (let loop ([col (+ col delta vec-sz graph-sz)] 1306 [v (cond 1307 [(vector? v) 1308 (vector->short-list v values)] 1309 [(struct? v) 1310 (cons (let ([pf (prefab-struct-key v)]) 1311 (if pf 1312 (prefab-struct-key v) 1313 (object-name v))) 1314 (cdr (vector->list (struct->vector v qq-ellipses))))] 1315 [else v])]) 1316 (if (null? v) 1317 null 1318 (let ([i (do-syntax-ize (car v) col line ht #f qq #f)]) 1319 (cons i 1320 (loop (+ col 1 (syntax-span i)) (cdr v))))))]) 1321 (datum->syntax #f 1322 (cond 1323 [(vector? v) (short-list->vector v l)] 1324 [(struct? v) 1325 (let ([pf (prefab-struct-key v)]) 1326 (if pf 1327 (apply make-prefab-struct (prefab-struct-key v) (cdr l)) 1328 (make-struct-proxy (car l) (cdr l))))] 1329 [else l]) 1330 (vector #f line 1331 (+ graph-sz col) 1332 (+ 1 graph-sz col) 1333 (+ 1 1334 vec-sz 1335 delta 1336 (if (zero? (length l)) 1337 0 1338 (sub1 (length l))) 1339 (apply + (map syntax-span l))))))]) 1340 (unless graph? 1341 (set-box! ht (hash-set (unbox ht) v #f))) 1342 (cond 1343 [graph? (datum->syntax #f 1344 (make-graph-defn r graph-box) 1345 (vector #f (syntax-line r) 1346 (- (syntax-column r) graph-sz) 1347 (- (syntax-position r) graph-sz) 1348 (+ (syntax-span r) graph-sz)))] 1349 [(unbox graph-box) 1350 ;; Go again, this time knowing that there will be a graph: 1351 (set-box! ht orig-ht) 1352 (do-syntax-ize v col line ht #t qq #f)] 1353 [else r])))] 1354 [(or (pair? v) 1355 (mpair? v) 1356 (forced-pair? v)) 1357 (let ([carv (if (pair? v) (car v) (if (mpair? v) (mcar v) (forced-pair-car v)))] 1358 [cdrv (if (pair? v) (cdr v) (if (mpair? v) (mcdr v) (forced-pair-cdr v)))] 1359 [orig-ht (unbox ht)] 1360 [graph-box (box (graph-count ht graph?))]) 1361 (set-box! ht (hash-set (unbox ht) v graph-box)) 1362 (let* ([delta (if (and qq (zero? qq) (not no-cons?)) 1363 (if (mpair? v) 1364 7 ; "(mcons " 1365 (if (or (list? cdrv) 1366 (not (pair? cdrv))) 1367 6 ; "(cons " 1368 7)) ; "(list* " 1369 1)] 1370 [inc (if graph? 1371 (+ 2 (string-length (format "~a" (unbox graph-box)))) 1372 0)] 1373 [a (do-syntax-ize carv (+ col delta inc) line ht #f qq #f)] 1374 [sep (if (and (pair? v) 1375 (pair? cdrv) 1376 ;; FIXME: what if it turns out to be a graph reference? 1377 (not (hash-ref (unbox ht) cdrv #f))) 1378 0 1379 (if (and qq (zero? qq)) 1380 1 1381 3))] 1382 [b (do-syntax-ize cdrv (+ col delta inc (syntax-span a) sep) line ht #f qq #t)]) 1383 (let ([r (datum->syntax #f 1384 (if (mpair? v) 1385 (mcons a b) 1386 (cons a b)) 1387 (vector #f line (+ col inc) (+ delta col inc) 1388 (+ 1 delta 1389 (if (and qq (zero? qq)) 1 0) 1390 sep (syntax-span a) (syntax-span b))))]) 1391 (unless graph? 1392 (set-box! ht (hash-set (unbox ht) v #f))) 1393 (cond 1394 [graph? (datum->syntax #f 1395 (make-graph-defn r graph-box) 1396 (vector #f line col (+ delta col) 1397 (+ inc (syntax-span r))))] 1398 [(unbox graph-box) 1399 ;; Go again... 1400 (set-box! ht orig-ht) 1401 (do-syntax-ize v col line ht #t qq #f)] 1402 [else r]))))] 1403 [(box? v) 1404 (let* ([delta (if (and qq (zero? qq)) 1405 5 ; "(box " 1406 2)] ; "#&" 1407 [a (do-syntax-ize (unbox v) (+ col delta) line ht #f qq #f)]) 1408 (datum->syntax #f 1409 (box a) 1410 (vector #f line col (+ 1 col) 1411 (+ delta (if (and qq (zero? qq)) 1 0) (syntax-span a)))))] 1412 [(hash? v) 1413 (let* ([delta (cond 1414 [(hash-eq? v) 7] 1415 [(hash-eqv? v) 8] 1416 [else 6])] 1417 [undelta (if (and qq (zero? qq)) 1418 (- delta 1) 1419 0)] 1420 [pairs (if (and qq (zero? qq)) 1421 (let ([ls (do-syntax-ize (apply append (hash-map v (lambda (k v) (list k v)))) 1422 (+ col delta -1) line ht #f qq #t)]) 1423 (datum->syntax 1424 #f 1425 (let loop ([l (syntax->list ls)]) 1426 (if (null? l) 1427 null 1428 (cons (cons (car l) (cadr l)) (loop (cddr l))))) 1429 ls)) 1430 (do-syntax-ize (hash-map v make-forced-pair) (+ col delta) line ht #f qq #f))]) 1431 (datum->syntax #f 1432 ((cond 1433 [(hash-eq? v) make-immutable-hasheq] 1434 [(hash-eqv? v) make-immutable-hasheqv] 1435 [else make-immutable-hash]) 1436 (map (lambda (p) 1437 (let ([p (syntax-e p)]) 1438 (cons (syntax->datum (car p)) 1439 (cdr p)))) 1440 (syntax->list pairs))) 1441 (vector (syntax-source pairs) 1442 (syntax-line pairs) 1443 (max 0 (- (syntax-column pairs) undelta)) 1444 (max 1 (- (syntax-position pairs) undelta)) 1445 (+ (syntax-span pairs) undelta))))] 1446 [else 1447 (datum->syntax #f v (vector #f line col (+ 1 col) 1))]))