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

100
collects/scribble/decode.ss
View File

@ -1,20 +1,20 @@
#lang scheme/base
(module decode mzscheme (require "struct.ss"
(require "struct.ss"
"decode-struct.ss" "decode-struct.ss"
mzlib/contract scheme/contract
mzlib/class) scheme/class
scheme/list)
(provide decode (provide decode
decode-part decode-part
decode-flow decode-flow
decode-paragraph decode-paragraph
decode-content decode-content
(rename decode-content decode-elements) (rename-out [decode-content decode-elements])
decode-string decode-string
whitespace?) whitespace?)
(provide-structs (provide-structs
[title-decl ([tag-prefix (or/c false/c string?)] [title-decl ([tag-prefix (or/c false/c string?)]
[tags (listof tag?)] [tags (listof tag?)]
[version (or/c string? false/c)] [version (or/c string? false/c)]
@ -31,7 +31,7 @@
[part-collect-decl ([element (or/c element? part-relative-element?)])] [part-collect-decl ([element (or/c element? part-relative-element?)])]
[part-tag-decl ([tag tag?])]) [part-tag-decl ([tag tag?])])
(define (decode-string s) (define (decode-string s)
(let loop ([l '((#rx"---" mdash) (let loop ([l '((#rx"---" mdash)
(#rx"--" ndash) (#rx"--" ndash)
(#rx"``" ldquo) (#rx"``" ldquo)
@ -45,23 +45,23 @@
(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)
(equal? v "\n")) (equal? v "\n"))
(define (whitespace? v) (define (whitespace? v)
(and (string? v) (regexp-match? #px"^[\\s]*$" v))) (and (string? v) (regexp-match? #px"^[\\s]*$" v)))
(define (decode-accum-para accum) (define (decode-accum-para accum)
(if (andmap whitespace? accum) (if (andmap whitespace? accum)
null null
(list (decode-paragraph (reverse (skip-whitespace accum)))))) (list (decode-paragraph (reverse (skip-whitespace accum))))))
(define (part-version p) (define (part-version p)
(if (versioned-part? p) (if (versioned-part? p)
(versioned-part-version p) (versioned-part-version p)
#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] (let loop ([l l] [next? #f] [keys keys] [colls colls] [accum null]
[title title] [tag-prefix tag-prefix] [tags tags] [vers vers] [title title] [tag-prefix tag-prefix] [tags tags] [vers vers]
[style style]) [style style])
@ -89,7 +89,8 @@
(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)?"
(content->string title) ""))
(list (make-element #f title)) (list (make-element #f title))
(make-part-index-desc)) (make-part-index-desc))
l) l)
@ -138,12 +139,11 @@
((part-start-depth (car l)) . <= . part-depth))) ((part-start-depth (car l)) . <= . part-depth)))
(unless part-depth (error 'decode "misplaced part: ~e" (car l))) (unless part-depth (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])
(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)
@ -151,7 +151,8 @@
(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
title part-depth)])
(make-versioned-part (part-tag-prefix part) (make-versioned-part (part-tag-prefix part)
(part-tags part) (part-tags part)
(part-title-content part) (part-title-content part)
@ -164,24 +165,35 @@
(loop (append (splice-run (car l)) (cdr l)) s-accum) (loop (append (splice-run (car l)) (cdr l)) s-accum)
(loop (cdr l) (cons (car l) s-accum))))))] (loop (cdr l) (cons (car l) s-accum))))))]
[(splice? (car l)) [(splice? (car l))
(loop (append (splice-run (car l)) (cdr l)) next? keys colls accum title tag-prefix tags vers style)] (loop (append (splice-run (car l)) (cdr l))
[(null? (cdr l)) (loop null #f keys colls (cons (car l) accum) title tag-prefix tags vers style)] 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)])
(make-versioned-part
(part-tag-prefix part)
(part-tags part) (part-tags part)
(part-title-content part) (part-title-content part)
(part-style part) (part-style part)
@ -190,39 +202,39 @@
(flow-paragraphs (part-flow part)))) (flow-paragraphs (part-flow part))))
(part-parts part) (part-parts part)
(part-version part))) (part-version part)))
(loop (cdr l) #f keys colls (cons (car l) accum) title tag-prefix tags vers style))))] (loop (cdr l) #f keys colls (cons (car l) accum) title tag-prefix
[else (loop (cdr l) #f keys colls (cons (car l) accum) title tag-prefix tags vers style)]))) 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)) [(whitespace? (car l)) (match-newline-whitespace (cdr l))]
(match-newline-whitespace (cdr l))]
[else #f])) [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)))

1996
collects/scribble/manual.ss
View File

File diff suppressed because it is too large Load Diff