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