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

1996
collects/scribble/manual.ss
View File

File diff suppressed because it is too large Load Diff