core.rkt (26520B)
1 #lang scheme/base 2 (require "private/provide-structs.rkt" 3 scheme/serialize 4 racket/contract/base 5 file/convertible) 6 7 ;; ---------------------------------------- 8 9 (define-struct collect-info (fp ht ext-ht ext-demand parts tags gen-prefix relatives parents) #:transparent) 10 (define-struct resolve-info (ci delays undef searches) #:transparent) 11 12 (define (part-collected-info part ri) 13 (hash-ref (collect-info-parts (resolve-info-ci ri)) 14 part)) 15 16 (define (collect-put! ci key val) 17 (let ([ht (collect-info-ht ci)]) 18 (let ([old-val (hash-ref ht key #f)]) 19 (when old-val 20 (eprintf "WARNING: collected information for key multiple times: ~e; values: ~e ~e\n" 21 key old-val val)) 22 (hash-set! ht key val)))) 23 24 (define (resolve-get/where part ri key) 25 (let ([key (tag-key key ri)]) 26 (let ([v (hash-ref (if part 27 (collected-info-info (part-collected-info part ri)) 28 (collect-info-ht (resolve-info-ci ri))) 29 key 30 #f)]) 31 (cond 32 [v (values v #f)] 33 [part (resolve-get/where 34 (collected-info-parent (part-collected-info part ri)) 35 ri key)] 36 [else 37 (define ci (resolve-info-ci ri)) 38 (define (try-ext) 39 (hash-ref (collect-info-ext-ht ci) key #f)) 40 (define v 41 (or (try-ext) 42 (and ((collect-info-ext-demand ci) key ci) 43 (try-ext)))) 44 (if (known-doc? v) 45 (values (known-doc-v v) (known-doc-id v)) 46 (values v #t))])))) 47 48 (define (resolve-get/ext? part ri key) 49 (define-values (v ext-id) (resolve-get/ext-id* part ri key #f)) 50 (values v (and ext-id #t))) 51 52 (define (resolve-get/ext-id part ri key) 53 (resolve-get/ext-id* part ri key #f)) 54 55 (define (resolve-get/ext-id* part ri key search-key) 56 (let-values ([(v ext-id) (resolve-get/where part ri key)]) 57 (when ext-id 58 (hash-set! (resolve-info-undef ri) (tag-key key ri) 59 (if v 'found search-key))) 60 (values v ext-id))) 61 62 (define (resolve-get part ri key) 63 (resolve-get* part ri key #f)) 64 65 (define (resolve-get* part ri key search-key) 66 (let-values ([(v ext-id) (resolve-get/ext-id* part ri key search-key)]) 67 v)) 68 69 (define (resolve-get/tentative part ri key) 70 (let-values ([(v ext-id) (resolve-get/where part ri key)]) 71 v)) 72 73 (define (resolve-search search-key part ri key) 74 (let ([s-ht (hash-ref (resolve-info-searches ri) 75 search-key 76 (lambda () 77 (let ([s-ht (make-hash)]) 78 (hash-set! (resolve-info-searches ri) 79 search-key s-ht) 80 s-ht)))]) 81 (hash-set! s-ht key #t)) 82 (resolve-get* part ri key search-key)) 83 84 (define (resolve-get-keys part ri key-pred) 85 (for/list ([k (in-hash-keys (if part 86 (collected-info-info (part-collected-info part ri)) 87 (let ([ci (resolve-info-ci ri)]) 88 ;; Force all xref info: 89 ((collect-info-ext-demand ci) #f ci) 90 (collect-info-ext-ht ci))))] 91 #:when (key-pred k)) 92 k)) 93 94 (provide (struct-out collect-info) 95 (struct-out resolve-info)) 96 97 ;; ---------------------------------------- 98 99 (provide tag?) 100 (define (tag? s) 101 (and (pair? s) 102 (symbol? (car s)) 103 (pair? (cdr s)) 104 (or (string? (cadr s)) 105 (generated-tag? (cadr s)) 106 (and (pair? (cadr s)) 107 (list? (cadr s)) 108 (serializable? (cadr s)))) 109 (null? (cddr s)))) 110 111 (provide block?) 112 (define (block? p) 113 (or (paragraph? p) 114 (table? p) 115 (itemization? p) 116 (nested-flow? p) 117 (compound-paragraph? p) 118 (delayed-block? p) 119 (traverse-block? p))) 120 121 (define content-symbols 122 #hasheq([nbsp . #t] 123 [mdash . #t] 124 [ndash . #t] 125 [ldquo . #t] 126 [rdquo . #t] 127 [rsquo . #t] 128 [lsquo . #t] 129 [prime . #t] 130 [rarr . #t] 131 [larr . #t] 132 [alpha . #t] 133 [infin . #t] 134 [lang . #t] 135 [rang . #t])) 136 137 (provide content?) 138 (define (content? v) 139 (or (string? v) 140 (element? v) 141 (and (list? v) (andmap content? v)) 142 (delayed-element? v) 143 (traverse-element? v) 144 (part-relative-element? v) 145 (multiarg-element? v) 146 (hash-ref content-symbols v #f) 147 (convertible? v))) 148 149 (provide element-style?) 150 (define (element-style? s) 151 (or (style? s) (not s) (string? s) (symbol? s))) 152 153 (define (string-without-newline? s) 154 (and (string? s) 155 (not (regexp-match? #rx"\n" s)))) 156 157 (define (same-lengths? ls) 158 (or (null? ls) 159 (let ([l1 (length (car ls))]) 160 (andmap (λ (l) (= l1 (length l))) 161 (cdr ls))))) 162 163 ;; ---------------------------------------- 164 165 (define-struct link-render-style (mode) 166 #:constructor-name link-render-style 167 #:property 168 prop:serializable 169 (make-serialize-info 170 (lambda (s) 171 (vector (link-render-style-mode s))) 172 #'deserialize-link-render-style 173 #f 174 (or (current-load-relative-directory) (current-directory)))) 175 176 (provide deserialize-link-render-style) 177 (define deserialize-link-render-style 178 (make-deserialize-info (lambda (s) 179 (link-render-style s)) 180 (lambda (tag init-val) 181 (error "cannot allocate link-render-style for cycle")))) 182 183 (define current-link-render-style (make-parameter (link-render-style 'default))) 184 185 (provide 186 link-render-style? 187 link-render-style-mode 188 (contract-out 189 [link-render-style ((or/c 'default 'number) 190 . -> . link-render-style?)] 191 [current-link-render-style (parameter/c link-render-style?)])) 192 193 ;; ---------------------------------------- 194 195 (define-struct numberer (tag step-proc initial-value) 196 #:constructor-name numberer 197 #:property 198 prop:serializable 199 (make-serialize-info 200 (lambda (d) 201 (vector (numberer-tag d) 202 (numberer-initial-value d))) 203 #'deserialize-numberer 204 #f 205 (or (current-load-relative-directory) (current-directory)))) 206 207 (provide deserialize-numberer) 208 (define deserialize-numberer 209 (make-deserialize-info (lambda (tag init-val) 210 (numberer tag #f)) 211 (lambda (tag init-val) 212 (error "cannot allocate numberer for cycle")))) 213 214 (define (make-numberer spec-proc initial-value) 215 (numberer (generated-tag) spec-proc initial-value)) 216 217 (define (numberer-step n parent-numbers ci ht) 218 (define tag (generate-tag `(numberer ,(numberer-tag n)) ci)) 219 (define-values (numberer-str new-val) 220 (let ([step (numberer-step-proc n)]) 221 (step (hash-ref ht tag (lambda () (numberer-initial-value n))) 222 parent-numbers))) 223 (values numberer-str (hash-set ht tag new-val))) 224 225 (define part-number-item? 226 (or/c #f exact-nonnegative-integer? string? (list/c string? string?))) 227 228 (provide 229 part-number-item? 230 numberer? 231 (contract-out 232 [make-numberer ((any/c (listof part-number-item?) 233 . -> . (values part-number-item? any/c)) 234 any/c 235 . -> . numberer?)] 236 [numberer-step (numberer? 237 (listof part-number-item?) 238 collect-info? 239 hash? 240 . -> . (values part-number-item? hash?))])) 241 242 ;; ---------------------------------------- 243 244 (provide-structs 245 [part ([tag-prefix (or/c false/c string?)] 246 [tags (listof tag?)] 247 [title-content (or/c false/c content?)] 248 [style style?] 249 [to-collect list?] 250 [blocks (listof block?)] 251 [parts (listof part?)])] 252 [paragraph ([style style?] 253 [content content?])] 254 [table ([style style?] 255 [blockss (and/c (listof (listof (or/c block? (one-of/c 'cont)))) 256 same-lengths?)])] 257 [delayed-block ([resolve (any/c part? resolve-info? . -> . block?)])] 258 [itemization ([style style?] 259 [blockss (listof (listof block?))])] 260 [nested-flow ([style style?] 261 [blocks (listof block?)])] 262 [compound-paragraph ([style style?] 263 [blocks (listof block?)])] 264 265 [element ([style element-style?] 266 [content content?])] 267 [(toc-element element) ([toc-content content?])] 268 [(target-element element) ([tag tag?])] 269 [(toc-target-element target-element) ()] 270 [(toc-target2-element toc-target-element) ([toc-content content?])] 271 [(page-target-element target-element) ()] 272 [(redirect-target-element target-element) ([alt-path path-string?] 273 [alt-anchor string?])] 274 [(link-element element) ([tag tag?])] 275 [(index-element element) ([tag tag?] 276 [plain-seq (and/c pair? (listof string-without-newline?))] 277 [entry-seq (listof content?)] 278 [desc any/c])] 279 [(image-element element) ([path (or/c path-string? 280 (cons/c (one-of/c 'collects) 281 (listof bytes?)))] 282 [suffixes (listof #rx"^[.]")] 283 [scale real?])] 284 [multiarg-element ([style element-style?] 285 [contents (listof content?)])] 286 287 [style ([name (or/c string? symbol? #f)] 288 [properties list?])] 289 ;; properties: 290 [document-version ([text (or/c string? false/c)])] 291 [document-date ([text (or/c string? false/c)])] 292 [target-url ([addr path-string?])] 293 [color-property ([color (or/c string? (list/c byte? byte? byte?))])] 294 [background-color-property ([color (or/c string? (list/c byte? byte? byte?))])] 295 [numberer-property ([numberer numberer?] [argument any/c])] 296 297 [table-columns ([styles (listof style?)])] 298 [table-cells ([styless (listof (listof style?))])] 299 300 [box-mode ([top-name string?] 301 [center-name string?] 302 [bottom-name string?])] 303 304 [collected-info ([number (listof part-number-item?)] 305 [parent (or/c false/c part?)] 306 [info any/c])] 307 308 [known-doc ([v any/c] 309 [id string?])]) 310 311 (provide plain) 312 (define plain (make-style #f null)) 313 314 (define (box-mode* name) 315 (box-mode name name name)) 316 (provide/contract 317 [box-mode* (string? . -> . box-mode?)]) 318 319 ;; ---------------------------------------- 320 321 ;; Traverse block has special serialization support: 322 (define-struct traverse-block (traverse) 323 #:property 324 prop:serializable 325 (make-serialize-info 326 (lambda (d) 327 (let ([ri (current-serialize-resolve-info)]) 328 (unless ri 329 (error 'serialize-traverse-block 330 "current-serialize-resolve-info not set")) 331 (vector (traverse-block-block d ri)))) 332 #'deserialize-traverse-block 333 #f 334 (or (current-load-relative-directory) (current-directory))) 335 #:transparent) 336 337 (define block-traverse-procedure/c 338 (recursive-contract 339 ((symbol? any/c . -> . any/c) 340 (symbol? any/c . -> . any) 341 . -> . (or/c block-traverse-procedure/c 342 block?)))) 343 344 (provide block-traverse-procedure/c) 345 (provide/contract 346 (struct traverse-block ([traverse block-traverse-procedure/c]))) 347 348 (provide deserialize-traverse-block) 349 (define deserialize-traverse-block 350 (make-deserialize-info values values)) 351 352 (define (traverse-block-block b i) 353 (cond 354 [(collect-info? i) 355 (let ([p (hash-ref (collect-info-fp i) b #f)]) 356 (if (block? p) 357 p 358 (error 'traverse-block-block 359 "no block computed for traverse-block: ~e" 360 b)))] 361 [(resolve-info? i) 362 (traverse-block-block b (resolve-info-ci i))])) 363 364 (provide/contract 365 [traverse-block-block (traverse-block? 366 (or/c resolve-info? collect-info?) 367 . -> . block?)]) 368 369 ;; ---------------------------------------- 370 371 ;; Traverse element has special serialization support: 372 (define-struct traverse-element (traverse) 373 #:property 374 prop:serializable 375 (make-serialize-info 376 (lambda (d) 377 (let ([ri (current-serialize-resolve-info)]) 378 (unless ri 379 (error 'serialize-traverse-block 380 "current-serialize-resolve-info not set")) 381 (vector (traverse-element-content d ri)))) 382 #'deserialize-traverse-element 383 #f 384 (or (current-load-relative-directory) (current-directory))) 385 #:transparent) 386 387 (define element-traverse-procedure/c 388 (recursive-contract 389 ((symbol? any/c . -> . any/c) 390 (symbol? any/c . -> . any) 391 . -> . (or/c element-traverse-procedure/c 392 content?)))) 393 394 (provide/contract 395 (struct traverse-element ([traverse element-traverse-procedure/c]))) 396 397 (provide deserialize-traverse-element) 398 (define deserialize-traverse-element 399 (make-deserialize-info values values)) 400 401 (define (traverse-element-content e i) 402 (cond 403 [(collect-info? i) 404 (let ([c (hash-ref (collect-info-fp i) e #f)]) 405 (if (content? c) 406 c 407 (error 'traverse-block-block 408 "no block computed for traverse-block: ~e" 409 e)))] 410 [(resolve-info? i) 411 (traverse-element-content e (resolve-info-ci i))])) 412 413 (provide element-traverse-procedure/c) 414 (provide/contract 415 [traverse-element-content (traverse-element? 416 (or/c resolve-info? collect-info?) 417 . -> . content?)]) 418 419 ;; ---------------------------------------- 420 421 ;; Delayed element has special serialization support: 422 (define-struct delayed-element (resolve sizer plain) 423 #:property 424 prop:serializable 425 (make-serialize-info 426 (lambda (d) 427 (let ([ri (current-serialize-resolve-info)]) 428 (unless ri 429 (error 'serialize-delayed-element 430 "current-serialize-resolve-info not set")) 431 (with-handlers ([exn:fail:contract? 432 (lambda (exn) 433 (error 'serialize-delayed-element 434 "serialization failed (wrong resolve info? delayed element never rendered?); ~a" 435 (exn-message exn)))]) 436 (vector (delayed-element-content d ri))))) 437 #'deserialize-delayed-element 438 #f 439 (or (current-load-relative-directory) (current-directory))) 440 #:transparent) 441 442 (provide/contract 443 (struct delayed-element ([resolve (any/c part? resolve-info? . -> . content?)] 444 [sizer (-> any)] 445 [plain (-> any)]))) 446 447 (module+ deserialize-info 448 (provide deserialize-delayed-element)) 449 (define deserialize-delayed-element 450 (make-deserialize-info values values)) 451 452 (provide delayed-element-content) 453 (define (delayed-element-content e ri) 454 (hash-ref (resolve-info-delays ri) e)) 455 456 (provide delayed-block-blocks) 457 (define (delayed-block-blocks p ri) 458 (hash-ref (resolve-info-delays ri) p)) 459 460 (provide current-serialize-resolve-info) 461 (define current-serialize-resolve-info (make-parameter #f)) 462 463 ;; ---------------------------------------- 464 465 ;; part-relative element has special serialization support: 466 (define-struct part-relative-element (collect sizer plain) 467 #:property 468 prop:serializable 469 (make-serialize-info 470 (lambda (d) 471 (let ([ri (current-serialize-resolve-info)]) 472 (unless ri 473 (error 'serialize-part-relative-element 474 "current-serialize-resolve-info not set")) 475 (with-handlers ([exn:fail:contract? 476 (lambda (exn) 477 (error 'serialize-part-relative-element 478 "serialization failed (wrong resolve info? part-relative element never rendered?); ~a" 479 (exn-message exn)))]) 480 (vector 481 (part-relative-element-content d ri))))) 482 #'deserialize-part-relative-element 483 #f 484 (or (current-load-relative-directory) (current-directory))) 485 #:transparent) 486 487 (provide/contract 488 (struct part-relative-element ([collect (collect-info? . -> . content?)] 489 [sizer (-> any)] 490 [plain (-> any)]))) 491 492 (module+ deserialize-info 493 (provide deserialize-part-relative-element)) 494 (define deserialize-part-relative-element 495 (make-deserialize-info values values)) 496 497 (provide part-relative-element-content) 498 (define (part-relative-element-content e ci/ri) 499 (hash-ref (collect-info-relatives 500 (if (resolve-info? ci/ri) (resolve-info-ci ci/ri) ci/ri)) 501 e)) 502 503 (provide collect-info-parents) 504 505 ;; ---------------------------------------- 506 507 ;; Delayed index entry also has special serialization support. 508 ;; It uses the same delay -> value table as delayed-element 509 (define-struct delayed-index-desc (resolve) 510 #:mutable 511 #:property 512 prop:serializable 513 (make-serialize-info 514 (lambda (d) 515 (let ([ri (current-serialize-resolve-info)]) 516 (unless ri 517 (error 'serialize-delayed-index-desc 518 "current-serialize-resolve-info not set")) 519 (with-handlers ([exn:fail:contract? 520 (lambda (exn) 521 (error 'serialize-index-desc 522 "serialization failed (wrong resolve info?); ~a" 523 (exn-message exn)))]) 524 (vector 525 (delayed-element-content d ri))))) 526 #'deserialize-delayed-index-desc 527 #f 528 (or (current-load-relative-directory) (current-directory))) 529 #:transparent) 530 531 (provide/contract 532 (struct delayed-index-desc ([resolve (any/c part? resolve-info? . -> . any)]))) 533 534 (module+ deserialize-info 535 (provide deserialize-delayed-index-desc)) 536 (define deserialize-delayed-index-desc 537 (make-deserialize-info values values)) 538 539 ;; ---------------------------------------- 540 541 (define-struct (collect-element element) (collect) 542 #:mutable 543 #:property 544 prop:serializable 545 (make-serialize-info 546 (lambda (d) 547 (vector (make-element 548 (element-style d) 549 (element-content d)))) 550 #'deserialize-collect-element 551 #f 552 (or (current-load-relative-directory) (current-directory))) 553 #:transparent) 554 555 (module+ deserialize-info 556 (provide deserialize-collect-element)) 557 (define deserialize-collect-element 558 (make-deserialize-info values values)) 559 560 (provide/contract 561 [struct collect-element ([style element-style?] 562 [content content?] 563 [collect (collect-info? . -> . any)])]) 564 565 ;; ---------------------------------------- 566 567 (define-struct (render-element element) (render) 568 #:property 569 prop:serializable 570 (make-serialize-info 571 (lambda (d) 572 (vector (make-element 573 (element-style d) 574 (element-content d)))) 575 #'deserialize-render-element 576 #f 577 (or (current-load-relative-directory) (current-directory))) 578 #:transparent) 579 580 (module+ deserialize-info 581 (provide deserialize-render-element)) 582 (define deserialize-render-element 583 (make-deserialize-info values values)) 584 585 (provide/contract 586 [struct render-element ([style element-style?] 587 [content content?] 588 [render (any/c part? resolve-info? . -> . any)])]) 589 590 ;; ---------------------------------------- 591 592 (define-struct generated-tag () 593 #:property 594 prop:serializable 595 (make-serialize-info 596 (lambda (g) 597 (let ([ri (current-serialize-resolve-info)]) 598 (unless ri 599 (error 'serialize-generated-tag 600 "current-serialize-resolve-info not set")) 601 (let ([t (hash-ref (collect-info-tags (resolve-info-ci ri)) g #f)]) 602 (if t 603 (vector t) 604 (error 'serialize-generated-tag 605 "serialization failed (wrong resolve info?)"))))) 606 #'deserialize-generated-tag 607 #f 608 (or (current-load-relative-directory) (current-directory))) 609 #:transparent) 610 611 (provide (struct-out generated-tag)) 612 613 (module+ deserialize-info 614 (provide deserialize-generated-tag)) 615 (define deserialize-generated-tag 616 (make-deserialize-info values values)) 617 618 (provide generate-tag tag-key 619 current-tag-prefixes 620 add-current-tag-prefix) 621 622 (define (generate-tag tg ci) 623 (if (generated-tag? (cadr tg)) 624 (let ([t (cadr tg)]) 625 (list (car tg) 626 (let ([tags (collect-info-tags ci)]) 627 (or (hash-ref tags t #f) 628 (let ([key (list* 'gentag 629 (hash-count tags) 630 (collect-info-gen-prefix ci))]) 631 (hash-set! tags t key) 632 key))))) 633 tg)) 634 635 (define (tag-key tg ri) 636 (if (generated-tag? (cadr tg)) 637 (list (car tg) 638 (hash-ref (collect-info-tags (resolve-info-ci ri)) (cadr tg))) 639 tg)) 640 641 (define current-tag-prefixes (make-parameter null)) 642 (define (add-current-tag-prefix t) 643 (let ([l (current-tag-prefixes)]) 644 (if (null? l) 645 t 646 (cons (car t) (append l (cdr t)))))) 647 648 ;; ---------------------------------------- 649 650 (provide content->string 651 strip-aux) 652 653 ;; content->port: output-port content -> void 654 ;; Writes the string content of content into op. 655 (define content->port 656 (case-lambda 657 [(op c) 658 (cond 659 [(element? c) (content->port op (element-content c))] 660 [(multiarg-element? c) (content->port op (multiarg-element-contents c))] 661 [(list? c) (for-each (lambda (e) (content->port op e)) c)] 662 [(part-relative-element? c) (content->port op ((part-relative-element-plain c)))] 663 [(delayed-element? c) (content->port op ((delayed-element-plain c)))] 664 [(string? c) (display c op)] 665 [else (display (case c 666 [(mdash) "---"] 667 [(ndash) "--"] 668 [(ldquo rdquo) "\""] 669 [(rsquo) "'"] 670 [(rarr) "->"] 671 [(lang) "<"] 672 [(rang) ">"] 673 [(nbsp) "\xA0"] 674 [else (format "~s" c)]) 675 op)])] 676 [(op c renderer sec ri) 677 (cond 678 [(and (link-element? c) 679 (null? (element-content c))) 680 (let ([dest (resolve-get sec ri (link-element-tag c))]) 681 ;; FIXME: this is specific to renderer 682 (if dest 683 (content->port op 684 (strip-aux 685 (if (pair? dest) (cadr dest) (vector-ref dest 1))) 686 renderer sec ri) 687 (display "???" op)))] 688 [(element? c) (content->port op (element-content c) renderer sec ri)] 689 [(multiarg-element? c) (content->port op (multiarg-element-contents c) renderer sec ri)] 690 [(list? c) (for-each (lambda (e) 691 (content->port op e renderer sec ri)) 692 c)] 693 [(delayed-element? c) 694 (content->port op (delayed-element-content c ri) renderer sec ri)] 695 [(part-relative-element? c) 696 (content->port op (part-relative-element-content c ri) renderer sec ri)] 697 [else (content->port op c)])])) 698 699 (define (simple-content->string c) 700 ;; `content->string' is commonly used on a list containing a single string 701 (cond 702 [(string? c) c] 703 [(and (pair? c) 704 (string? (car c)) 705 (null? (cdr c))) 706 (car c)] 707 [else #f])) 708 709 (define content->string 710 (case-lambda 711 [(c) 712 (or (simple-content->string c) 713 (let ([op (open-output-string)]) 714 (content->port op c) 715 (get-output-string op)))] 716 [(c renderer sec ri) 717 (or (simple-content->string c) 718 (let ([op (open-output-string)]) 719 (content->port op c renderer sec ri) 720 (get-output-string op)))])) 721 722 723 (define (aux-element? e) 724 (and (element? e) 725 (let ([s (element-style e)]) 726 (and (style? s) 727 (memq 'aux (style-properties s)))))) 728 729 (define (strip-aux content) 730 (cond 731 [(null? content) null] 732 [(aux-element? content) null] 733 [(element? content) 734 (define c (element-content content)) 735 (define p (strip-aux c)) 736 (if (equal? c p) 737 content 738 (struct-copy element content [content p]))] 739 [(list? content) 740 (define p (map strip-aux content)) 741 (if (equal? p content) 742 content 743 p)] 744 [else content])) 745 746 ;; ---------------------------------------- 747 748 (provide block-width 749 content-width) 750 751 (define (content-width s) 752 (cond 753 [(string? s) (string-length s)] 754 [(list? s) (for/fold ([v 0]) ([s (in-list s)]) (+ v (content-width s)))] 755 [(element? s) (content-width (element-content s))] 756 [(multiarg-element? s) (content-width (multiarg-element-contents s))] 757 [(delayed-element? s) (content-width ((delayed-element-sizer s)))] 758 [(part-relative-element? s) (content-width ((part-relative-element-sizer s)))] 759 [else 1])) 760 761 (define (paragraph-width s) 762 (content-width (paragraph-content s))) 763 764 (define (flow-width f) 765 (apply max 0 (map block-width f))) 766 767 (define (block-width p) 768 (cond 769 [(paragraph? p) (paragraph-width p)] 770 [(table? p) (table-width p)] 771 [(itemization? p) (itemization-width p)] 772 [(nested-flow? p) (nested-flow-width p)] 773 [(compound-paragraph? p) (compound-paragraph-width p)] 774 [(delayed-block? p) 1] 775 [(eq? p 'cont) 0])) 776 777 (define (table-width p) 778 (let ([blocks (table-blockss p)]) 779 (if (null? blocks) 780 0 781 (let loop ([blocks blocks]) 782 (if (null? (car blocks)) 783 0 784 (+ (apply max 0 (map block-width (map car blocks))) 785 (loop (map cdr blocks)))))))) 786 787 (define (itemization-width p) 788 (apply max 0 (map flow-width (itemization-blockss p)))) 789 790 (define (nested-flow-width p) 791 (+ 4 (apply max 0 (map block-width (nested-flow-blocks p))))) 792 793 (define (compound-paragraph-width p) 794 (apply max 0 (map block-width (compound-paragraph-blocks p)))) 795 796 ;; ---------------------------------------- 797 798 (define (info-key? l) 799 (and (pair? l) 800 (symbol? (car l)) 801 (pair? (cdr l)))) 802 803 (provide info-key?) 804 (provide/contract 805 [part-collected-info (part? resolve-info? . -> . collected-info?)] 806 [collect-put! (collect-info? info-key? any/c . -> . any)] 807 [resolve-get ((or/c part? false/c) resolve-info? info-key? . -> . any)] 808 [resolve-get/tentative ((or/c part? false/c) resolve-info? info-key? . -> . any)] 809 [resolve-get/ext? ((or/c part? false/c) resolve-info? info-key? . -> . any)] 810 [resolve-get/ext-id ((or/c part? false/c) resolve-info? info-key? . -> . any)] 811 [resolve-search (any/c (or/c part? false/c) resolve-info? info-key? . -> . any)] 812 [resolve-get-keys ((or/c part? false/c) resolve-info? (info-key? . -> . any/c) . -> . any/c)])