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

reformatted and a little improved code, use scheme/base

Browse Source 
svn: r9881

original commit: 8f8451dc4f17984156a5733c3e313f9b35de5ea1
This commit is contained in:
Eli Barzilay 2008-05-18 20:26:36 +00:00
parent 04e6d902c8
commit ae5f6458d8
2 changed files with 2596 additions and 2824 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

420
collects/scribble/decode.ss
View File

@ -1,228 +1,240 @@
#lang scheme/base
(require "struct.ss"
"decode-struct.ss"
scheme/contract
scheme/class
scheme/list)
(module decode mzscheme (provide decode
(require "struct.ss" decode-part
"decode-struct.ss" decode-flow
mzlib/contract decode-paragraph
mzlib/class) decode-content
(rename-out [decode-content decode-elements])
decode-string
whitespace?)
(provide decode (provide-structs
decode-part [title-decl ([tag-prefix (or/c false/c string?)]
decode-flow [tags (listof tag?)]
decode-paragraph [version (or/c string? false/c)]
decode-content [style any/c]
(rename decode-content decode-elements) [content list?])]
decode-string [part-start ([depth integer?]
whitespace?) [tag-prefix (or/c false/c string?)]
[tags (listof tag?)]
[style any/c]
[title list?])]
[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-structs (define (decode-string s)
[title-decl ([tag-prefix (or/c false/c string?)] (let loop ([l '((#rx"---" mdash)
[tags (listof tag?)] (#rx"--" ndash)
[version (or/c string? false/c)] (#rx"``" ldquo)
[style any/c] (#rx"''" rdquo)
[content list?])] (#rx"'" rsquo))])
[part-start ([depth integer?] (cond [(null? l) (list s)]
[tag-prefix (or/c false/c string?)] [(regexp-match-positions (caar l) s)
[tags (listof tag?)] => (lambda (m)
[style any/c] (append (decode-string (substring s 0 (caar m)))
[title list?])] (cdar l)
[splice ([run list?])] (decode-string (substring s (cdar m)))))]
[part-index-decl ([plain-seq (listof string?)] [else (loop (cdr l))])))
[entry-seq list?])]
[part-collect-decl ([element (or/c element? part-relative-element?)])]
[part-tag-decl ([tag tag?])])
(define (decode-string s) (define (line-break? v)
(let loop ([l '((#rx"---" mdash) (equal? v "\n"))
(#rx"--" ndash)
(#rx"``" ldquo)
(#rx"''" rdquo)
(#rx"'" rsquo))])
(cond [(null? l) (list s)]
[(regexp-match-positions (caar l) s)
=> (lambda (m)
(append (decode-string (substring s 0 (caar m)))
(cdar l)
(decode-string (substring s (cdar m)))))]
[else (loop (cdr l))])))
(define (line-break? v) (define (whitespace? v)
(equal? v "\n")) (and (string? v) (regexp-match? #px"^[\\s]*$" v)))
(define (whitespace? v) (define (decode-accum-para accum)
(and (string? v) (regexp-match? #px"^[\\s]*$" v))) (if (andmap whitespace? accum)
null
(list (decode-paragraph (reverse (skip-whitespace accum))))))
(define (decode-accum-para accum) (define (part-version p)
(if (andmap whitespace? accum) (if (versioned-part? p)
null (versioned-part-version p)
(list (decode-paragraph (reverse (skip-whitespace accum)))))) #f))
(define (part-version p) (define (decode-flow* l keys colls tag-prefix tags vers style title part-depth)
(if (versioned-part? p) (let loop ([l l] [next? #f] [keys keys] [colls colls] [accum null]
(versioned-part-version p) [title title] [tag-prefix tag-prefix] [tags tags] [vers vers]
#f)) [style style])
(cond
(define (decode-flow* l keys colls tag-prefix tags vers style title part-depth) [(null? l)
(let loop ([l l] [next? #f] [keys keys] [colls colls] [accum null] (let ([k-tags (map (lambda (k) `(idx ,(make-generated-tag))) keys)]
[title title] [tag-prefix tag-prefix] [tags tags] [vers vers] [tags (if (null? tags)
[style style]) (list `(part ,(make-generated-tag)))
(cond tags)])
[(null? l) (make-versioned-part
(let ([k-tags (map (lambda (k) `(idx ,(make-generated-tag))) keys)] tag-prefix
[tags (if (null? tags) (append tags k-tags)
(list `(part ,(make-generated-tag))) title
tags)]) style
(make-versioned-part (let ([l (append
tag-prefix (map (lambda (k tag)
(append tags k-tags) (make-index-element #f null tag
title (part-index-decl-plain-seq k)
style (part-index-decl-entry-seq k)
(let ([l (append #f))
(map (lambda (k tag) keys k-tags)
(make-index-element #f null tag
(part-index-decl-plain-seq k)
(part-index-decl-entry-seq k)
#f))
keys k-tags)
colls)]) colls)])
(if (and title (not (or (eq? 'hidden style) (if (and title (not (or (eq? 'hidden style)
(and (list? style) (memq 'hidden style))))) (and (list? style) (memq 'hidden style)))))
(cons (make-index-element (cons (make-index-element
#f null (car tags) #f null (car tags)
(list (regexp-replace (list (regexp-replace
#px"^\\s+(?:(?:A|An|The)\\s)?" (content->string title) "")) #px"^\\s+(?:(?:A|An|The)\\s)?"
(list (make-element #f title)) (content->string title) ""))
(make-part-index-desc)) (list (make-element #f title))
l) (make-part-index-desc))
l)) l)
(make-flow (decode-accum-para accum)) l))
null (make-flow (decode-accum-para accum))
vers))] null
[(title-decl? (car l)) vers))]
(cond [(not part-depth) (error 'decode "misplaced title: ~e" (car l))] [(title-decl? (car l))
[title (error 'decode "found extra title: ~v" (car l))] (cond [(not part-depth) (error 'decode "misplaced title: ~e" (car l))]
[else (loop (cdr l) next? keys colls accum [title (error 'decode "found extra title: ~v" (car l))]
(title-decl-content (car l)) [else (loop (cdr l) next? keys colls accum
(title-decl-tag-prefix (car l)) (title-decl-content (car l))
(title-decl-tags (car l)) (title-decl-tag-prefix (car l))
(title-decl-version (car l)) (title-decl-tags (car l))
(title-decl-style (car l)))])] (title-decl-version (car l))
[(block? (car l)) (title-decl-style (car l)))])]
(let ([para (decode-accum-para accum)] [(block? (car l))
[part (decode-flow* (cdr l) keys colls tag-prefix tags vers style (let ([para (decode-accum-para accum)]
title part-depth)]) [part (decode-flow* (cdr l) keys colls tag-prefix tags vers style
(make-versioned-part title part-depth)])
(part-tag-prefix part) (make-versioned-part
(part-tags part) (part-tag-prefix part)
(part-title-content part) (part-tags part)
(part-style part) (part-title-content part)
(part-to-collect part) (part-style part)
(make-flow (append para (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? (car l)) (part-version part)))]
(let ([para (decode-accum-para accum)] [(part? (car l))
[part (decode-flow* (cdr l) keys colls tag-prefix tags vers style (let ([para (decode-accum-para accum)]
title part-depth)]) [part (decode-flow* (cdr l) keys colls tag-prefix tags vers style
(make-versioned-part title part-depth)])
(part-tag-prefix part) (make-versioned-part
(part-tags part) (part-tag-prefix part)
(part-title-content part) (part-tags part)
(part-style part) (part-title-content part)
(part-to-collect part) (part-style part)
(make-flow (append para (flow-paragraphs (part-flow part)))) (part-to-collect part)
(cons (car l) (part-parts part)) (make-flow (append para (flow-paragraphs (part-flow part))))
(part-version part)))] (cons (car l) (part-parts part))
[(and (part-start? (car l)) (part-version part)))]
(or (not part-depth) [(and (part-start? (car l))
((part-start-depth (car l)) . <= . part-depth))) (or (not part-depth)
(unless part-depth (error 'decode "misplaced part: ~e" (car l))) ((part-start-depth (car l)) . <= . part-depth)))
(let ([s (car l)]) (unless part-depth (error 'decode "misplaced part: ~e" (car l)))
(let loop ([l (cdr l)] (let ([s (car l)])
[s-accum null]) (let loop ([l (cdr l)] [s-accum null])
(if (or (null? l) (if (or (null? l)
(or (and (part-start? (car l)) (and (part-start? (car l))
((part-start-depth (car l)) . <= . part-depth)) ((part-start-depth (car l)) . <= . part-depth))
(part? (car l)))) (part? (car l)))
(let ([para (decode-accum-para accum)] (let ([para (decode-accum-para accum)]
[s (decode-styled-part (reverse s-accum) [s (decode-styled-part (reverse s-accum)
(part-start-tag-prefix s) (part-start-tag-prefix s)
(part-start-tags s) (part-start-tags s)
(part-start-style s) (part-start-style s)
(part-start-title s) (part-start-title s)
(add1 part-depth))] (add1 part-depth))]
[part (decode-flow* l keys colls tag-prefix tags vers style title part-depth)]) [part (decode-flow* 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-tag-prefix part)
(part-title-content part) (part-tags part)
(part-style part) (part-title-content part)
(part-to-collect part) (part-style part)
(make-flow para) (part-to-collect part)
(cons s (part-parts part)) (make-flow para)
(part-version part))) (cons s (part-parts part))
(if (splice? (car l)) (part-version part)))
(loop (append (splice-run (car l)) (cdr l)) s-accum) (if (splice? (car l))
(loop (cdr l) (cons (car l) s-accum))))))] (loop (append (splice-run (car l)) (cdr l)) s-accum)
[(splice? (car l)) (loop (cdr l) (cons (car l) s-accum))))))]
(loop (append (splice-run (car l)) (cdr l)) next? keys colls accum title tag-prefix tags vers style)] [(splice? (car l))
[(null? (cdr l)) (loop null #f keys colls (cons (car l) accum) title tag-prefix tags vers style)] (loop (append (splice-run (car l)) (cdr l))
next? keys colls accum title tag-prefix tags vers style)]
[(null? (cdr l))
(loop null #f keys colls (cons (car l) accum) title tag-prefix tags
vers style)]
[(part-index-decl? (car l)) [(part-index-decl? (car l))
(loop (cdr l) next? (cons (car l) keys) colls accum title tag-prefix tags vers style)] (loop (cdr l) next? (cons (car l) keys) colls accum title tag-prefix
tags vers style)]
[(part-collect-decl? (car l)) [(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)] (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)) [(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)] (loop (cdr l) next? keys colls accum title tag-prefix
(append tags (list (part-tag-decl-tag (car l))))
vers style)]
[(and (pair? (cdr l)) [(and (pair? (cdr l))
(splice? (cadr l))) (splice? (cadr l)))
(loop (cons (car l) (append (splice-run (cadr l)) (cddr l))) next? keys colls accum title tag-prefix tags vers style)] (loop (cons (car l) (append (splice-run (cadr l)) (cddr l)))
next? keys colls accum title tag-prefix tags vers style)]
[(line-break? (car l)) [(line-break? (car l))
(if next? (if next?
(loop (cdr l) #t keys colls accum title tag-prefix tags vers style) (loop (cdr l) #t keys colls accum title tag-prefix tags vers style)
(let ([m (match-newline-whitespace (cdr l))]) (let ([m (match-newline-whitespace (cdr l))])
(if m (if m
(let ([part (loop m #t keys colls null title tag-prefix tags vers style)]) (let ([part (loop m #t keys colls null title tag-prefix tags vers
(make-versioned-part (part-tag-prefix part) style)])
(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 (decode-accum-para accum) (part-style part)
(flow-paragraphs (part-flow part)))) (part-to-collect part)
(part-parts part) (make-flow (append (decode-accum-para accum)
(part-version part))) (flow-paragraphs (part-flow part))))
(loop (cdr l) #f keys colls (cons (car l) accum) title tag-prefix tags vers style))))] (part-parts part)
[else (loop (cdr l) #f keys colls (cons (car l) accum) title tag-prefix tags vers style)]))) (part-version 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) (define (decode-part l tags title depth)
(decode-flow* l null null #f tags #f #f title depth)) (decode-flow* l null null #f tags #f #f title depth))
(define (decode-styled-part l tag-prefix tags style 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)) (decode-flow* l null null tag-prefix tags #f style title depth))
(define (decode-flow l) (define (decode-flow l)
(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 [(null? l) #f] (cond [(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)) (cdr l)))] [(whitespace? (car 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)
(if (or (null? l) (not (whitespace? (car l)))) (if (or (null? l) (not (whitespace? (car l))))
l l
(skip-whitespace (cdr l)))) (skip-whitespace (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 (decode-content l))) (make-paragraph (decode-content l)))
(define (decode-content l) (define (decode-content l)
(apply append (map (lambda (s) (if (string? s) (decode-string s) (list s))) (append-map (lambda (s) (if (string? s) (decode-string s) (list s)))
(skip-whitespace l))))) (skip-whitespace l)))

5000
collects/scribble/manual.ss
View File

File diff suppressed because it is too large Load Diff