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