977 lines
38 KiB
Racket
977 lines
38 KiB
Racket
#lang scheme/base
|
|
|
|
(require "decode.rkt"
|
|
"core.rkt"
|
|
"manual-struct.rkt"
|
|
"decode-struct.rkt"
|
|
"html-properties.rkt"
|
|
"tag.rkt"
|
|
scheme/list
|
|
scheme/class
|
|
racket/contract/base
|
|
racket/contract/combinator
|
|
(for-syntax scheme/base))
|
|
|
|
(provide (all-from-out "tag.rkt"))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define-syntax-rule (title-like-contract)
|
|
(->* ()
|
|
(#:tag (or/c #f string? (listof string?))
|
|
#:tag-prefix (or/c #f string? module-path?)
|
|
#:style (or/c style? string? symbol? (listof symbol?) #f))
|
|
#:rest (listof pre-content?)
|
|
part-start?))
|
|
|
|
(provide/contract
|
|
[title (->* ()
|
|
(#:tag (or/c #f string? (listof string?))
|
|
#:tag-prefix (or/c #f string? module-path?)
|
|
#:style (or/c style? string? symbol? (listof symbol?) #f)
|
|
#:version (or/c string? #f)
|
|
#:date (or/c string? #f))
|
|
#:rest (listof pre-content?)
|
|
title-decl?)]
|
|
[section (title-like-contract)]
|
|
[subsection (title-like-contract)]
|
|
[subsubsection (title-like-contract)]
|
|
[subsubsub*section (->* ()
|
|
(#:tag (or/c #f string? (listof string?)))
|
|
#:rest (listof pre-content?)
|
|
block?)])
|
|
(provide include-section)
|
|
|
|
(define (gen-tag content)
|
|
(datum-intern-literal
|
|
(regexp-replace* "[^-a-zA-Z0-9_=]" (content->string content) "_")))
|
|
|
|
(define (prefix->string p)
|
|
(and p (if (string? p)
|
|
(datum-intern-literal p)
|
|
(module-path-prefix->string p))))
|
|
|
|
(define (convert-tag tag content)
|
|
(if (list? tag)
|
|
(append-map (lambda (t) (convert-tag t content)) tag)
|
|
`((part ,(or tag (gen-tag content))))))
|
|
|
|
(define (convert-part-style who s)
|
|
(cond
|
|
[(style? s) s]
|
|
[(not s) plain]
|
|
[(string? s) (make-style s null)]
|
|
[(symbol? s) (make-style #f (list s))]
|
|
[(and (list? s) (andmap symbol? s)) (make-style #f s)]
|
|
[else (raise-argument-error who "(or/c style? string? symbol? (listof symbol?) #f)" s)]))
|
|
|
|
(define (title #:tag [tag #f] #:tag-prefix [prefix #f] #:style [style plain]
|
|
#:version [version #f] #:date [date #f]
|
|
. str)
|
|
(let ([content (decode-content str)])
|
|
(make-title-decl (prefix->string prefix)
|
|
(convert-tag tag content)
|
|
version
|
|
(let ([s (convert-part-style 'title style)])
|
|
(if date
|
|
(make-style (style-name s)
|
|
(cons (make-document-date date)
|
|
(style-properties s)))
|
|
s))
|
|
content)))
|
|
|
|
(define (section #:tag [tag #f] #:tag-prefix [prefix #f] #:style [style plain]
|
|
. str)
|
|
(let ([content (decode-content str)])
|
|
(make-part-start 0 (prefix->string prefix)
|
|
(convert-tag tag content)
|
|
(convert-part-style 'section style)
|
|
content)))
|
|
|
|
(define (subsection #:tag [tag #f] #:tag-prefix [prefix #f] #:style [style plain]
|
|
. str)
|
|
(let ([content (decode-content str)])
|
|
(make-part-start 1
|
|
(prefix->string prefix)
|
|
(convert-tag tag content)
|
|
(convert-part-style 'subsection style)
|
|
content)))
|
|
|
|
(define (subsubsection #:tag [tag #f] #:tag-prefix [prefix #f]
|
|
#:style [style plain] . str)
|
|
(let ([content (decode-content str)])
|
|
(make-part-start 2
|
|
(prefix->string prefix)
|
|
(convert-tag tag content)
|
|
(convert-part-style 'subsubsection style)
|
|
content)))
|
|
|
|
(define (subsubsub*section #:tag [tag #f] . str)
|
|
(let ([content (decode-content str)])
|
|
(make-paragraph plain
|
|
(list
|
|
(make-element "SSubSubSubSection"
|
|
(if tag
|
|
(make-target-element #f content `(part ,tag))
|
|
content))))))
|
|
|
|
(define-syntax (include-section stx)
|
|
(syntax-case stx ()
|
|
[(_ mod)
|
|
(with-syntax ([doc-from-mod (datum->syntax #'mod 'doc)])
|
|
(unless (module-path? (syntax->datum #'mod))
|
|
(raise-syntax-error #f
|
|
"not a module path"
|
|
stx
|
|
#'mod))
|
|
#'(begin
|
|
(require (only-in mod [doc-from-mod doc]))
|
|
doc))]))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(provide/contract
|
|
[author (->* (content?) () #:rest (listof content?) block?)]
|
|
[author+email (->* (content? string?) (#:obfuscate? any/c) element?)])
|
|
|
|
(define (author . auths)
|
|
(make-paragraph
|
|
(make-style 'author null)
|
|
(let ([nl (make-element 'newline '("\n"))])
|
|
(case (length auths)
|
|
[(1) auths]
|
|
[(2) (list (car auths) nl "and " (cadr auths))]
|
|
[else (let ([r (reverse auths)])
|
|
(append (add-between (reverse (cdr r))
|
|
(make-element #f (list "," nl)))
|
|
(list "," nl "and " (car r))))]))))
|
|
|
|
(define (author+email name email #:obfuscate? [obfuscate? #f])
|
|
(make-element #f
|
|
(list
|
|
name
|
|
" <"
|
|
(if obfuscate?
|
|
(regexp-replace* #rx"[.]"
|
|
(regexp-replace* #rx"@" email " at ")
|
|
" dot ")
|
|
(hyperlink (string-append "mailto:" email) email))
|
|
">")))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define (item? x) (an-item? x))
|
|
|
|
(define recur-items/c
|
|
(make-flat-contract
|
|
#:name 'items/c
|
|
#:first-order (lambda (x)
|
|
((flat-contract-predicate items/c) x))))
|
|
|
|
(define items/c (or/c item?
|
|
block?
|
|
(listof recur-items/c)
|
|
(spliceof recur-items/c)))
|
|
|
|
(provide items/c)
|
|
|
|
(provide/contract
|
|
[itemlist (->* ()
|
|
(#:style (or/c style? string? symbol? #f))
|
|
#:rest (listof items/c)
|
|
itemization?)]
|
|
[item (->* ()
|
|
()
|
|
#:rest (listof pre-flow?)
|
|
item?)])
|
|
(provide/contract
|
|
[item? (any/c . -> . boolean?)])
|
|
|
|
(define (itemlist #:style [style plain] . items)
|
|
(let ([flows (let loop ([items items])
|
|
(cond
|
|
[(null? items) null]
|
|
[(item? (car items)) (cons (an-item-flow (car items))
|
|
(loop (cdr items)))]
|
|
[(block? (car items)) (cons (list (car items))
|
|
(loop (cdr items)))]
|
|
[(splice? (car items))
|
|
(loop (append (splice-run (car items))
|
|
(cdr items)))]
|
|
[else
|
|
(loop (append (car items) (cdr items)))]))])
|
|
(make-itemization (convert-block-style style) flows)))
|
|
|
|
(define-struct an-item (flow))
|
|
|
|
(define (item . str)
|
|
(make-an-item (decode-flow str)))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(provide ._ .__ ~ ?- -~-)
|
|
|
|
(define ._ (make-element (make-style "Sendabbrev" null) "."))
|
|
(define .__ (make-element (make-style "Sendsentence" null) "."))
|
|
(define ~ "\uA0")
|
|
(define ?- "\uAD")
|
|
(define -~- "\u2011")
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define elem-like-contract
|
|
(->* () () #:rest (listof pre-content?) element?))
|
|
|
|
(provide/contract
|
|
[linebreak (-> element?)]
|
|
[nonbreaking elem-like-contract]
|
|
[hspace (-> exact-nonnegative-integer? element?)]
|
|
[elem (->* ()
|
|
(#:style element-style?)
|
|
#:rest (listof pre-content?)
|
|
element?)]
|
|
[italic elem-like-contract]
|
|
[bold elem-like-contract]
|
|
[smaller elem-like-contract]
|
|
[larger elem-like-contract]
|
|
[emph elem-like-contract]
|
|
[tt elem-like-contract]
|
|
[subscript elem-like-contract]
|
|
[superscript elem-like-contract]
|
|
|
|
[literal (->* (string?) () #:rest (listof string?) element?)]
|
|
|
|
[image (->* ((or/c path-string? (cons/c 'collects (listof bytes?))))
|
|
(#:scale real?
|
|
#:suffixes (listof (and/c string? #rx"^[.]"))
|
|
#:style element-style?)
|
|
#:rest (listof content?)
|
|
image-element?)])
|
|
|
|
(define hspace-cache (make-vector 100 #f))
|
|
|
|
(define (hspace n)
|
|
(if (n . < . (vector-length hspace-cache))
|
|
(or (vector-ref hspace-cache n)
|
|
(let ([h (make-element 'hspace (list (make-string n #\space)))])
|
|
(vector-set! hspace-cache n h)
|
|
h))
|
|
(make-element 'hspace (list (make-string n #\space)))))
|
|
|
|
(define (linebreak)
|
|
(make-element 'newline '("\n")))
|
|
|
|
(define (nonbreaking . str)
|
|
(make-element 'no-break (decode-content str)))
|
|
|
|
(define (elem #:style [style plain] . str)
|
|
(make-element style (decode-content str)))
|
|
|
|
(define (italic . str)
|
|
(make-element 'italic (decode-content str)))
|
|
|
|
(define (bold . str)
|
|
(make-element 'bold (decode-content str)))
|
|
|
|
(define (smaller . str)
|
|
(make-element 'smaller (decode-content str)))
|
|
|
|
(define (larger . str)
|
|
(make-element 'larger (decode-content str)))
|
|
|
|
(define (emph . str)
|
|
(make-element 'italic (decode-content str)))
|
|
|
|
(define (tt . str)
|
|
(let* ([l (decode-content str)]
|
|
[l (let ([m (and (pair? l)
|
|
(string? (car l))
|
|
(regexp-match-positions #rx"^ +" (car l)))])
|
|
(if m
|
|
(list* (hspace (- (cdar m) (caar m)))
|
|
(substring (car l) (cdar m))
|
|
(cdr l))
|
|
l))])
|
|
(if (andmap string? l)
|
|
(make-element 'tt l)
|
|
(make-element #f (map (lambda (s)
|
|
(if (or (string? s) (symbol? s))
|
|
(make-element 'tt (list s))
|
|
s))
|
|
l)))))
|
|
|
|
(define (span-class classname . str)
|
|
(make-element classname (decode-content str)))
|
|
|
|
(define (subscript . str)
|
|
(make-element 'subscript (decode-content str)))
|
|
|
|
(define (superscript . str)
|
|
(make-element 'superscript (decode-content str)))
|
|
|
|
(define (literal s . strs)
|
|
(let ([s (apply string-append s strs)])
|
|
(make-element #f s)))
|
|
|
|
(define (image #:scale [scale 1.0]
|
|
filename-relative-to-source
|
|
#:suffixes [suffixes null]
|
|
#:style [style #f]
|
|
. alt)
|
|
(make-image-element style
|
|
(decode-content alt)
|
|
filename-relative-to-source
|
|
suffixes
|
|
scale))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define (cell-spec/c c)
|
|
(define rc
|
|
(recursive-contract (or/c c
|
|
empty
|
|
(cons/c rc rc))))
|
|
rc)
|
|
|
|
(provide/contract
|
|
[para (->* ()
|
|
(#:style (or/c style? string? symbol? #f ))
|
|
#:rest (listof pre-content?)
|
|
paragraph?)]
|
|
[nested (->* ()
|
|
(#:style (or/c style? string? symbol? #f ))
|
|
#:rest (listof pre-flow?)
|
|
nested-flow?)]
|
|
[compound (->* ()
|
|
(#:style (or/c style? string? symbol? #f ))
|
|
#:rest (listof pre-flow?)
|
|
compound-paragraph?)]
|
|
[tabular (->* ((listof (listof (or/c 'cont block? content?))))
|
|
(#:style (or/c style? string? symbol? #f)
|
|
#:sep (or/c content? block? #f)
|
|
#:column-properties (listof any/c)
|
|
#:row-properties (listof any/c)
|
|
#:cell-properties (listof (listof any/c)))
|
|
table?)])
|
|
|
|
(define (convert-block-style style)
|
|
(cond
|
|
[(style? style) style]
|
|
[(or (string? style) (symbol? style)) (make-style style null)]
|
|
[else plain]))
|
|
|
|
(define (nested #:style [style #f] . c)
|
|
(make-nested-flow (convert-block-style style)
|
|
(decode-flow c)))
|
|
|
|
(define (para #:style [style #f] . c)
|
|
(make-paragraph (convert-block-style style)
|
|
(decode-content c)))
|
|
|
|
(define (compound #:style [style #f] . c)
|
|
(make-compound-paragraph (convert-block-style style)
|
|
(decode-flow c)))
|
|
|
|
(define (tabular #:style [style #f]
|
|
#:sep [sep #f]
|
|
#:column-properties [column-properties null]
|
|
#:row-properties [row-properties null]
|
|
#:cell-properties [cell-properties null]
|
|
cells)
|
|
(define (nth-str pos)
|
|
(case (modulo pos 10)
|
|
[(1) "st"]
|
|
[(2) "nd"]
|
|
[(3) "rd"]
|
|
[else "th"]))
|
|
(unless (null? cells)
|
|
(let ([n (length (car cells))])
|
|
(for ([row (in-list (cdr cells))]
|
|
[pos (in-naturals 2)])
|
|
(unless (= n (length row))
|
|
(raise-mismatch-error
|
|
'tabular
|
|
(format "bad length (~a does not match first row's length ~a) for ~a~a row: "
|
|
(length row)
|
|
n
|
|
pos
|
|
(nth-str pos))
|
|
row)))))
|
|
(for ([row (in-list cells)]
|
|
[pos (in-naturals 1)])
|
|
(when (and (pair? row) (eq? (car row) 'cont))
|
|
(raise-mismatch-error
|
|
'tabular
|
|
(format "~a~a row starts with 'cont: " pos (nth-str pos))
|
|
row)))
|
|
(make-table (let ([s (convert-block-style style)])
|
|
(define n-orig-cols (if (null? cells)
|
|
0
|
|
(length (car cells))))
|
|
(define n-cols (if sep
|
|
(max 0 (sub1 (* n-orig-cols 2)))
|
|
n-orig-cols))
|
|
(define n-rows (length cells))
|
|
(unless (null? cells)
|
|
(when ((length column-properties) . > . n-orig-cols)
|
|
(raise-mismatch-error
|
|
'tabular
|
|
"column properties list is too long: "
|
|
column-properties)))
|
|
(when ((length row-properties) . > . n-rows)
|
|
(raise-mismatch-error
|
|
'tabular
|
|
"row properties list is too long: "
|
|
row-properties))
|
|
(when ((length cell-properties) . > . n-rows)
|
|
(raise-mismatch-error
|
|
'tabular
|
|
"cell properties list is too long: "
|
|
cell-properties))
|
|
(unless (null? cells)
|
|
(for ([row (in-list cell-properties)])
|
|
(when ((length row) . > . n-orig-cols)
|
|
(raise-mismatch-error
|
|
'tabular
|
|
"row list within cell properties list is too long: "
|
|
row))))
|
|
;; Expand given column and cell properties lists to match
|
|
;; the dimensions of the given `cells` by duplicating
|
|
;; the last element of a list as needed (and ignoring
|
|
;; extra elements):
|
|
(define (make-full-column-properties column-properties)
|
|
(let loop ([column-properties column-properties]
|
|
[n 0]
|
|
[prev null])
|
|
(cond
|
|
[(= n n-cols) null]
|
|
[(null? column-properties)
|
|
(if (or (zero? n) (not sep))
|
|
(cons prev (loop null (add1 n) prev))
|
|
(list* prev prev (loop null (+ n 2) prev)))]
|
|
[else
|
|
(define (to-list v) (if (list? v) v (list v)))
|
|
(define props (to-list (car column-properties)))
|
|
(define rest (loop (cdr column-properties)
|
|
(if (or (zero? n) (not sep))
|
|
(add1 n)
|
|
(+ n 2))
|
|
props))
|
|
(if (or (zero? n) (not sep))
|
|
(cons props rest)
|
|
(list* null props rest))])))
|
|
(define full-column-properties
|
|
(make-full-column-properties column-properties))
|
|
(define (make-full-cell-properties cell-properties)
|
|
(let loop ([cell-properties cell-properties]
|
|
[n 0]
|
|
[prev (make-list n-cols null)])
|
|
(cond
|
|
[(= n n-rows) null]
|
|
[(null? cell-properties)
|
|
(cons prev (loop null (add1 n) prev))]
|
|
[else
|
|
(define props (make-full-column-properties (car cell-properties)))
|
|
(cons props
|
|
(loop (cdr cell-properties)
|
|
(add1 n)
|
|
props))])))
|
|
(define full-cell-properties
|
|
(for/list ([c-row (in-list (make-full-cell-properties cell-properties))]
|
|
[r-row (in-list (make-full-cell-properties (map list row-properties)))])
|
|
(for/list ([c (in-list c-row)]
|
|
[r (in-list r-row)])
|
|
(append c r))))
|
|
(define all-cell-properties
|
|
(and (or (pair? row-properties)
|
|
(pair? cell-properties))
|
|
(if (null? column-properties)
|
|
full-cell-properties
|
|
(for/list ([row (in-list full-cell-properties)])
|
|
(for/list ([cell (in-list row)]
|
|
[col (in-list full-column-properties)])
|
|
(append cell col))))))
|
|
(define all-column-properties
|
|
(and (pair? column-properties)
|
|
full-column-properties))
|
|
;; Will werge `cell-properties` and `column-properties` into
|
|
;; `s`. Start by finding any existing `table-columns`
|
|
;; and `table-cells` properties with the right number of
|
|
;; styles:
|
|
(define props (style-properties s))
|
|
(define tc (and all-column-properties
|
|
(let ([tc (ormap (lambda (v) (and (table-columns? v) v))
|
|
props)])
|
|
(if (and tc
|
|
(= (length (table-columns-styles tc))
|
|
n-cols))
|
|
tc
|
|
#f))))
|
|
(define tl (and all-cell-properties
|
|
(let ([tl (ormap (lambda (v) (and (table-cells? v) v))
|
|
props)])
|
|
(if (and tl
|
|
(= (length (table-cells-styless tl))
|
|
n-rows)
|
|
(andmap (lambda (cl)
|
|
(= (length cl) n-cols))
|
|
(table-cells-styless tl)))
|
|
tl
|
|
#f))))
|
|
;; Merge:
|
|
(define (cons-maybe v l) (if v (cons v l) l))
|
|
(make-style (style-name s)
|
|
(cons-maybe
|
|
(and all-column-properties
|
|
(table-columns
|
|
(if tc
|
|
(for/list ([ps (in-list all-column-properties)]
|
|
[cs (in-list (table-columns-styles tc))])
|
|
(make-style (style-name cs)
|
|
(append ps (style-properties cs))))
|
|
(for/list ([ps (in-list all-column-properties)])
|
|
(make-style #f ps)))))
|
|
(cons-maybe
|
|
(and all-cell-properties
|
|
(table-cells
|
|
(if tl
|
|
(for/list ([pss (in-list all-cell-properties)]
|
|
[css (in-list (table-cells-styless tl))])
|
|
(for/list ([ps (in-list pss)]
|
|
[cs (in-list css)])
|
|
(make-style (style-name cs)
|
|
(append ps (style-properties cs)))))
|
|
(for/list ([pss (in-list all-cell-properties)])
|
|
(for/list ([ps (in-list pss)])
|
|
(make-style #f ps))))))
|
|
(remq tc (remq tl props))))))
|
|
;; Process cells:
|
|
(map (lambda (row)
|
|
(define (cvt cell)
|
|
(cond
|
|
[(eq? cell 'cont) cell]
|
|
[(block? cell) cell]
|
|
[else (make-paragraph plain cell)]))
|
|
(define l (map cvt row))
|
|
(if sep
|
|
(add-between/cont l (cvt sep))
|
|
l))
|
|
cells)))
|
|
|
|
;; Like `add-between`, but change `sep` to 'cont when
|
|
;; adding before a 'cont:
|
|
(define (add-between/cont l sep)
|
|
(cond
|
|
[(null? l) null]
|
|
[(null? (cdr l)) l]
|
|
[else
|
|
(list* (car l)
|
|
(if (eq? 'cont (cadr l)) 'cont sep)
|
|
(add-between/cont (cdr l) sep))]))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(provide/contract
|
|
[elemtag (->* ((or/c tag? string?))
|
|
()
|
|
#:rest (listof pre-content?)
|
|
element?)]
|
|
[elemref (->* ((or/c tag? string?))
|
|
(#:underline? any/c)
|
|
#:rest (listof pre-content?)
|
|
element?)]
|
|
[secref (->* (string?)
|
|
(#:doc module-path?
|
|
#:tag-prefixes (or/c #f (listof string?))
|
|
#:underline? any/c)
|
|
element?)]
|
|
[Secref (->* (string?)
|
|
(#:doc module-path?
|
|
#:tag-prefixes (or/c #f (listof string?))
|
|
#:underline? any/c)
|
|
element?)]
|
|
[seclink (->* (string?)
|
|
(#:doc module-path?
|
|
#:tag-prefixes (or/c #f (listof string?))
|
|
#:underline? any/c
|
|
#:indirect? any/c)
|
|
#:rest (listof pre-content?)
|
|
element?)]
|
|
[other-doc (->* (module-path?)
|
|
(#:underline? any/c
|
|
#:indirect (or/c #f content?))
|
|
element?)])
|
|
|
|
(define (elemtag t . body)
|
|
(make-target-element #f (decode-content body) `(elem ,t)))
|
|
(define (elemref #:underline? [u? #t] t . body)
|
|
(make-link-element (if u? #f "plainlink") (decode-content body) `(elem ,t)))
|
|
|
|
(define (secref s #:underline? [u? #t] #:doc [doc #f] #:tag-prefixes [prefix #f])
|
|
(make-link-element (if u? #f "plainlink") null (make-section-tag s #:doc doc #:tag-prefixes prefix)))
|
|
(define (Secref s #:underline? [u? #t] #:doc [doc #f] #:tag-prefixes [prefix #f])
|
|
(let ([le (secref s #:underline? u? #:doc doc #:tag-prefixes prefix)])
|
|
(make-link-element
|
|
(make-style (element-style le) '(uppercase))
|
|
(element-content le)
|
|
(link-element-tag le))))
|
|
|
|
(define normal-indirect (style #f '(indirect-link)))
|
|
(define plain-indirect (style "plainlink" '(indirect-link)))
|
|
|
|
(define (seclink tag
|
|
#:doc [doc #f]
|
|
#:underline? [u? #t]
|
|
#:tag-prefixes [prefix #f]
|
|
#:indirect? [indirect? #f]
|
|
. s)
|
|
(make-link-element (if indirect?
|
|
(if u?
|
|
normal-indirect
|
|
plain-indirect)
|
|
(if u?
|
|
#f
|
|
"plainlink"))
|
|
(decode-content s)
|
|
`(part ,(doc-prefix doc prefix tag))))
|
|
|
|
(define (other-doc doc
|
|
#:underline? [u? #t]
|
|
#:indirect [indirect #f])
|
|
(if indirect
|
|
(seclink "top" #:doc doc #:underline? u? #:indirect? #t
|
|
(list "the " indirect " documentation"))
|
|
(secref "top" #:doc doc #:underline? u?)))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(provide/contract
|
|
[hyperlink (->* ((or/c string? path?))
|
|
(#:underline? any/c
|
|
#:style element-style?)
|
|
#:rest (listof pre-content?)
|
|
element?)]
|
|
[url (-> string? element?)]
|
|
[margin-note (->* () (#:left? any/c) #:rest (listof pre-flow?) block?)]
|
|
[margin-note* (->* () (#:left? any/c) #:rest (listof pre-content?) element?)]
|
|
[centered (->* () () #:rest (listof pre-flow?) block?)]
|
|
[verbatim (->* (content?) (#:indent exact-nonnegative-integer?) #:rest (listof content?) block?)])
|
|
|
|
(define (centered . s)
|
|
(make-nested-flow (make-style "SCentered" null) (decode-flow s)))
|
|
|
|
(define (hyperlink url
|
|
#:underline? [underline? #t]
|
|
#:style [style (if underline? #f "plainlink")]
|
|
. str)
|
|
(make-element (make-style (if (style? style)
|
|
(style-name style)
|
|
style)
|
|
(cons (make-target-url url)
|
|
(if (style? style)
|
|
(style-properties style)
|
|
null)))
|
|
(decode-content str)))
|
|
|
|
(define (url str)
|
|
(hyperlink str (make-element 'url str)))
|
|
|
|
(define (margin-note #:left? [left? #f] . c)
|
|
(make-nested-flow
|
|
(make-style (if left? "refparaleft" "refpara")
|
|
'(command never-indents))
|
|
(list
|
|
(make-nested-flow
|
|
(make-style (if left? "refcolumnleft" "refcolumn")
|
|
null)
|
|
(list
|
|
(make-nested-flow
|
|
(make-style "refcontent" null)
|
|
(decode-flow c)))))))
|
|
|
|
(define (margin-note* #:left? [left? #f] . c)
|
|
(make-element
|
|
(make-style (if left? "refelemleft" "refelem") null)
|
|
(make-element
|
|
(make-style (if left? "refcolumnleft" "refcolumn") null)
|
|
(make-element
|
|
(make-style "refcontent" null)
|
|
(decode-content c)))))
|
|
|
|
(define (verbatim #:indent [i 0] s . more)
|
|
(define lines
|
|
;; Break input into a list of lists, where each inner
|
|
;; list is a single line. Break lines on "\n" in the
|
|
;; input strings, while non-string content is treated
|
|
;; as an element within a line.
|
|
(let loop ([l (cons s more)] [strs null])
|
|
(cond
|
|
[(null? l) (if (null? strs)
|
|
null
|
|
(map
|
|
list
|
|
(regexp-split
|
|
#rx"\n"
|
|
(apply string-append (reverse strs)))))]
|
|
[(string? (car l))
|
|
(loop (cdr l) (cons (car l) strs))]
|
|
[else
|
|
(define post-lines (loop (cdr l) null))
|
|
(define pre-lines (loop null strs))
|
|
(define-values (post-line rest-lines)
|
|
(if (null? post-lines)
|
|
(values null null)
|
|
(values (car post-lines) (cdr post-lines))))
|
|
(define-values (first-lines pre-line)
|
|
(if (null? pre-lines)
|
|
(values null null)
|
|
(values (drop-right pre-lines 1)
|
|
(last pre-lines))))
|
|
(append first-lines
|
|
(list (append pre-line (list (car l)) post-line))
|
|
rest-lines)])))
|
|
(define (str->elts str)
|
|
;; Convert a single string in a line to typewriter font,
|
|
;; and also convert multiple adjacent spaces to `hspace` so
|
|
;; that the space is preserved exactly:
|
|
(let ([spaces (regexp-match-positions #rx"(?:^| ) +" str)])
|
|
(if spaces
|
|
(list* (make-element 'tt (substring str 0 (caar spaces)))
|
|
(hspace (- (cdar spaces) (caar spaces)))
|
|
(str->elts (substring str (cdar spaces))))
|
|
(list (make-element 'tt (list str))))))
|
|
(define (strs->elts line)
|
|
;; Convert strings in the line:
|
|
(apply append (map (lambda (e)
|
|
(if (string? e)
|
|
(str->elts e)
|
|
(list e)))
|
|
line)))
|
|
(define indent
|
|
;; Add indentation to a line:
|
|
(if (zero? i)
|
|
values
|
|
(let ([hs (hspace i)]) (lambda (line) (cons hs line)))))
|
|
(define (make-nonempty l)
|
|
;; If a line has no content, then add a single space:
|
|
(if (let loop ([l l])
|
|
(cond
|
|
[(null? l) #t]
|
|
[(equal? "" l) #t]
|
|
[(list? l) (andmap loop l)]
|
|
[(element? l) (loop (element-content l))]
|
|
[(multiarg-element? l) (loop (multiarg-element-contents l))]
|
|
[else #f]))
|
|
(list l (hspace 1))
|
|
l))
|
|
(define (make-line line)
|
|
;; Convert a list of line elements --- a mixture of strings
|
|
;; and non-strings --- to a paragraph for the line:
|
|
(let* ([line (indent (strs->elts line))])
|
|
(list (make-paragraph omitable-style (make-nonempty line)))))
|
|
(make-table plain (map make-line lines)))
|
|
|
|
(define omitable-style (make-style 'omitable null))
|
|
|
|
;; ----------------------------------------
|
|
|
|
; XXX unknown contract
|
|
(provide get-index-entries)
|
|
(provide/contract
|
|
[index-block (-> delayed-block?)]
|
|
[index (((or/c string? (listof string?))) () #:rest (listof pre-content?) . ->* . index-element?)]
|
|
[index* (((listof string?) (listof any/c)) () #:rest (listof pre-content?) . ->* . index-element?)] ; XXX first any/c wrong in docs
|
|
[as-index (() () #:rest (listof pre-content?) . ->* . index-element?)]
|
|
[section-index (() () #:rest (listof string?) . ->* . part-index-decl?)]
|
|
[index-section (() (#:tag (or/c false/c string?)) . ->* . part?)])
|
|
|
|
(define (section-index . elems)
|
|
(make-part-index-decl (map content->string elems) elems))
|
|
|
|
(define (record-index word-seq element-seq tag content)
|
|
(make-index-element #f
|
|
(list (make-target-element #f content `(idx ,tag)))
|
|
`(idx ,tag)
|
|
word-seq
|
|
element-seq
|
|
#f))
|
|
|
|
(define (index* word-seq content-seq . s)
|
|
(let ([key (make-generated-tag)])
|
|
(record-index (map clean-up-index-string word-seq)
|
|
content-seq key (decode-content s))))
|
|
|
|
(define (index word-seq . s)
|
|
(let ([word-seq (if (string? word-seq) (list word-seq) word-seq)])
|
|
(apply index* word-seq word-seq s)))
|
|
|
|
(define (as-index . s)
|
|
(let ([key (make-generated-tag)]
|
|
[content (decode-content s)])
|
|
(record-index
|
|
(list (clean-up-index-string (content->string content)))
|
|
(if (= 1 (length content)) content (list (make-element #f content)))
|
|
key
|
|
content)))
|
|
|
|
(define (index-section #:title [title "Index"] #:tag [tag #f])
|
|
(make-part #f
|
|
`((part ,(or tag "doc-index")))
|
|
(list title)
|
|
(make-style 'index '(unnumbered))
|
|
null
|
|
(list (index-block))
|
|
null))
|
|
|
|
;; returns an ordered list of (list tag (text ...) (element ...) index-desc)
|
|
(define (get-index-entries sec ri)
|
|
(define (compare-lists xs ys <?)
|
|
(let loop ([xs xs] [ys ys])
|
|
(cond [(and (null? xs) (null? ys)) '=]
|
|
[(null? xs) '<]
|
|
[(null? ys) '>]
|
|
[(<? (car xs) (car ys)) '<]
|
|
[(<? (car ys) (car xs)) '>]
|
|
[else (loop (cdr ys) (cdr xs))])))
|
|
;; string-ci<? as a major key, and string<? next, so "Foo" precedes "foo"
|
|
;; (define (string*<? s1 s2)
|
|
;; (or (string-ci<? s1 s2)
|
|
;; (and (not (string-ci<? s2 s1)) (string<? s1 s2))))
|
|
(define (get-desc entry)
|
|
(let ([desc (cadddr entry)])
|
|
(cond [(exported-index-desc? desc)
|
|
(cons 'libs (map (lambda (l)
|
|
(format "~s" l))
|
|
(exported-index-desc-from-libs desc)))]
|
|
[(module-path-index-desc? desc) '(mod)]
|
|
[(part-index-desc? desc) '(part)]
|
|
[(delayed-index-desc? desc) '(delayed)]
|
|
[else '(#f)])))
|
|
;; parts first, then modules, then bindings, delayed means it's not
|
|
;; the last round, and #f means no desc
|
|
(define desc-order '(part mod libs delayed #f))
|
|
;; this defines an imposed ordering for module names
|
|
(define lib-order '(#rx"^racket(?:/|$)" #rx"^r.rs(?:/|$)" #rx"^lang(?:/|$)"))
|
|
(define (lib<? lib1 lib2)
|
|
(define (lib-level lib)
|
|
(let loop ([i 0] [rxs lib-order])
|
|
(if (or (null? rxs) (regexp-match? (car rxs) lib))
|
|
i (loop (add1 i) (cdr rxs)))))
|
|
(let ([l1 (lib-level lib1)] [l2 (lib-level lib2)])
|
|
(if (= l1 l2) (string<? lib1 lib2) (< l1 l2))))
|
|
(define (compare-desc e1 e2)
|
|
(let* ([d1 (get-desc e1)] [d2 (get-desc e2)]
|
|
[t1 (car d1)] [t2 (car d2)])
|
|
(cond [(memq t2 (cdr (memq t1 desc-order))) '<]
|
|
[(memq t1 (cdr (memq t2 desc-order))) '>]
|
|
[else (case t1 ; equal to t2
|
|
[(part) '=] ; will just compare tags
|
|
[(mod) '=] ; the text fields are the names of the modules
|
|
[(libs) (compare-lists (cdr d1) (cdr d2) lib<?)]
|
|
[(delayed) '>] ; dosn't matter, will run again
|
|
[(#f) '=])])))
|
|
(define (entry<? e1 e2)
|
|
(let ([text1 (cadr e1)] [text2 (cadr e2)])
|
|
(case (compare-lists text1 text2 string-ci<?)
|
|
[(<) #t] [(>) #f]
|
|
[else (case (compare-desc e1 e2)
|
|
[(<) #t] [(>) #f]
|
|
[else (case (compare-lists text1 text2 string<?)
|
|
[(<) #t] [(>) #f]
|
|
[else
|
|
;; (error 'get-index-entries
|
|
;; ;; when this happens, revise this code so
|
|
;; ;; ordering will always be deterministic
|
|
;; "internal error -- unordered entries: ~e ~e"
|
|
;; e1 e2)
|
|
;; Instead, just compare the tags
|
|
(string<? (format "~a" (car e1))
|
|
(format "~a" (car e2)))])])])))
|
|
(define l null)
|
|
(hash-for-each
|
|
(let ([parent (collected-info-parent (part-collected-info sec ri))])
|
|
(if parent
|
|
(collected-info-info (part-collected-info parent ri))
|
|
(let ([ci (resolve-info-ci ri)])
|
|
;; Force all xref info:
|
|
((collect-info-ext-demand ci) #f ci)
|
|
(collect-info-ext-ht ci))))
|
|
(lambda (k v)
|
|
(when (and (pair? k) (eq? 'index-entry (car k)))
|
|
(let ([v (if (known-doc? v) (known-doc-v v) v)])
|
|
(set! l (cons (cons (cadr k) v) l))))))
|
|
(sort l entry<?))
|
|
|
|
(define (index-block)
|
|
(define alpha (string->list "ABCDEFGHIJKLMNOPQRSTUVWXYZ"))
|
|
(define (rows . rows)
|
|
(make-table (make-style 'index null)
|
|
(map (lambda (row)
|
|
(list (make-paragraph plain row)))
|
|
rows)))
|
|
(define contents
|
|
(lambda (renderer sec ri)
|
|
(define l (get-index-entries sec ri))
|
|
(define manual-newlines? (send renderer index-manual-newlines?))
|
|
(define alpha-starts (make-hasheq))
|
|
(define alpha-row
|
|
(let loop ([i l] [alpha alpha])
|
|
(define (add-letter let l)
|
|
(list* (make-element "nonavigation" (list (string let))) " " l))
|
|
(cond [(null? alpha) null]
|
|
[(null? i) (add-letter (car alpha) (loop i (cdr alpha)))]
|
|
[else
|
|
(let* ([strs (cadr (car i))]
|
|
[letter (if (or (null? strs) (string=? "" (car strs)))
|
|
#f
|
|
(char-upcase (string-ref (car strs) 0)))])
|
|
(cond [(not letter) (loop (cdr i) alpha)]
|
|
[(char-ci>? letter (car alpha))
|
|
(add-letter (car alpha) (loop i (cdr alpha)))]
|
|
[(char-ci=? letter (car alpha))
|
|
(hash-set! alpha-starts (car i) letter)
|
|
(list* (make-element
|
|
(make-style #f (list (make-target-url (format "#alpha:~a" letter))))
|
|
(list (string (car alpha))))
|
|
" "
|
|
(loop (cdr i) (cdr alpha)))]
|
|
[else (loop (cdr i) alpha)]))])))
|
|
(define body
|
|
(let ([br (if manual-newlines? (make-element 'newline '("\n")) "")])
|
|
(map (lambda (i)
|
|
(let ([e (make-link-element
|
|
"indexlink"
|
|
`(,@(add-between (caddr i) ", ") ,br)
|
|
(car i))])
|
|
(cond [(hash-ref alpha-starts i #f)
|
|
=> (lambda (let)
|
|
(make-element
|
|
(make-style #f (list
|
|
(make-url-anchor
|
|
(format "alpha:~a" (char-upcase let)))))
|
|
(list e)))]
|
|
[else e])))
|
|
l)))
|
|
(if manual-newlines?
|
|
(rows alpha-row '(nbsp) body)
|
|
(apply rows alpha-row '(nbsp) (map list body)))))
|
|
(make-delayed-block contents))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(provide/contract
|
|
[table-of-contents (-> delayed-block?)]
|
|
[local-table-of-contents (()
|
|
(#:style (or/c style? string? symbol? (listof symbol?) #f))
|
|
. ->* . delayed-block?)])
|
|
|
|
(define (table-of-contents)
|
|
(make-delayed-block
|
|
(lambda (renderer part ri)
|
|
(send renderer table-of-contents part ri))))
|
|
|
|
(define (local-table-of-contents #:style [style plain])
|
|
(make-delayed-block
|
|
(lambda (renderer part ri)
|
|
(send renderer local-table-of-contents part ri style))))
|