suzanne.soy/scribble-enhanced
1
0
Fork 0
Code Issues 1 Pull Requests 1 Actions Packages Projects Releases Wiki Activity

minor code improvements

Browse Source 
svn: r8417

original commit: 7126fdce72db0dc7a11b8db91cc37e678fd1ca8c
This commit is contained in:
Eli Barzilay 2008-01-25 16:32:33 +00:00
parent c63cd9a943
commit a65ca82cc5
1 changed files with 87 additions and 105 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

192
collects/scribble/basic.ss
View File

@ -8,8 +8,8 @@
setup/main-collects setup/main-collects
syntax/modresolve syntax/modresolve
(for-syntax scheme/base)) (for-syntax scheme/base))
(provide title (provide title
section section
subsection subsection
subsubsection subsubsection
@ -17,7 +17,7 @@
include-section) include-section)
(define (gen-tag content) (define (gen-tag content)
(regexp-replace* "[^-a-zA-Z0-9_=]" (regexp-replace* "[^-a-zA-Z0-9_=]"
(content->string content) (content->string content)
"_")) "_"))
@ -31,7 +31,7 @@
(if (list? tag) (if (list? tag)
(apply append (map (lambda (t) (convert-tag t content)) tag)) (apply append (map (lambda (t) (convert-tag t content)) tag))
`((part ,(or tag (gen-tag content)))))) `((part ,(or tag (gen-tag content))))))
(define (title #:tag [tag #f] #:tag-prefix [prefix #f] #:style [style #f] #:version [version #f] . str) (define (title #:tag [tag #f] #:tag-prefix [prefix #f] #:style [style #f] #:version [version #f] . str)
(let ([content (decode-content str)]) (let ([content (decode-content str)])
(make-title-decl (prefix->string prefix) (make-title-decl (prefix->string prefix)
@ -39,7 +39,7 @@
version version
style style
content))) content)))
(define (section #:tag [tag #f] #:tag-prefix [prefix #f] #:style [style #f] . str) (define (section #:tag [tag #f] #:tag-prefix [prefix #f] #:style [style #f] . str)
(let ([content (decode-content str)]) (let ([content (decode-content str)])
(make-part-start 0 (prefix->string prefix) (make-part-start 0 (prefix->string prefix)
@ -49,7 +49,7 @@
(define (subsection #:tag [tag #f] #:tag-prefix [prefix #f] #:style [style #f] . str) (define (subsection #:tag [tag #f] #:tag-prefix [prefix #f] #:style [style #f] . str)
(let ([content (decode-content str)]) (let ([content (decode-content str)])
(make-part-start 1 (make-part-start 1
(prefix->string prefix) (prefix->string prefix)
(convert-tag tag content) (convert-tag tag content)
style style
@ -57,7 +57,7 @@
(define (subsubsection #:tag [tag #f] #:tag-prefix [prefix #f] #:style [style #f] . str) (define (subsubsection #:tag [tag #f] #:tag-prefix [prefix #f] #:style [style #f] . str)
(let ([content (decode-content str)]) (let ([content (decode-content str)])
(make-part-start 2 (make-part-start 2
(prefix->string prefix) (prefix->string prefix)
(convert-tag tag content) (convert-tag tag content)
style style
@ -66,7 +66,7 @@
(define (subsubsub*section #:tag [tag #f] . str) (define (subsubsub*section #:tag [tag #f] . str)
(let ([content (decode-content str)]) (let ([content (decode-content str)])
(make-paragraph (list (make-element 'bold content))))) (make-paragraph (list (make-element 'bold content)))))
(define-syntax (include-section stx) (define-syntax (include-section stx)
(syntax-case stx () (syntax-case stx ()
[(_ mod) [(_ mod)
@ -82,19 +82,16 @@
(define (module-path-prefix->string p) (define (module-path-prefix->string p)
(format "~a" (path->main-collects-relative (format "~a" (path->main-collects-relative
(resolve-module-path p #f)))) (resolve-module-path p #f))))
;; ---------------------------------------- ;; ----------------------------------------
(provide itemize item item?) (provide itemize item item?)
(define (itemize . items) (define (itemize . items)
(let ([items (filter (lambda (v) (not (whitespace? v))) items)]) (let ([items (filter (lambda (v) (not (whitespace? v))) items)])
(for-each (lambda (v) (for ([v items])
(unless (an-item? v) (unless (an-item? v)
(error 'itemize (error 'itemize "expected an item, found something else: ~e" v)))
"expected an item, found something else: ~e"
v)))
items)
(make-itemization (map an-item-flow items)))) (make-itemization (map an-item-flow items))))
(define-struct an-item (flow)) (define-struct an-item (flow))
@ -188,7 +185,7 @@
(let ([key (make-generated-tag)] (let ([key (make-generated-tag)]
[content (decode-content s)]) [content (decode-content s)])
(record-index (list (content->string content)) (record-index (list (content->string content))
(list (make-element #f content)) (list (make-element #f content))
key key
content))) content)))
@ -203,95 +200,80 @@
null)) null))
(define (index-flow-elements) (define (index-flow-elements)
(list (make-delayed-flow-element (define (commas l)
(lambda (renderer sec ri) (if (or (null? l) (null? (cdr l)))
(let ([l null]) l
(hash-table-for-each (cdr (apply append (map (lambda (i) (list ", " i)) l)))))
(let ([parent (collected-info-parent (define (cadr-string-lists<? a b)
(part-collected-info sec ri))]) (let loop ([a (cadr a)] [b (cadr b)])
(if parent (cond [(null? a) #t]
(collected-info-info [(null? b) #f]
(part-collected-info [(string-ci=? (car a) (car b)) (loop (cdr a) (cdr b))]
parent [else (string-ci<? (car a) (car b))])))
ri)) (define alpha (string->list "ABCDEFGHIJKLMNOPQRSTUVWXYZ"))
(collect-info-ext-ht (resolve-info-ci ri)))) (define contents
(lambda (k v) (make-delayed-flow-element
(when (and (pair? k) (lambda (renderer sec ri)
(eq? 'index-entry (car k))) (define l null)
(set! l (cons (cons (cadr k) v) l))))) (define alpha-starts (make-hash-table))
(let ([l (sort (hash-table-for-each
l (let ([parent (collected-info-parent (part-collected-info sec ri))])
(lambda (a b) (if parent
(let loop ([a (cadr a)][b (cadr b)]) (collected-info-info (part-collected-info parent ri))
(cond (collect-info-ext-ht (resolve-info-ci ri))))
[(null? a) #t] (lambda (k v)
[(null? b) #f] (when (and (pair? k) (eq? 'index-entry (car k)))
[(string-ci=? (car a) (car b)) (set! l (cons (cons (cadr k) v) l)))))
(loop (cdr a) (cdr b))] (set! l (sort l cadr-string-lists<?))
[else (make-table
(string-ci<? (car a) (car b))]))))] 'index
[commas (lambda (l) (list*
(if (or (null? l) (list
(null? (cdr l))) (make-flow
l (list
(cdr (apply append (map (lambda (i) (make-paragraph
(list ", " i)) (let loop ([i l] [alpha alpha])
l)))))] (define (add-letter letter l)
[alpha-starts (make-hash-table)]) (list* (make-element "nonavigation" (list (string letter)))
(make-table " " l))
'index (cond [(null? alpha) null]
(list* [(null? i) (add-letter (car alpha) (loop i (cdr alpha)))]
(list [else
(make-flow (let* ([strs (cadr (car i))]
(list [letter (if (or (null? strs)
(make-paragraph (string=? "" (car strs)))
(let ([add-letter #f
(lambda (letter l) (string-ref (car strs) 0))])
(list* (make-element "nonavigation" (cond
(list (string letter))) [(not letter) (loop (cdr i) alpha)]
" " [(char-ci>? letter (car alpha))
l))]) (add-letter (car alpha) (loop i (cdr alpha)))]
(let loop ([i l] [(char-ci=? letter (car alpha))
[alpha (string->list "ABCDEFGHIJKLMNOPQRSTUVWXYZ")]) (hash-table-put! alpha-starts (car i) letter)
(cond (list*
[(null? alpha) null] (make-element
[(null? i) (add-letter (car alpha) (make-target-url
(loop i (cdr alpha)))] (format "#alpha:~a" (char-upcase letter))
[else (let* ([strs (cadr (car i))] #f)
[letter (if (or (null? strs) (list (string (car alpha))))
(string=? "" (car strs))) " "
#f (loop (cdr i) (cdr alpha)))]
(string-ref (car strs) 0))]) [else (loop (cdr i) alpha)]))]))))))
(cond (list (make-flow (list (make-paragraph (list 'nbsp)))))
[(not letter) (loop (cdr i) alpha)] (map (lambda (i)
[(char-ci>? letter (car alpha)) (let* ([e (make-link-element
(add-letter (car alpha) "indexlink"
(loop i (cdr alpha)))] (commas (caddr i))
[(char-ci=? letter (car alpha)) (car i))]
(hash-table-put! alpha-starts (car i) letter) [letter (hash-table-get alpha-starts i #f)]
(list* (make-element (make-target-url [e (if letter
(format "#alpha:~a" letter) (make-element
#f) (make-url-anchor (format "alpha:~a" letter))
(list (string (car alpha)))) (list e))
" " e)])
(loop (cdr i) (cdr alpha)))] (list (make-flow (list (make-paragraph (list e)))))))
[else (loop (cdr i) alpha)]))]))))))) l))))))
(list (make-flow (list (make-paragraph (list 'nbsp))))) (list contents))
(map (lambda (i)
(list (make-flow
(list
(make-paragraph
(list
(let ([e (make-link-element
"indexlink"
(commas (caddr i))
(car i))])
(let ([letter (hash-table-get alpha-starts i #f)])
(if letter
(make-element (make-url-anchor (format "alpha:~a" letter))
(list e))
e)))))))))
l)))))))))
;; ---------------------------------------- ;; ----------------------------------------