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

66
collects/scribble/decode.ss
View File

@ -1,16 +1,16 @@
#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?)
@ -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,8 +202,10 @@
(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))
@ -204,12 +218,10 @@
(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)
@ -224,5 +236,5 @@
(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)))

1558
collects/scribble/manual.ss
View File

File diff suppressed because it is too large Load Diff