370 lines
14 KiB
Racket
370 lines
14 KiB
Racket
#lang scheme/base
|
|
(require "core.rkt"
|
|
"private/provide-structs.rkt"
|
|
"decode-struct.rkt"
|
|
racket/contract/base
|
|
racket/contract/combinator
|
|
scheme/list)
|
|
|
|
(define (pre-content? i)
|
|
(or (string? i)
|
|
(content? i)
|
|
(and (splice? i)
|
|
(andmap pre-content? (splice-run i)))
|
|
(and (list? i)
|
|
(andmap pre-content? i))
|
|
(void? i)))
|
|
|
|
(define (pre-flow? i)
|
|
(or (string? i)
|
|
(content? i)
|
|
(block? i)
|
|
(and (splice? i)
|
|
(andmap pre-flow? (splice-run i)))
|
|
(and (list? i)
|
|
(andmap pre-flow? i))
|
|
(void? i)))
|
|
|
|
(define (pre-part? v)
|
|
(or (pre-flow? v)
|
|
(title-decl? v)
|
|
(part-start? v)
|
|
(part-index-decl? v)
|
|
(part-collect-decl? v)
|
|
(part-tag-decl? v)
|
|
(part? v)
|
|
(and (splice? v)
|
|
(andmap pre-part? (splice-run v)))
|
|
(and (list? v)
|
|
(andmap pre-part? v))))
|
|
|
|
(provide-structs
|
|
[title-decl ([tag-prefix (or/c false/c string?)]
|
|
[tags (listof tag?)]
|
|
[version (or/c string? false/c)]
|
|
[style style?]
|
|
[content content?])]
|
|
[part-start ([depth integer?]
|
|
[tag-prefix (or/c false/c string?)]
|
|
[tags (listof tag?)]
|
|
[style style?]
|
|
[title content?])]
|
|
[splice ([run list?])]
|
|
[part-index-decl ([plain-seq (listof string?)]
|
|
[entry-seq list?])]
|
|
[part-collect-decl ([element (or/c element? part-relative-element?)])]
|
|
[part-tag-decl ([tag tag?])])
|
|
|
|
(provide whitespace?
|
|
pre-content?
|
|
pre-flow?
|
|
pre-part?)
|
|
|
|
(provide/contract
|
|
[decode (-> (listof pre-part?)
|
|
part?)]
|
|
[decode-part (-> (listof pre-part?)
|
|
(listof string?)
|
|
(or/c #f content?)
|
|
exact-nonnegative-integer?
|
|
part?)]
|
|
[decode-flow (-> (listof pre-flow?)
|
|
(listof block?))]
|
|
[decode-paragraph (-> (listof pre-content?)
|
|
paragraph?)]
|
|
[decode-compound-paragraph (-> (listof pre-flow?)
|
|
block?)]
|
|
[decode-content (-> (listof pre-content?)
|
|
content?)]
|
|
[rename decode-content decode-elements
|
|
(-> (listof pre-content?)
|
|
content?)]
|
|
[decode-string (-> string? content?)]
|
|
[clean-up-index-string (-> string? string?)])
|
|
|
|
(define (spliceof c)
|
|
(define name `(spliceof ,(contract-name c)))
|
|
(define p (flat-contract-predicate c))
|
|
(make-flat-contract #:name name
|
|
#:first-order (lambda (x)
|
|
(and (splice? x)
|
|
(andmap p (splice-run x))))))
|
|
(provide/contract
|
|
[spliceof (flat-contract? . -> . flat-contract?)])
|
|
|
|
(define the-part-index-desc (make-part-index-desc))
|
|
|
|
(define (clean-up-index-string s)
|
|
;; Collapse whitespace, and remove leading or trailing spaces, which
|
|
;; might appear there due to images or something else that gets
|
|
;; dropped in string form.
|
|
(let* ([s (regexp-replace* #px"\\s+" s " ")]
|
|
[s (regexp-replace* #rx"^ " s "")]
|
|
[s (regexp-replace* #rx" $" s "")])
|
|
(datum-intern-literal s)))
|
|
|
|
|
|
(define (decode-string s)
|
|
(define pattern #rx"(---|--|``|''|'|`)")
|
|
(let loop ([start 0])
|
|
(cond
|
|
[(regexp-match-positions pattern s start)
|
|
=> (lambda (m)
|
|
(define the-match (substring s (caar m) (cdar m)))
|
|
(list* (datum-intern-literal (substring s start (caar m)))
|
|
(cond
|
|
[(string=? the-match "---") 'mdash]
|
|
[(string=? the-match "--") 'ndash]
|
|
[(string=? the-match "``") 'ldquo]
|
|
[(string=? the-match "''") 'rdquo]
|
|
[(string=? the-match "'") 'rsquo]
|
|
[(string=? the-match "`") 'lsquo])
|
|
(loop (cdar m))))]
|
|
;; Common case: nothing to decode, so don't copy strings.
|
|
;; Assume that the input is already interned.
|
|
[(= start 0)
|
|
(list s)]
|
|
[else
|
|
(list (datum-intern-literal (substring s start)))])))
|
|
|
|
|
|
(define (line-break? v)
|
|
(equal? v "\n"))
|
|
|
|
(define (whitespace? v)
|
|
(and (string? v) (regexp-match? #px"^[\\s]*$" v)))
|
|
|
|
(define (decode-accum-para accum)
|
|
(if (andmap whitespace? accum)
|
|
null
|
|
(list (decode-compound-paragraph (reverse (skip-whitespace accum))))))
|
|
|
|
(define (decode-flow* l keys colls tag-prefix tags vers style title part-depth)
|
|
(let loop ([l l] [next? #f] [keys keys] [colls colls] [accum null]
|
|
[title title] [tag-prefix tag-prefix] [tags tags] [vers vers]
|
|
[style style])
|
|
(cond
|
|
[(null? l)
|
|
(let ([k-tags (map (lambda (k) `(idx ,(make-generated-tag))) keys)]
|
|
[tags (if (null? tags)
|
|
(list `(part ,(make-generated-tag)))
|
|
tags)])
|
|
(make-part
|
|
tag-prefix
|
|
(append tags k-tags)
|
|
title
|
|
(if vers
|
|
(make-style (style-name style)
|
|
(cons (make-document-version vers)
|
|
(style-properties style)))
|
|
style)
|
|
(let ([l (append
|
|
(map (lambda (k tag)
|
|
(make-index-element #f null tag
|
|
(part-index-decl-plain-seq k)
|
|
(part-index-decl-entry-seq k)
|
|
#f))
|
|
keys k-tags)
|
|
colls)])
|
|
(if (and title
|
|
(not (memq 'hidden (style-properties style)))
|
|
(not (memq 'no-index (style-properties style))))
|
|
(cons (make-index-element
|
|
#f null (car tags)
|
|
(list (clean-up-index-string
|
|
(regexp-replace #px"^\\s+(?:(?:A|An|The)\\s)?"
|
|
(content->string title) "")))
|
|
(list (make-element #f title))
|
|
the-part-index-desc)
|
|
l)
|
|
l))
|
|
(decode-accum-para accum)
|
|
null))]
|
|
[(void? (car l))
|
|
(loop (cdr l) next? keys colls accum title tag-prefix tags vers style)]
|
|
[(title-decl? (car l))
|
|
(cond [(not part-depth) (error 'decode "misplaced title: ~e" (car l))]
|
|
[title (error 'decode "found extra title: ~v" (car l))]
|
|
[else (loop (cdr l) next? keys colls accum
|
|
(title-decl-content (car l))
|
|
(title-decl-tag-prefix (car l))
|
|
(title-decl-tags (car l))
|
|
(title-decl-version (car l))
|
|
(title-decl-style (car l)))])]
|
|
#;
|
|
;; Blocks are now handled by decode-accum-para
|
|
[(block? (car l))
|
|
(let ([para (decode-accum-para accum)]
|
|
[part (decode-flow* (cdr l) keys colls tag-prefix tags vers style
|
|
title part-depth)])
|
|
(make-part
|
|
(part-tag-prefix part)
|
|
(part-tags part)
|
|
(part-title-content part)
|
|
(part-style part)
|
|
(part-to-collect part)
|
|
(append para (list (car l)) (part-flow part))
|
|
(part-parts part)))]
|
|
[(part? (car l))
|
|
(let ([para (decode-accum-para accum)]
|
|
[part (decode-flow* (cdr l) keys colls tag-prefix tags vers style
|
|
title part-depth)])
|
|
(make-part
|
|
(part-tag-prefix part)
|
|
(part-tags part)
|
|
(part-title-content part)
|
|
(part-style part)
|
|
(part-to-collect part)
|
|
(append para (part-blocks part))
|
|
(cons (car l) (part-parts part))))]
|
|
[(part-start? (car l))
|
|
(unless part-depth
|
|
(error 'decode "misplaced part; title: ~s" (part-start-title (car l))))
|
|
(unless ((part-start-depth (car l)) . <= . part-depth)
|
|
(error 'decode
|
|
"misplaced part (the part is more than one layer deeper than its container); title: ~s"
|
|
(part-start-title (car l))))
|
|
(let ([s (car l)])
|
|
(let loop ([l (cdr l)] [s-accum null])
|
|
(if (or (null? l)
|
|
(and (part-start? (car l))
|
|
((part-start-depth (car l)) . <= . part-depth))
|
|
(part? (car l)))
|
|
(let ([para (decode-accum-para accum)]
|
|
[s (decode-styled-part (reverse s-accum)
|
|
(part-start-tag-prefix s)
|
|
(part-start-tags s)
|
|
(part-start-style s)
|
|
(part-start-title s)
|
|
(add1 part-depth))]
|
|
[part (decode-flow* l keys colls tag-prefix tags vers style
|
|
title part-depth)])
|
|
(make-part (part-tag-prefix part)
|
|
(part-tags part)
|
|
(part-title-content part)
|
|
(part-style part)
|
|
(part-to-collect part)
|
|
para
|
|
(cons s (part-parts part))))
|
|
(cond
|
|
[(splice? (car l))
|
|
(loop (append (splice-run (car l)) (cdr l)) s-accum)]
|
|
[(list? (car l))
|
|
(loop (append (car l) (cdr l)) s-accum)]
|
|
[else
|
|
(loop (cdr l) (cons (car l) s-accum))]))))]
|
|
[(splice? (car l))
|
|
(loop (append (splice-run (car l)) (cdr l))
|
|
next? keys colls accum title tag-prefix tags vers style)]
|
|
[(list? (car l))
|
|
(loop (append (car l) (cdr l))
|
|
next? keys colls accum title tag-prefix tags vers style)]
|
|
[(part-index-decl? (car l))
|
|
(loop (cdr l) next? (cons (car l) keys) colls accum title tag-prefix
|
|
tags vers style)]
|
|
[(part-collect-decl? (car l))
|
|
(loop (cdr l) next? keys
|
|
(cons (part-collect-decl-element (car l)) colls)
|
|
accum title tag-prefix tags vers style)]
|
|
[(part-tag-decl? (car l))
|
|
(loop (cdr l) next? keys colls accum title tag-prefix
|
|
(append tags (list (part-tag-decl-tag (car l))))
|
|
vers style)]
|
|
[(null? (cdr l))
|
|
(loop null #f keys colls (cons (car l) accum) title tag-prefix tags
|
|
vers style)]
|
|
[(and (pair? (cdr l))
|
|
(or (splice? (cadr l))
|
|
(list? (cadr l))))
|
|
(loop (cons (car l) (append ((if (splice? (cadr l)) splice-run values) (cadr l)) (cddr l)))
|
|
next? keys colls accum title tag-prefix tags vers style)]
|
|
[(line-break? (car l))
|
|
(if next?
|
|
(loop (cdr l) #t keys colls accum title tag-prefix tags vers style)
|
|
(let ([m (match-newline-whitespace (cdr l))])
|
|
(if m
|
|
(let ([part (loop m #t keys colls null title tag-prefix tags vers
|
|
style)])
|
|
(make-part
|
|
(part-tag-prefix part)
|
|
(part-tags part)
|
|
(part-title-content part)
|
|
(part-style part)
|
|
(part-to-collect part)
|
|
(append (decode-accum-para accum)
|
|
(part-blocks part))
|
|
(part-parts part)))
|
|
(loop (cdr l) #f keys colls (cons (car l) accum) title tag-prefix
|
|
tags vers style))))]
|
|
[else (loop (cdr l) #f keys colls (cons (car l) accum) title tag-prefix
|
|
tags vers style)])))
|
|
|
|
(define (decode-part l tags title depth)
|
|
(decode-flow* l null null #f tags #f plain title depth))
|
|
|
|
(define (decode-styled-part l tag-prefix tags style title depth)
|
|
(decode-flow* l null null tag-prefix tags #f style title depth))
|
|
|
|
(define (decode-flow l)
|
|
(part-blocks (decode-flow* l null null #f null #f plain #f #f)))
|
|
|
|
(define (match-newline-whitespace l)
|
|
(cond [(null? l) #f]
|
|
[(void? (car l)) (match-newline-whitespace (cdr l))]
|
|
[(line-break? (car l)) (skip-whitespace l)]
|
|
[(splice? (car l))
|
|
(match-newline-whitespace (append (splice-run (car l)) (cdr l)))]
|
|
[(list? (car l))
|
|
(match-newline-whitespace (append (car l) (cdr l)))]
|
|
[(whitespace? (car l)) (match-newline-whitespace (cdr l))]
|
|
[else #f]))
|
|
|
|
(define (skip-whitespace l)
|
|
(if (or (null? l)
|
|
(not (or (whitespace? (car l))
|
|
(void? (car l)))))
|
|
l
|
|
(skip-whitespace (cdr l))))
|
|
|
|
(define (decode l)
|
|
(decode-part l null #f 0))
|
|
|
|
(define (decode-paragraph l)
|
|
(make-paragraph plain (decode-content l)))
|
|
|
|
(define (decode-content l)
|
|
(append-map (lambda (s) (cond
|
|
[(string? s) (decode-string s)]
|
|
[(void? s) null]
|
|
[(splice? s) (decode-content (splice-run s))]
|
|
[(list? s) (decode-content s)]
|
|
[else (list s)]))
|
|
(skip-whitespace l)))
|
|
|
|
(define (decode-compound-paragraph l)
|
|
(define (finish-accum para-accum)
|
|
(if (null? para-accum)
|
|
null
|
|
(list (make-paragraph plain (skip-whitespace (apply append (reverse para-accum)))))))
|
|
(let ([r (let loop ([l (skip-whitespace l)]
|
|
[para-accum null])
|
|
(cond
|
|
[(null? l)
|
|
(finish-accum para-accum)]
|
|
[else
|
|
(let ([s (car l)])
|
|
(cond
|
|
[(block? s) (append
|
|
(finish-accum para-accum)
|
|
(cons s (loop (skip-whitespace (cdr l)) null)))]
|
|
[(string? s) (loop (cdr l)
|
|
(cons (decode-string s) para-accum))]
|
|
[else (loop (cdr l)
|
|
(cons (list (car l)) para-accum))]))]))])
|
|
(cond
|
|
[(null? r)
|
|
(make-paragraph plain null)]
|
|
[(null? (cdr r))
|
|
(car r)]
|
|
[(make-compound-paragraph plain r)])))
|