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

reformat

Browse Source 
svn: r9878

original commit: a3c5b7052f092d7feb675e864097d8f147d60281
This commit is contained in:
Eli Barzilay 2008-05-17 18:19:58 +00:00
parent bb2b77d874
commit ab7c7e7f92
1 changed files with 445 additions and 475 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

92
collects/scribble/struct.ss
View File

@ -1,5 +1,4 @@
#lang scheme/base
(module struct scheme/base
(require scheme/serialize (require scheme/serialize
scheme/contract scheme/contract
(for-syntax scheme/base)) (for-syntax scheme/base))
@ -13,7 +12,6 @@
(hash-ref (collect-info-parts (resolve-info-ci ri)) (hash-ref (collect-info-parts (resolve-info-ci ri))
part)) part))
(define (collect-put! ci key val) (define (collect-put! ci key val)
(let ([ht (collect-info-ht ci)]) (let ([ht (collect-info-ht ci)])
(when (hash-ref ht key #f) (when (hash-ref ht key #f)
@ -31,22 +29,17 @@
#f)]) #f)])
(cond (cond
[v (values v #f)] [v (values v #f)]
[part (resolve-get/where (collected-info-parent [part (resolve-get/where
(part-collected-info part ri)) (collected-info-parent (part-collected-info part ri))
ri ri key)]
key)]
[else [else
(let ([v (hash-ref (collect-info-ext-ht (resolve-info-ci ri)) (values (hash-ref (collect-info-ext-ht (resolve-info-ci ri)) key #f)
key #t)]))))
#f)])
(values v #t))]))))
(define (resolve-get/ext? part ri key) (define (resolve-get/ext? part ri key)
(let-values ([(v ext?) (resolve-get/where part ri key)]) (let-values ([(v ext?) (resolve-get/where part ri key)])
(when ext? (when ext?
(hash-set! (resolve-info-undef ri) (hash-set! (resolve-info-undef ri) (tag-key key ri) #t))
(tag-key key ri)
#t))
(values v ext?))) (values v ext?)))
(define (resolve-get part ri key) (define (resolve-get part ri key)
@ -63,8 +56,7 @@
(lambda () (lambda ()
(let ([s-ht (make-hash)]) (let ([s-ht (make-hash)])
(hash-set! (resolve-info-searches ri) (hash-set! (resolve-info-searches ri)
search-key search-key s-ht)
s-ht)
s-ht)))]) s-ht)))])
(hash-set! s-ht key #t)) (hash-set! s-ht key #t))
(resolve-get part ri key)) (resolve-get part ri key))
@ -72,15 +64,11 @@
(define (resolve-get-keys part ri key-pred) (define (resolve-get-keys part ri key-pred)
(let ([l null]) (let ([l null])
(hash-for-each (hash-for-each
(collected-info-info (collected-info-info (part-collected-info part ri))
(part-collected-info part ri)) (lambda (k v) (when (key-pred k) (set! l (cons k l)))))
(lambda (k v)
(when (key-pred k)
(set! l (cons k l)))))
l)) l))
(provide (provide (struct-out collect-info)
(struct-out collect-info)
(struct-out resolve-info)) (struct-out resolve-info))
;; ---------------------------------------- ;; ----------------------------------------
@ -95,7 +83,7 @@
(provide/contract (provide/contract
#,@(let ([ids (syntax->list #'(id ...))] #,@(let ([ids (syntax->list #'(id ...))]
[fields+cts (syntax->list #'(([field ct] ...) ...))]) [fields+cts (syntax->list #'(([field ct] ...) ...))])
(letrec ([get-fields (lambda (super-id) (define (get-fields super-id)
(ormap (lambda (id fields+cts) (ormap (lambda (id fields+cts)
(if (identifier? id) (if (identifier? id)
(and (free-identifier=? id super-id) (and (free-identifier=? id super-id)
@ -106,7 +94,7 @@
#`[#,@(get-fields #'next-id) #`[#,@(get-fields #'next-id)
#,@fields+cts]] #,@fields+cts]]
[_else #f]))) [_else #f])))
ids fields+cts))]) ids fields+cts))
(map (lambda (id fields+cts) (map (lambda (id fields+cts)
(if (identifier? id) (if (identifier? id)
#`[struct #,id #,fields+cts] #`[struct #,id #,fields+cts]
@ -115,10 +103,11 @@
#`[struct id (#,@(get-fields #'super) #`[struct id (#,@(get-fields #'super)
#,@fields+cts)]]))) #,@fields+cts)]])))
ids ids
fields+cts)))))])) fields+cts))))]))
(provide tag?) (provide tag?)
(define (tag? s) (and (pair? s) (define (tag? s)
(and (pair? s)
(symbol? (car s)) (symbol? (car s))
(pair? (cdr s)) (pair? (cdr s))
(or (string? (cadr s)) (or (string? (cadr s))
@ -265,9 +254,8 @@
(provide part-relative-element-content) (provide part-relative-element-content)
(define (part-relative-element-content e ci/ri) (define (part-relative-element-content e ci/ri)
(hash-ref (collect-info-relatives (if (resolve-info? ci/ri) (hash-ref (collect-info-relatives
(resolve-info-ci ci/ri) (if (resolve-info? ci/ri) (resolve-info-ci ci/ri) ci/ri))
ci/ri))
e)) e))
(provide collect-info-parents) (provide collect-info-parents)
@ -337,10 +325,7 @@
(unless ri (unless ri
(error 'serialize-generated-tag (error 'serialize-generated-tag
"current-serialize-resolve-info not set")) "current-serialize-resolve-info not set"))
(let ([t (hash-ref (collect-info-tags (let ([t (hash-ref (collect-info-tags (resolve-info-ci ri)) g #f)])
(resolve-info-ci ri))
g
#f)])
(if t (if t
(vector t) (vector t)
(error 'serialize-generated-tag (error 'serialize-generated-tag
@ -349,8 +334,7 @@
#f #f
(or (current-load-relative-directory) (current-directory)))) (or (current-load-relative-directory) (current-directory))))
(provide (provide (struct-out generated-tag))
(struct-out generated-tag))
(provide deserialize-generated-tag) (provide deserialize-generated-tag)
(define deserialize-generated-tag (define deserialize-generated-tag
@ -374,9 +358,7 @@
(define (tag-key tg ri) (define (tag-key tg ri)
(if (generated-tag? (cadr tg)) (if (generated-tag? (cadr tg))
(list (car tg) (list (car tg)
(hash-ref (collect-info-tags (hash-ref (collect-info-tags (resolve-info-ci ri)) (cadr tg)))
(resolve-info-ci ri))
(cadr tg)))
tg)) tg))
;; ---------------------------------------- ;; ----------------------------------------
@ -388,12 +370,11 @@
(define content->string (define content->string
(case-lambda (case-lambda
[(c) (c->s c element->string)] [(c) (c->s c element->string)]
[(c renderer sec ri) (c->s c (lambda (e) [(c renderer sec ri)
(element->string e renderer sec ri)))])) (c->s c (lambda (e) (element->string e renderer sec ri)))]))
(define (c->s c do-elem) (define (c->s c do-elem)
(apply string-append (apply string-append (map do-elem c)))
(map do-elem c)))
(define element->string (define element->string
(case-lambda (case-lambda
@ -416,27 +397,22 @@
(let ([dest (resolve-get sec ri (link-element-tag c))]) (let ([dest (resolve-get sec ri (link-element-tag c))])
;; FIXME: this is specific to renderer ;; FIXME: this is specific to renderer
(if dest (if dest
(content->string (strip-aux (if (pair? dest) (content->string (strip-aux
(cadr dest) (if (pair? dest) (cadr dest) (vector-ref dest 1)))
(vector-ref dest 1)))
renderer sec ri) renderer sec ri)
"???"))] "???"))]
[(element? c) (content->string (element-content c) renderer sec ri)] [(element? c) (content->string (element-content c) renderer sec ri)]
[(delayed-element? c) [(delayed-element? c)
(content->string (delayed-element-content c ri) (content->string (delayed-element-content c ri) renderer sec ri)]
renderer sec ri)]
[(part-relative-element? c) [(part-relative-element? c)
(content->string (part-relative-element-content c ri) (content->string (part-relative-element-content c ri) renderer sec ri)]
renderer sec ri)]
[else (element->string c)])])) [else (element->string c)])]))
(define (strip-aux content) (define (strip-aux content)
(cond (cond
[(null? content) null] [(null? content) null]
[(aux-element? (car content)) [(aux-element? (car content)) (strip-aux (cdr content))]
(strip-aux (cdr content))] [else (cons (car content) (strip-aux (cdr content)))]))
[else (cons (car content)
(strip-aux (cdr content)))]))
;; ---------------------------------------- ;; ----------------------------------------
@ -472,10 +448,7 @@
(let loop ([flowss flowss]) (let loop ([flowss flowss])
(if (null? (car flowss)) (if (null? (car flowss))
0 0
(+ (apply max (+ (apply max 0 (map flow-width (map car flowss)))
0
(map flow-width
(map car flowss)))
(loop (map cdr flowss)))))))) (loop (map cdr flowss))))))))
(define (itemization-width p) (define (itemization-width p)
@ -509,6 +482,3 @@
[resolve-get/ext? ((or/c part? false/c) resolve-info? info-key? . -> . any)] [resolve-get/ext? ((or/c part? false/c) resolve-info? info-key? . -> . any)]
[resolve-search (any/c (or/c part? false/c) resolve-info? info-key? . -> . any)] [resolve-search (any/c (or/c part? false/c) resolve-info? info-key? . -> . any)]
[resolve-get-keys ((or/c part? false/c) resolve-info? (info-key? . -> . any/c) . -> . any/c)]) [resolve-get-keys ((or/c part? false/c) resolve-info? (info-key? . -> . any/c) . -> . any/c)])
)