base.rkt (38398B)
1 #lang scheme/base 2 3 (require "decode.rkt" 4 "core.rkt" 5 "manual-struct.rkt" 6 "decode-struct.rkt" 7 "html-properties.rkt" 8 "tag.rkt" 9 "private/tag.rkt" 10 scheme/list 11 scheme/class 12 racket/contract/base 13 racket/contract/combinator 14 (for-syntax scheme/base)) 15 16 (provide (all-from-out "tag.rkt")) 17 18 ;; ---------------------------------------- 19 20 (define-syntax-rule (title-like-contract) 21 (->* () 22 (#:tag (or/c #f string? (listof string?)) 23 #:tag-prefix (or/c #f string? module-path?) 24 #:style (or/c style? string? symbol? (listof symbol?) #f)) 25 #:rest (listof pre-content?) 26 part-start?)) 27 28 (provide/contract 29 [title (->* () 30 (#:tag (or/c #f string? (listof string?)) 31 #:tag-prefix (or/c #f string? module-path?) 32 #:style (or/c style? string? symbol? (listof symbol?) #f) 33 #:version (or/c string? #f) 34 #:date (or/c string? #f)) 35 #:rest (listof pre-content?) 36 title-decl?)] 37 [section (title-like-contract)] 38 [subsection (title-like-contract)] 39 [subsubsection (title-like-contract)] 40 [subsubsub*section (->* () 41 (#:tag (or/c #f string? (listof string?))) 42 #:rest (listof pre-content?) 43 block?)]) 44 (provide include-section) 45 46 (define (title #:tag [tag #f] #:tag-prefix [prefix #f] #:style [style plain] 47 #:version [version #f] #:date [date #f] 48 . str) 49 (let ([content (decode-content str)]) 50 (make-title-decl (prefix->string prefix) 51 (convert-tag tag content) 52 version 53 (let ([s (convert-part-style 'title style)]) 54 (if date 55 (make-style (style-name s) 56 (cons (make-document-date date) 57 (style-properties s))) 58 s)) 59 content))) 60 61 (define (section #:tag [tag #f] #:tag-prefix [prefix #f] #:style [style plain] 62 . str) 63 (let ([content (decode-content str)]) 64 (make-part-start 0 (prefix->string prefix) 65 (convert-tag tag content) 66 (convert-part-style 'section style) 67 content))) 68 69 (define (subsection #:tag [tag #f] #:tag-prefix [prefix #f] #:style [style plain] 70 . str) 71 (let ([content (decode-content str)]) 72 (make-part-start 1 73 (prefix->string prefix) 74 (convert-tag tag content) 75 (convert-part-style 'subsection style) 76 content))) 77 78 (define (subsubsection #:tag [tag #f] #:tag-prefix [prefix #f] 79 #:style [style plain] . str) 80 (let ([content (decode-content str)]) 81 (make-part-start 2 82 (prefix->string prefix) 83 (convert-tag tag content) 84 (convert-part-style 'subsubsection style) 85 content))) 86 87 (define (subsubsub*section #:tag [tag #f] . str) 88 (let ([content (decode-content str)]) 89 (make-paragraph plain 90 (list 91 (make-element "SSubSubSubSection" 92 (if tag 93 (make-target-element #f content `(part ,tag)) 94 content)))))) 95 96 (define-syntax (include-section stx) 97 (syntax-case stx () 98 [(_ mod) 99 (with-syntax ([doc-from-mod (datum->syntax #'mod 'doc)]) 100 (unless (module-path? (syntax->datum #'mod)) 101 (raise-syntax-error #f 102 "not a module path" 103 stx 104 #'mod)) 105 #'(begin 106 (require (only-in mod [doc-from-mod doc])) 107 doc))])) 108 109 ;; ---------------------------------------- 110 111 (provide/contract 112 [author (->* (content?) () #:rest (listof content?) block?)] 113 [author+email (->* (content? string?) (#:obfuscate? any/c) element?)]) 114 115 (define (author . auths) 116 (make-paragraph 117 (make-style 'author null) 118 (let ([nl (make-element 'newline '("\n"))]) 119 (case (length auths) 120 [(1) auths] 121 [(2) (list (car auths) nl "and " (cadr auths))] 122 [else (let ([r (reverse auths)]) 123 (append (add-between (reverse (cdr r)) 124 (make-element #f (list "," nl))) 125 (list "," nl "and " (car r))))])))) 126 127 (define (author+email name email #:obfuscate? [obfuscate? #f]) 128 (make-element #f 129 (list 130 name 131 " <" 132 (if obfuscate? 133 (regexp-replace* #rx"[.]" 134 (regexp-replace* #rx"@" email " at ") 135 " dot ") 136 (hyperlink (string-append "mailto:" email) email)) 137 ">"))) 138 139 ;; ---------------------------------------- 140 141 (define (item? x) (an-item? x)) 142 143 (define recur-items/c 144 (make-flat-contract 145 #:name 'items/c 146 #:first-order (lambda (x) 147 ((flat-contract-predicate items/c) x)))) 148 149 (define items/c (or/c item? 150 block? 151 (listof recur-items/c) 152 (spliceof recur-items/c))) 153 154 (provide items/c) 155 156 (provide/contract 157 [itemlist (->* () 158 (#:style (or/c style? string? symbol? #f)) 159 #:rest (listof items/c) 160 itemization?)] 161 [item (->* () 162 () 163 #:rest (listof pre-flow?) 164 item?)]) 165 (provide/contract 166 [item? (any/c . -> . boolean?)]) 167 168 (define (itemlist #:style [style plain] . items) 169 (let ([flows (let loop ([items items]) 170 (cond 171 [(null? items) null] 172 [(item? (car items)) (cons (an-item-flow (car items)) 173 (loop (cdr items)))] 174 [(block? (car items)) (cons (list (car items)) 175 (loop (cdr items)))] 176 [(splice? (car items)) 177 (loop (append (splice-run (car items)) 178 (cdr items)))] 179 [else 180 (loop (append (car items) (cdr items)))]))]) 181 (make-itemization (convert-block-style style) flows))) 182 183 (define-struct an-item (flow)) 184 185 (define (item . str) 186 (make-an-item (decode-flow str))) 187 188 ;; ---------------------------------------- 189 190 (provide ._ .__ ~ ?- -~-) 191 192 (define ._ (make-element (make-style "Sendabbrev" null) ".")) 193 (define .__ (make-element (make-style "Sendsentence" null) ".")) 194 (define ~ "\uA0") 195 (define ?- "\uAD") 196 (define -~- "\u2011") 197 198 ;; ---------------------------------------- 199 200 (define elem-like-contract 201 (->* () () #:rest (listof pre-content?) element?)) 202 203 (provide/contract 204 [linebreak (-> element?)] 205 [nonbreaking elem-like-contract] 206 [hspace (-> exact-nonnegative-integer? element?)] 207 [elem (->* () 208 (#:style element-style?) 209 #:rest (listof pre-content?) 210 element?)] 211 [italic elem-like-contract] 212 [bold elem-like-contract] 213 [smaller elem-like-contract] 214 [larger elem-like-contract] 215 [emph elem-like-contract] 216 [tt elem-like-contract] 217 [subscript elem-like-contract] 218 [superscript elem-like-contract] 219 220 [literal (->* (string?) () #:rest (listof string?) element?)] 221 222 [image (->* ((or/c path-string? (cons/c 'collects (listof bytes?)))) 223 (#:scale real? 224 #:suffixes (listof (and/c string? #rx"^[.]")) 225 #:style element-style?) 226 #:rest (listof content?) 227 image-element?)]) 228 229 (define hspace-cache (make-vector 100 #f)) 230 231 (define (hspace n) 232 (if (n . < . (vector-length hspace-cache)) 233 (or (vector-ref hspace-cache n) 234 (let ([h (make-element 'hspace (list (make-string n #\space)))]) 235 (vector-set! hspace-cache n h) 236 h)) 237 (make-element 'hspace (list (make-string n #\space))))) 238 239 (define (linebreak) 240 (make-element 'newline '("\n"))) 241 242 (define (nonbreaking . str) 243 (make-element 'no-break (decode-content str))) 244 245 (define (elem #:style [style plain] . str) 246 (make-element style (decode-content str))) 247 248 (define (italic . str) 249 (make-element 'italic (decode-content str))) 250 251 (define (bold . str) 252 (make-element 'bold (decode-content str))) 253 254 (define (smaller . str) 255 (make-element 'smaller (decode-content str))) 256 257 (define (larger . str) 258 (make-element 'larger (decode-content str))) 259 260 (define (emph . str) 261 (make-element 'emph (decode-content str))) 262 263 (define (tt . str) 264 (let* ([l (decode-content str)] 265 [l (let ([m (and (pair? l) 266 (string? (car l)) 267 (regexp-match-positions #rx"^ +" (car l)))]) 268 (if m 269 (list* (hspace (- (cdar m) (caar m))) 270 (substring (car l) (cdar m)) 271 (cdr l)) 272 l))]) 273 (if (andmap string? l) 274 (make-element 'tt l) 275 (make-element #f (map (lambda (s) 276 (if (or (string? s) (symbol? s)) 277 (make-element 'tt (list s)) 278 s)) 279 l))))) 280 281 (define (span-class classname . str) 282 (make-element classname (decode-content str))) 283 284 (define (subscript . str) 285 (make-element 'subscript (decode-content str))) 286 287 (define (superscript . str) 288 (make-element 'superscript (decode-content str))) 289 290 (define (literal s . strs) 291 (let ([s (apply string-append s strs)]) 292 (make-element #f s))) 293 294 (define (image #:scale [scale 1.0] 295 filename-relative-to-source 296 #:suffixes [suffixes null] 297 #:style [style #f] 298 . alt) 299 (make-image-element style 300 (decode-content alt) 301 filename-relative-to-source 302 suffixes 303 scale)) 304 305 ;; ---------------------------------------- 306 307 (define (cell-spec/c c) 308 (define rc 309 (recursive-contract (or/c c 310 empty 311 (cons/c rc rc)))) 312 rc) 313 314 (provide/contract 315 [para (->* () 316 (#:style (or/c style? string? symbol? #f )) 317 #:rest (listof pre-content?) 318 paragraph?)] 319 [nested (->* () 320 (#:style (or/c style? string? symbol? #f )) 321 #:rest (listof pre-flow?) 322 nested-flow?)] 323 [compound (->* () 324 (#:style (or/c style? string? symbol? #f )) 325 #:rest (listof pre-flow?) 326 compound-paragraph?)] 327 [tabular (->* ((listof (listof (or/c 'cont block? content?)))) 328 (#:style (or/c style? string? symbol? #f) 329 #:sep (or/c content? block? #f) 330 #:column-properties (listof any/c) 331 #:row-properties (listof any/c) 332 #:cell-properties (listof (listof any/c)) 333 #:sep-properties (or/c list? #f)) 334 table?)]) 335 336 (define (convert-block-style style) 337 (cond 338 [(style? style) style] 339 [(or (string? style) (symbol? style)) (make-style style null)] 340 [else plain])) 341 342 (define (nested #:style [style #f] . c) 343 (make-nested-flow (convert-block-style style) 344 (decode-flow c))) 345 346 (define (para #:style [style #f] . c) 347 (make-paragraph (convert-block-style style) 348 (decode-content c))) 349 350 (define (compound #:style [style #f] . c) 351 (make-compound-paragraph (convert-block-style style) 352 (decode-flow c))) 353 354 (define (tabular #:style [style #f] 355 #:sep [sep #f] 356 #:sep-properties [sep-props #f] 357 #:column-properties [column-properties null] 358 #:row-properties [row-properties null] 359 #:cell-properties [cell-properties null] 360 cells) 361 (define (nth-str pos) 362 (case (modulo pos 10) 363 [(1) "st"] 364 [(2) "nd"] 365 [(3) "rd"] 366 [else "th"])) 367 (unless (null? cells) 368 (let ([n (length (car cells))]) 369 (for ([row (in-list (cdr cells))] 370 [pos (in-naturals 2)]) 371 (unless (= n (length row)) 372 (raise-mismatch-error 373 'tabular 374 (format "bad length (~a does not match first row's length ~a) for ~a~a row: " 375 (length row) 376 n 377 pos 378 (nth-str pos)) 379 row))))) 380 (for ([row (in-list cells)] 381 [pos (in-naturals 1)]) 382 (when (and (pair? row) (eq? (car row) 'cont)) 383 (raise-mismatch-error 384 'tabular 385 (format "~a~a row starts with 'cont: " pos (nth-str pos)) 386 row))) 387 (make-table (let ([s (convert-block-style style)]) 388 (define n-orig-cols (if (null? cells) 389 0 390 (length (car cells)))) 391 (define n-cols (if sep 392 (max 0 (sub1 (* n-orig-cols 2))) 393 n-orig-cols)) 394 (define n-rows (length cells)) 395 (unless (null? cells) 396 (when ((length column-properties) . > . n-orig-cols) 397 (raise-mismatch-error 398 'tabular 399 "column properties list is too long: " 400 column-properties))) 401 (when ((length row-properties) . > . n-rows) 402 (raise-mismatch-error 403 'tabular 404 "row properties list is too long: " 405 row-properties)) 406 (when ((length cell-properties) . > . n-rows) 407 (raise-mismatch-error 408 'tabular 409 "cell properties list is too long: " 410 cell-properties)) 411 (unless (null? cells) 412 (for ([row (in-list cell-properties)]) 413 (when ((length row) . > . n-orig-cols) 414 (raise-mismatch-error 415 'tabular 416 "row list within cell properties list is too long: " 417 row)))) 418 ;; Expand given column and cell properties lists to match 419 ;; the dimensions of the given `cells` by duplicating 420 ;; the last element of a list as needed (and ignoring 421 ;; extra elements): 422 (define (make-full-column-properties column-properties) 423 (let loop ([column-properties column-properties] 424 [n 0] 425 [prev null]) 426 (cond 427 [(= n n-cols) null] 428 [(null? column-properties) 429 (if (or (zero? n) (not sep)) 430 (cons prev (loop null (add1 n) prev)) 431 (list* (or sep-props prev) prev (loop null (+ n 2) prev)))] 432 [else 433 (define (to-list v) (if (list? v) v (list v))) 434 (define props (to-list (car column-properties))) 435 (define rest (loop (cdr column-properties) 436 (if (or (zero? n) (not sep)) 437 (add1 n) 438 (+ n 2)) 439 props)) 440 (if (or (zero? n) (not sep)) 441 (cons props rest) 442 (list* (or sep-props prev) props rest))]))) 443 (define full-column-properties 444 (make-full-column-properties column-properties)) 445 (define (make-full-cell-properties cell-properties) 446 (let loop ([cell-properties cell-properties] 447 [n 0] 448 [prev (make-list n-cols null)]) 449 (cond 450 [(= n n-rows) null] 451 [(null? cell-properties) 452 (cons prev (loop null (add1 n) prev))] 453 [else 454 (define props (make-full-column-properties (car cell-properties))) 455 (cons props 456 (loop (cdr cell-properties) 457 (add1 n) 458 props))]))) 459 (define full-cell-properties 460 (for/list ([c-row (in-list (make-full-cell-properties cell-properties))] 461 [r-row (in-list (make-full-cell-properties (map list row-properties)))]) 462 (for/list ([c (in-list c-row)] 463 [r (in-list r-row)]) 464 (append c r)))) 465 (define all-cell-properties 466 (and (or (pair? row-properties) 467 (pair? cell-properties)) 468 (if (null? column-properties) 469 full-cell-properties 470 (for/list ([row (in-list full-cell-properties)]) 471 (for/list ([cell (in-list row)] 472 [col (in-list full-column-properties)]) 473 (append cell col)))))) 474 (define all-column-properties 475 (and (pair? column-properties) 476 full-column-properties)) 477 ;; Will werge `cell-properties` and `column-properties` into 478 ;; `s`. Start by finding any existing `table-columns` 479 ;; and `table-cells` properties with the right number of 480 ;; styles: 481 (define props (style-properties s)) 482 (define tc (and all-column-properties 483 (let ([tc (ormap (lambda (v) (and (table-columns? v) v)) 484 props)]) 485 (if (and tc 486 (= (length (table-columns-styles tc)) 487 n-cols)) 488 tc 489 #f)))) 490 (define tl (and all-cell-properties 491 (let ([tl (ormap (lambda (v) (and (table-cells? v) v)) 492 props)]) 493 (if (and tl 494 (= (length (table-cells-styless tl)) 495 n-rows) 496 (andmap (lambda (cl) 497 (= (length cl) n-cols)) 498 (table-cells-styless tl))) 499 tl 500 #f)))) 501 ;; Merge: 502 (define (cons-maybe v l) (if v (cons v l) l)) 503 (make-style (style-name s) 504 (cons-maybe 505 (and all-column-properties 506 (table-columns 507 (if tc 508 (for/list ([ps (in-list all-column-properties)] 509 [cs (in-list (table-columns-styles tc))]) 510 (make-style (style-name cs) 511 (append ps (style-properties cs)))) 512 (for/list ([ps (in-list all-column-properties)]) 513 (make-style #f ps))))) 514 (cons-maybe 515 (and all-cell-properties 516 (table-cells 517 (if tl 518 (for/list ([pss (in-list all-cell-properties)] 519 [css (in-list (table-cells-styless tl))]) 520 (for/list ([ps (in-list pss)] 521 [cs (in-list css)]) 522 (make-style (style-name cs) 523 (append ps (style-properties cs))))) 524 (for/list ([pss (in-list all-cell-properties)]) 525 (for/list ([ps (in-list pss)]) 526 (make-style #f ps)))))) 527 (remq tc (remq tl props)))))) 528 ;; Process cells: 529 (map (lambda (row) 530 (define (cvt cell) 531 (cond 532 [(eq? cell 'cont) cell] 533 [(block? cell) cell] 534 [else (make-paragraph plain cell)])) 535 (define l (map cvt row)) 536 (if sep 537 (add-between/cont l (cvt sep)) 538 l)) 539 cells))) 540 541 ;; Like `add-between`, but change `sep` to 'cont when 542 ;; adding before a 'cont: 543 (define (add-between/cont l sep) 544 (cond 545 [(null? l) null] 546 [(null? (cdr l)) l] 547 [else 548 (list* (car l) 549 (if (eq? 'cont (cadr l)) 'cont sep) 550 (add-between/cont (cdr l) sep))])) 551 552 ;; ---------------------------------------- 553 554 (provide 555 (contract-out 556 [elemtag (->* ((or/c taglet? generated-tag?)) 557 () 558 #:rest (listof pre-content?) 559 element?)] 560 [elemref (->* ((or/c taglet? generated-tag?)) 561 (#:underline? any/c) 562 #:rest (listof pre-content?) 563 element?)] 564 [secref (->* (string?) 565 (#:doc (or/c #f module-path?) 566 #:tag-prefixes (or/c #f (listof string?)) 567 #:underline? any/c 568 #:link-render-style (or/c #f link-render-style?)) 569 element?)] 570 [Secref (->* (string?) 571 (#:doc module-path? 572 #:tag-prefixes (or/c #f (listof string?)) 573 #:underline? any/c 574 #:link-render-style (or/c #f link-render-style?)) 575 element?)] 576 [seclink (->* (string?) 577 (#:doc module-path? 578 #:tag-prefixes (or/c #f (listof string?)) 579 #:underline? any/c 580 #:indirect? any/c) 581 #:rest (listof pre-content?) 582 element?)] 583 [other-doc (->* (module-path?) 584 (#:underline? any/c 585 #:indirect (or/c #f content?)) 586 element?)])) 587 588 (define (elemtag t . body) 589 (make-target-element #f (decode-content body) `(elem ,t))) 590 (define (elemref #:underline? [u? #t] t . body) 591 (make-link-element (if u? #f "plainlink") (decode-content body) `(elem ,t))) 592 593 (define (secref s #:underline? [u? #t] #:doc [doc #f] #:tag-prefixes [prefix #f] 594 #:link-render-style [link-style #f]) 595 (make-link-element (let ([name (if u? #f "plainlink")]) 596 (if link-style 597 (style name (list link-style)) 598 name)) 599 null 600 (make-section-tag s #:doc doc #:tag-prefixes prefix))) 601 (define (Secref s #:underline? [u? #t] #:doc [doc #f] #:tag-prefixes [prefix #f] 602 #:link-render-style [link-style #f]) 603 (let ([le (secref s #:underline? u? #:doc doc #:tag-prefixes prefix)]) 604 (make-link-element 605 (make-style (element-style le) '(uppercase)) 606 (element-content le) 607 (link-element-tag le)))) 608 609 (define normal-indirect (style #f '(indirect-link))) 610 (define plain-indirect (style "plainlink" '(indirect-link))) 611 612 (define (seclink tag 613 #:doc [doc #f] 614 #:underline? [u? #t] 615 #:tag-prefixes [prefix #f] 616 #:indirect? [indirect? #f] 617 . s) 618 (make-link-element (if indirect? 619 (if u? 620 normal-indirect 621 plain-indirect) 622 (if u? 623 #f 624 "plainlink")) 625 (decode-content s) 626 `(part ,(doc-prefix doc prefix tag)))) 627 628 (define (other-doc doc 629 #:underline? [u? #t] 630 #:indirect [indirect #f]) 631 (if indirect 632 (seclink "top" #:doc doc #:underline? u? #:indirect? #t 633 (list "the " indirect " documentation")) 634 (secref "top" #:doc doc #:underline? u?))) 635 636 ;; ---------------------------------------- 637 638 (provide/contract 639 [hyperlink (->* ((or/c string? path?)) 640 (#:underline? any/c 641 #:style element-style?) 642 #:rest (listof pre-content?) 643 element?)] 644 [url (-> string? element?)] 645 [margin-note (->* () (#:left? any/c) #:rest (listof pre-flow?) block?)] 646 [margin-note* (->* () (#:left? any/c) #:rest (listof pre-content?) element?)] 647 [centered (->* () () #:rest (listof pre-flow?) block?)] 648 [verbatim (->* (content?) (#:indent exact-nonnegative-integer?) #:rest (listof content?) block?)]) 649 650 (define (centered . s) 651 (make-nested-flow (make-style "SCentered" null) (decode-flow s))) 652 653 (define (hyperlink url 654 #:underline? [underline? #t] 655 #:style [style (if underline? #f "plainlink")] 656 . str) 657 (make-element (make-style (if (style? style) 658 (style-name style) 659 style) 660 (cons (make-target-url url) 661 (if (style? style) 662 (style-properties style) 663 null))) 664 (decode-content str))) 665 666 (define (url str) 667 (hyperlink str (make-element 'url str))) 668 669 (define (margin-note #:left? [left? #f] . c) 670 (make-nested-flow 671 (make-style (if left? "refparaleft" "refpara") 672 '(command never-indents)) 673 (list 674 (make-nested-flow 675 (make-style (if left? "refcolumnleft" "refcolumn") 676 null) 677 (list 678 (make-nested-flow 679 (make-style "refcontent" null) 680 (decode-flow c))))))) 681 682 (define (margin-note* #:left? [left? #f] . c) 683 (make-element 684 (make-style (if left? "refelemleft" "refelem") null) 685 (make-element 686 (make-style (if left? "refcolumnleft" "refcolumn") null) 687 (make-element 688 (make-style "refcontent" null) 689 (decode-content c))))) 690 691 (define (verbatim #:indent [i 0] s . more) 692 (define lines 693 ;; Break input into a list of lists, where each inner 694 ;; list is a single line. Break lines on "\n" in the 695 ;; input strings, while non-string content is treated 696 ;; as an element within a line. 697 (let loop ([l (cons s more)] [strs null]) 698 (cond 699 [(null? l) (if (null? strs) 700 null 701 (map 702 list 703 (regexp-split 704 #rx"\n" 705 (apply string-append (reverse strs)))))] 706 [(string? (car l)) 707 (loop (cdr l) (cons (car l) strs))] 708 [else 709 (define post-lines (loop (cdr l) null)) 710 (define pre-lines (loop null strs)) 711 (define-values (post-line rest-lines) 712 (if (null? post-lines) 713 (values null null) 714 (values (car post-lines) (cdr post-lines)))) 715 (define-values (first-lines pre-line) 716 (if (null? pre-lines) 717 (values null null) 718 (values (drop-right pre-lines 1) 719 (last pre-lines)))) 720 (append first-lines 721 (list (append pre-line (list (car l)) post-line)) 722 rest-lines)]))) 723 (define (str->elts str) 724 ;; Convert a single string in a line to typewriter font, 725 ;; and also convert multiple adjacent spaces to `hspace` so 726 ;; that the space is preserved exactly: 727 (let ([spaces (regexp-match-positions #rx"(?:^| ) +" str)]) 728 (if spaces 729 (list* (make-element 'tt (substring str 0 (caar spaces))) 730 (hspace (- (cdar spaces) (caar spaces))) 731 (str->elts (substring str (cdar spaces)))) 732 (list (make-element 'tt (list str)))))) 733 (define (strs->elts line) 734 ;; Convert strings in the line: 735 (apply append (map (lambda (e) 736 (if (string? e) 737 (str->elts e) 738 (list e))) 739 line))) 740 (define indent 741 ;; Add indentation to a line: 742 (if (zero? i) 743 values 744 (let ([hs (hspace i)]) (lambda (line) (cons hs line))))) 745 (define (make-nonempty l) 746 ;; If a line has no content, then add a single space: 747 (if (let loop ([l l]) 748 (cond 749 [(null? l) #t] 750 [(equal? "" l) #t] 751 [(list? l) (andmap loop l)] 752 [(element? l) (loop (element-content l))] 753 [(multiarg-element? l) (loop (multiarg-element-contents l))] 754 [else #f])) 755 (list l (hspace 1)) 756 l)) 757 (define (make-line line) 758 ;; Convert a list of line elements --- a mixture of strings 759 ;; and non-strings --- to a paragraph for the line: 760 (let* ([line (indent (strs->elts line))]) 761 (list (make-paragraph omitable-style (make-nonempty line))))) 762 (make-table (make-style "SVerbatim" null) (map make-line lines))) 763 764 (define omitable-style (make-style 'omitable null)) 765 766 ;; ---------------------------------------- 767 768 ; XXX unknown contract 769 (provide get-index-entries) 770 (provide/contract 771 [index-block (-> delayed-block?)] 772 [index (((or/c string? (listof string?))) () #:rest (listof pre-content?) . ->* . index-element?)] 773 [index* (((listof string?) (listof any/c)) () #:rest (listof pre-content?) . ->* . index-element?)] ; XXX first any/c wrong in docs 774 [as-index (() () #:rest (listof pre-content?) . ->* . index-element?)] 775 [section-index (() () #:rest (listof string?) . ->* . part-index-decl?)] 776 [index-section (() (#:tag (or/c false/c string?)) . ->* . part?)]) 777 778 (define (section-index . elems) 779 (make-part-index-decl (map content->string elems) elems)) 780 781 (define (record-index word-seq element-seq tag content) 782 (make-index-element #f 783 (list (make-target-element #f content `(idx ,tag))) 784 `(idx ,tag) 785 word-seq 786 element-seq 787 #f)) 788 789 (define (index* word-seq content-seq . s) 790 (let ([key (make-generated-tag)]) 791 (record-index (map clean-up-index-string word-seq) 792 content-seq key (decode-content s)))) 793 794 (define (index word-seq . s) 795 (let ([word-seq (if (string? word-seq) (list word-seq) word-seq)]) 796 (apply index* word-seq word-seq s))) 797 798 (define (as-index . s) 799 (let ([key (make-generated-tag)] 800 [content (decode-content s)]) 801 (record-index 802 (list (clean-up-index-string (content->string content))) 803 (if (= 1 (length content)) content (list (make-element #f content))) 804 key 805 content))) 806 807 (define (index-section #:title [title "Index"] #:tag [tag #f]) 808 (make-part #f 809 `((part ,(or tag "doc-index"))) 810 (list title) 811 (make-style 'index '(unnumbered)) 812 null 813 (list (index-block)) 814 null)) 815 816 ;; returns an ordered list of (list tag (text ...) (element ...) index-desc) 817 (define (get-index-entries sec ri) 818 (define (compare-lists xs ys <?) 819 (let loop ([xs xs] [ys ys]) 820 (cond [(and (null? xs) (null? ys)) '=] 821 [(null? xs) '<] 822 [(null? ys) '>] 823 [(<? (car xs) (car ys)) '<] 824 [(<? (car ys) (car xs)) '>] 825 [else (loop (cdr ys) (cdr xs))]))) 826 ;; string-ci<? as a major key, and string<? next, so "Foo" precedes "foo" 827 ;; (define (string*<? s1 s2) 828 ;; (or (string-ci<? s1 s2) 829 ;; (and (not (string-ci<? s2 s1)) (string<? s1 s2)))) 830 (define (get-desc entry) 831 (let ([desc (cadddr entry)]) 832 (cond [(exported-index-desc? desc) 833 (cons 'libs (map (lambda (l) 834 (format "~s" l)) 835 (exported-index-desc-from-libs desc)))] 836 [(module-path-index-desc? desc) '(mod)] 837 [(part-index-desc? desc) '(part)] 838 [(delayed-index-desc? desc) '(delayed)] 839 [else '(#f)]))) 840 ;; parts first, then modules, then bindings, delayed means it's not 841 ;; the last round, and #f means no desc 842 (define desc-order '(part mod libs delayed #f)) 843 ;; this defines an imposed ordering for module names 844 (define lib-order '(#rx"^racket(?:/|$)" #rx"^r.rs(?:/|$)" #rx"^lang(?:/|$)")) 845 (define (lib<? lib1 lib2) 846 (define (lib-level lib) 847 (let loop ([i 0] [rxs lib-order]) 848 (if (or (null? rxs) (regexp-match? (car rxs) lib)) 849 i (loop (add1 i) (cdr rxs))))) 850 (let ([l1 (lib-level lib1)] [l2 (lib-level lib2)]) 851 (if (= l1 l2) (string<? lib1 lib2) (< l1 l2)))) 852 (define (compare-desc e1 e2) 853 (let* ([d1 (get-desc e1)] [d2 (get-desc e2)] 854 [t1 (car d1)] [t2 (car d2)]) 855 (cond [(memq t2 (cdr (memq t1 desc-order))) '<] 856 [(memq t1 (cdr (memq t2 desc-order))) '>] 857 [else (case t1 ; equal to t2 858 [(part) '=] ; will just compare tags 859 [(mod) '=] ; the text fields are the names of the modules 860 [(libs) (compare-lists (cdr d1) (cdr d2) lib<?)] 861 [(delayed) '>] ; dosn't matter, will run again 862 [(#f) '=])]))) 863 (define (entry<? e1 e2) 864 (let ([text1 (cadr e1)] [text2 (cadr e2)]) 865 (case (compare-lists text1 text2 string-ci<?) 866 [(<) #t] [(>) #f] 867 [else (case (compare-desc e1 e2) 868 [(<) #t] [(>) #f] 869 [else (case (compare-lists text1 text2 string<?) 870 [(<) #t] [(>) #f] 871 [else 872 ;; (error 'get-index-entries 873 ;; ;; when this happens, revise this code so 874 ;; ;; ordering will always be deterministic 875 ;; "internal error -- unordered entries: ~e ~e" 876 ;; e1 e2) 877 ;; Instead, just compare the tags 878 (string<? (format "~a" (car e1)) 879 (format "~a" (car e2)))])])]))) 880 (define l null) 881 (hash-for-each 882 (let ([parent (collected-info-parent (part-collected-info sec ri))]) 883 (if parent 884 (collected-info-info (part-collected-info parent ri)) 885 (let ([ci (resolve-info-ci ri)]) 886 ;; Force all xref info: 887 ((collect-info-ext-demand ci) #f ci) 888 (collect-info-ext-ht ci)))) 889 (lambda (k v) 890 (when (and (pair? k) (eq? 'index-entry (car k))) 891 (let ([v (if (known-doc? v) (known-doc-v v) v)]) 892 (set! l (cons (cons (cadr k) v) l)))))) 893 (sort l entry<?)) 894 895 (define (index-block) 896 (define alpha (string->list "ABCDEFGHIJKLMNOPQRSTUVWXYZ")) 897 (define (rows . rows) 898 (make-table (make-style 'index null) 899 (map (lambda (row) 900 (list (make-paragraph plain row))) 901 rows))) 902 (define contents 903 (lambda (renderer sec ri) 904 (define l (get-index-entries sec ri)) 905 (define manual-newlines? (send renderer index-manual-newlines?)) 906 (define alpha-starts (make-hasheq)) 907 (define alpha-row 908 (let loop ([i l] [alpha alpha]) 909 (define (add-letter let l) 910 (list* (make-element "nonavigation" (list (string let))) " " l)) 911 (cond [(null? alpha) null] 912 [(null? i) (add-letter (car alpha) (loop i (cdr alpha)))] 913 [else 914 (let* ([strs (cadr (car i))] 915 [letter (if (or (null? strs) (string=? "" (car strs))) 916 #f 917 (char-upcase (string-ref (car strs) 0)))]) 918 (cond [(not letter) (loop (cdr i) alpha)] 919 [(char-ci>? letter (car alpha)) 920 (add-letter (car alpha) (loop i (cdr alpha)))] 921 [(char-ci=? letter (car alpha)) 922 (hash-set! alpha-starts (car i) letter) 923 (list* (make-element 924 (make-style #f (list (make-target-url (format "#alpha:~a" letter)))) 925 (list (string (car alpha)))) 926 " " 927 (loop (cdr i) (cdr alpha)))] 928 [else (loop (cdr i) alpha)]))]))) 929 (define body 930 (let ([br (if manual-newlines? (make-element 'newline '("\n")) "")]) 931 (map (lambda (i) 932 (let ([e (make-link-element 933 "indexlink" 934 `(,@(add-between (caddr i) ", ") ,br) 935 (car i))]) 936 (cond [(hash-ref alpha-starts i #f) 937 => (lambda (let) 938 (make-element 939 (make-style #f (list 940 (make-url-anchor 941 (format "alpha:~a" (char-upcase let))))) 942 (list e)))] 943 [else e]))) 944 l))) 945 (if manual-newlines? 946 (rows alpha-row '(nbsp) body) 947 (apply rows alpha-row '(nbsp) (map list body))))) 948 (make-delayed-block contents)) 949 950 ;; ---------------------------------------- 951 952 (provide/contract 953 [table-of-contents (-> delayed-block?)] 954 [local-table-of-contents (() 955 (#:style (or/c style? string? symbol? (listof symbol?) #f)) 956 . ->* . delayed-block?)]) 957 958 (define (table-of-contents) 959 (make-delayed-block 960 (lambda (renderer part ri) 961 (send renderer table-of-contents part ri)))) 962 963 (define (local-table-of-contents #:style [style plain]) 964 (make-delayed-block 965 (lambda (renderer part ri) 966 (send renderer local-table-of-contents part ri style))))