suzanne.soy/hyper-literate
1
0
Fork 0
Code Issues 4 Pull Requests 1 Actions Packages Projects Releases Wiki Activity

minor

Browse Source 
svn: r8494

original commit: d963f4c39ee4f04823b1a6991f38600989464e8d
This commit is contained in:
Eli Barzilay 2008-02-01 11:59:50 +00:00
parent e764c8e02f
commit 43c556ccc2
1 changed files with 86 additions and 114 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

200
collects/scribble/decode.ss
View File

@ -27,8 +27,7 @@
[splice ([run list?])] [splice ([run list?])]
[part-index-decl ([plain-seq (listof string?)] [part-index-decl ([plain-seq (listof string?)]
[entry-seq list?])] [entry-seq list?])]
[part-collect-decl ([element (or/c element? [part-collect-decl ([element (or/c element? part-relative-element?)])]
part-relative-element?)])]
[part-tag-decl ([tag tag?])]) [part-tag-decl ([tag tag?])])
(define (decode-string s) (define (decode-string s)
@ -37,22 +36,19 @@
(#rx"``" ldquo) (#rx"``" ldquo)
(#rx"''" rdquo) (#rx"''" rdquo)
(#rx"'" rsquo))]) (#rx"'" rsquo))])
(cond (cond [(null? l) (list s)]
[(null? l) (list s)] [(regexp-match-positions (caar l) s)
[(regexp-match-positions (caar l) s) => (lambda (m)
=> (lambda (m) (append (decode-string (substring s 0 (caar m)))
(append (decode-string (substring s 0 (caar m))) (cdar l)
(cdar l) (decode-string (substring s (cdar m)))))]
(decode-string (substring s (cdar m)))))] [else (loop (cdr l))])))
[else (loop (cdr l))])))
(define (line-break? v) (define (line-break? v)
(and (string? v) (equal? v "\n"))
(equal? v "\n")))
(define (whitespace? v) (define (whitespace? v)
(and (string? v) (and (string? v) (regexp-match? #px"^[\\s]*$" v)))
(regexp-match #px"^[\\s]*$" v)))
(define (decode-accum-para accum) (define (decode-accum-para accum)
(if (andmap whitespace? accum) (if (andmap whitespace? accum)
@ -65,95 +61,81 @@
#f)) #f))
(define (decode-flow* l keys colls tag-prefix tags vers style title part-depth) (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] (let loop ([l l] [next? #f] [keys keys] [colls colls] [accum null]
[tag-prefix tag-prefix][tags tags][vers vers][style style]) [title title] [tag-prefix tag-prefix] [tags tags] [vers vers]
[style style])
(cond (cond
[(null? l) [(null? l)
(let ([k-tags (map (lambda (k) (let ([k-tags (map (lambda (k) `(idx ,(make-generated-tag))) keys)]
`(idx ,(make-generated-tag)))
keys)]
[tags (if (null? tags) [tags (if (null? tags)
(list `(part ,(make-generated-tag))) (list `(part ,(make-generated-tag)))
tags)]) tags)])
(make-versioned-part tag-prefix (make-versioned-part
(append tags k-tags) tag-prefix
title (append tags k-tags)
style title
(let ([l (map (lambda (k tag) style
(make-index-element (let ([l (append
#f (map (lambda (k tag)
null (make-index-element #f null tag
tag
(part-index-decl-plain-seq k) (part-index-decl-plain-seq k)
(part-index-decl-entry-seq k) (part-index-decl-entry-seq k)
#f)) #f))
keys k-tags)]) keys k-tags)
(append colls)])
(if (and title (not (or (eq? 'hidden style) (if (and title (not (or (eq? 'hidden style)
(and (list? style) (and (list? style) (memq 'hidden style)))))
(memq 'hidden style))))) (cons (make-index-element
(cons (make-index-element #f null (car tags)
#f (list (regexp-replace
null #px"^(?:A|An|The)\\s" (content->string title) ""))
(car tags) (list (make-element #f title))
(list (regexp-replace #px"^(?:A|An|The)\\s" (content->string title) (make-part-index-desc))
"")) l)
(list (make-element #f title)) l))
(make-part-index-desc)) (make-flow (decode-accum-para accum))
l) null
l) vers))]
colls))
(make-flow (decode-accum-para accum))
null
vers))]
[(title-decl? (car l)) [(title-decl? (car l))
(unless part-depth (cond [(not part-depth) (error 'decode "misplaced title: ~e" (car l))]
(error 'decode [title (error 'decode "found extra title: ~v" (car l))]
"misplaced title: ~e" [else (loop (cdr l) next? keys colls accum
(car l))) (title-decl-content (car l))
(when title (title-decl-tag-prefix (car l))
(error 'decode (title-decl-tags (car l))
"found extra title: ~v" (title-decl-version (car l))
(car l))) (title-decl-style (car l)))])]
(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)))]
[(flow-element? (car l)) [(flow-element? (car l))
(let ([para (decode-accum-para accum)] (let ([para (decode-accum-para accum)]
[part (decode-flow* (cdr l) keys colls tag-prefix tags vers style title part-depth)]) [part (decode-flow* (cdr l) keys colls tag-prefix tags vers style
(make-versioned-part (part-tag-prefix part) title part-depth)])
(part-tags part) (make-versioned-part
(part-title-content part) (part-tag-prefix part)
(part-style part) (part-tags part)
(part-to-collect part) (part-title-content part)
(make-flow (append para (part-style part)
(list (car l)) (part-to-collect part)
(flow-paragraphs (part-flow part)))) (make-flow (append para (list (car l))
(part-parts part) (flow-paragraphs (part-flow part))))
(part-version part)))] (part-parts part)
(part-version part)))]
[(part? (car l)) [(part? (car l))
(let ([para (decode-accum-para accum)] (let ([para (decode-accum-para accum)]
[part (decode-flow* (cdr l) keys colls tag-prefix tags vers style title part-depth)]) [part (decode-flow* (cdr l) keys colls tag-prefix tags vers style
(make-versioned-part (part-tag-prefix part) title part-depth)])
(part-tags part) (make-versioned-part
(part-title-content part) (part-tag-prefix part)
(part-style part) (part-tags part)
(part-to-collect part) (part-title-content part)
(make-flow (append para (part-style part)
(flow-paragraphs (part-to-collect part)
(part-flow part)))) (make-flow (append para (flow-paragraphs (part-flow part))))
(cons (car l) (part-parts part)) (cons (car l) (part-parts part))
(part-version part)))] (part-version part)))]
[(and (part-start? (car l)) [(and (part-start? (car l))
(or (not part-depth) (or (not part-depth)
((part-start-depth (car l)) . <= . part-depth))) ((part-start-depth (car l)) . <= . part-depth)))
(unless part-depth (unless part-depth (error 'decode "misplaced part: ~e" (car l)))
(error 'decode
"misplaced part: ~e"
(car l)))
(let ([s (car l)]) (let ([s (car l)])
(let loop ([l (cdr l)] (let loop ([l (cdr l)]
[s-accum null]) [s-accum null])
@ -220,36 +202,26 @@
(part-flow (decode-flow* l null null #f null #f #f #f #f))) (part-flow (decode-flow* l null null #f null #f #f #f #f)))
(define (match-newline-whitespace l) (define (match-newline-whitespace l)
(cond (cond [(null? l) #f]
[(null? l) #f] [(line-break? (car l))
[(line-break? (car l)) (skip-whitespace l)]
(skip-whitespace l)] [(splice? (car l))
[(splice? (car l)) (match-newline-whitespace (append (splice-run (car l)) (cdr l)))]
(match-newline-whitespace (append (splice-run (car l)) [(whitespace? (car l))
(cdr l)))] (match-newline-whitespace (cdr l))]
[(whitespace? (car l)) [else #f]))
(match-newline-whitespace (cdr l))]
[else #f]))
(define (skip-whitespace l) (define (skip-whitespace l)
(let loop ([l l]) (if (or (null? l) (not (whitespace? (car l))))
(if (or (null? l) l
(not (whitespace? (car l)))) (skip-whitespace (cdr l))))
l
(loop (cdr l)))))
(define (decode l) (define (decode l)
(decode-part l null #f 0)) (decode-part l null #f 0))
(define (decode-paragraph l) (define (decode-paragraph l)
(make-paragraph (make-paragraph (decode-content l)))
(decode-content l)))
(define (decode-content l) (define (decode-content l)
(apply append (apply append (map (lambda (s) (if (string? s) (decode-string s) (list s)))
(map (lambda (s) (skip-whitespace l)))))
(cond
[(string? s)
(decode-string s)]
[else (list s)]))
(skip-whitespace l)))))