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

254
collects/scribble/struct.ss
View File

@ -1,20 +1,18 @@
#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))
;; ---------------------------------------- ;; ----------------------------------------
(define-struct collect-info (ht ext-ht parts tags gen-prefix relatives parents)) (define-struct collect-info (ht ext-ht parts tags gen-prefix relatives parents))
(define-struct resolve-info (ci delays undef searches)) (define-struct resolve-info (ci delays undef searches))
(define (part-collected-info part ri) (define (part-collected-info part ri)
(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)
(fprintf (current-error-port) (fprintf (current-error-port)
@ -22,7 +20,7 @@
key)) key))
(hash-set! ht key val))) (hash-set! ht key val)))
(define (resolve-get/where part ri key) (define (resolve-get/where part ri key)
(let ([key (tag-key key ri)]) (let ([key (tag-key key ri)])
(let ([v (hash-ref (if part (let ([v (hash-ref (if part
(collected-info-info (part-collected-info part ri)) (collected-info-info (part-collected-info part ri))
@ -31,63 +29,53 @@
#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)
(let-values ([(v ext?) (resolve-get/ext? part ri key)]) (let-values ([(v ext?) (resolve-get/ext? part ri key)])
v)) v))
(define (resolve-get/tentative part ri key) (define (resolve-get/tentative part ri key)
(let-values ([(v ext?) (resolve-get/where part ri key)]) (let-values ([(v ext?) (resolve-get/where part ri key)])
v)) v))
(define (resolve-search search-key part ri key) (define (resolve-search search-key part ri key)
(let ([s-ht (hash-ref (resolve-info-searches ri) (let ([s-ht (hash-ref (resolve-info-searches ri)
search-key search-key
(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))
(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))
;; ---------------------------------------- ;; ----------------------------------------
(provide provide-structs) (provide provide-structs)
(define-syntax (provide-structs stx) (define-syntax (provide-structs stx)
(syntax-case stx () (syntax-case stx ()
[(_ (id ([field ct] ...)) ...) [(_ (id ([field ct] ...)) ...)
#`(begin #`(begin
@ -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))
@ -127,15 +116,15 @@
(list? (cadr s)))) (list? (cadr s))))
(null? (cddr s)))) (null? (cddr s))))
(provide block?) (provide block?)
(define (block? p) (define (block? p)
(or (paragraph? p) (or (paragraph? p)
(table? p) (table? p)
(itemization? p) (itemization? p)
(blockquote? p) (blockquote? p)
(delayed-block? p))) (delayed-block? p)))
(provide-structs (provide-structs
[part ([tag-prefix (or/c false/c string?)] [part ([tag-prefix (or/c false/c string?)]
[tags (listof tag?)] [tags (listof tag?)]
[title-content (or/c false/c list?)] [title-content (or/c false/c list?)]
@ -185,10 +174,10 @@
(listof bytes?)))] (listof bytes?)))]
[scale real?])]) [scale real?])])
;; ---------------------------------------- ;; ----------------------------------------
;; Delayed element has special serialization support: ;; Delayed element has special serialization support:
(define-struct delayed-element (resolve sizer plain) (define-struct delayed-element (resolve sizer plain)
#:property #:property
prop:serializable prop:serializable
(make-serialize-info (make-serialize-info
@ -211,30 +200,30 @@
#f #f
(or (current-load-relative-directory) (current-directory)))) (or (current-load-relative-directory) (current-directory))))
(provide/contract (provide/contract
(struct delayed-element ([resolve (any/c part? resolve-info? . -> . list?)] (struct delayed-element ([resolve (any/c part? resolve-info? . -> . list?)]
[sizer (-> any)] [sizer (-> any)]
[plain (-> any)]))) [plain (-> any)])))
(provide deserialize-delayed-element) (provide deserialize-delayed-element)
(define deserialize-delayed-element (define deserialize-delayed-element
(make-deserialize-info values values)) (make-deserialize-info values values))
(provide delayed-element-content) (provide delayed-element-content)
(define (delayed-element-content e ri) (define (delayed-element-content e ri)
(hash-ref (resolve-info-delays ri) e)) (hash-ref (resolve-info-delays ri) e))
(provide delayed-block-blocks) (provide delayed-block-blocks)
(define (delayed-block-blocks p ri) (define (delayed-block-blocks p ri)
(hash-ref (resolve-info-delays ri) p)) (hash-ref (resolve-info-delays ri) p))
(provide current-serialize-resolve-info) (provide current-serialize-resolve-info)
(define current-serialize-resolve-info (make-parameter #f)) (define current-serialize-resolve-info (make-parameter #f))
;; ---------------------------------------- ;; ----------------------------------------
;; part-relative element has special serialization support: ;; part-relative element has special serialization support:
(define-struct part-relative-element (collect sizer plain) (define-struct part-relative-element (collect sizer plain)
#:property #:property
prop:serializable prop:serializable
(make-serialize-info (make-serialize-info
@ -254,29 +243,28 @@
#f #f
(or (current-load-relative-directory) (current-directory)))) (or (current-load-relative-directory) (current-directory))))
(provide/contract (provide/contract
(struct part-relative-element ([collect (collect-info? . -> . list?)] (struct part-relative-element ([collect (collect-info? . -> . list?)]
[sizer (-> any)] [sizer (-> any)]
[plain (-> any)]))) [plain (-> any)])))
(provide deserialize-part-relative-element) (provide deserialize-part-relative-element)
(define deserialize-part-relative-element (define deserialize-part-relative-element
(make-deserialize-info values values)) (make-deserialize-info values values))
(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)
;; ---------------------------------------- ;; ----------------------------------------
;; Delayed index entry also has special serialization support. ;; Delayed index entry also has special serialization support.
;; It uses the same delay -> value table as delayed-element ;; It uses the same delay -> value table as delayed-element
(define-struct delayed-index-desc (resolve) (define-struct delayed-index-desc (resolve)
#:mutable #:mutable
#:property #:property
prop:serializable prop:serializable
@ -297,16 +285,16 @@
#f #f
(or (current-load-relative-directory) (current-directory)))) (or (current-load-relative-directory) (current-directory))))
(provide/contract (provide/contract
(struct delayed-index-desc ([resolve (any/c part? resolve-info? . -> . any)]))) (struct delayed-index-desc ([resolve (any/c part? resolve-info? . -> . any)])))
(provide deserialize-delayed-index-desc) (provide deserialize-delayed-index-desc)
(define deserialize-delayed-index-desc (define deserialize-delayed-index-desc
(make-deserialize-info values values)) (make-deserialize-info values values))
;; ---------------------------------------- ;; ----------------------------------------
(define-struct (collect-element element) (collect) (define-struct (collect-element element) (collect)
#:mutable #:mutable
#:property #:property
prop:serializable prop:serializable
@ -317,18 +305,18 @@
#f #f
(or (current-load-relative-directory) (current-directory)))) (or (current-load-relative-directory) (current-directory))))
(provide deserialize-collect-element) (provide deserialize-collect-element)
(define deserialize-collect-element (define deserialize-collect-element
(make-deserialize-info values values)) (make-deserialize-info values values))
(provide/contract (provide/contract
[struct collect-element ([style any/c] [struct collect-element ([style any/c]
[content list?] [content list?]
[collect (collect-info? . -> . any)])]) [collect (collect-info? . -> . any)])])
;; ---------------------------------------- ;; ----------------------------------------
(define-struct generated-tag () (define-struct generated-tag ()
#:property #:property
prop:serializable prop:serializable
(make-serialize-info (make-serialize-info
@ -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,16 +334,15 @@
#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
(make-deserialize-info values values)) (make-deserialize-info values values))
(provide generate-tag tag-key) (provide generate-tag tag-key)
(define (generate-tag tg ci) (define (generate-tag tg ci)
(if (generated-tag? (cadr tg)) (if (generated-tag? (cadr tg))
(let ([t (cadr tg)]) (let ([t (cadr tg)])
(list (car tg) (list (car tg)
@ -371,31 +355,28 @@
key))))) key)))))
tg)) tg))
(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))
;; ---------------------------------------- ;; ----------------------------------------
(provide content->string (provide content->string
element->string element->string
strip-aux) strip-aux)
(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
[(c) [(c)
(cond (cond
@ -416,34 +397,29 @@
(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)))]))
;; ---------------------------------------- ;; ----------------------------------------
(provide block-width (provide block-width
element-width) element-width)
(define (element-width s) (define (element-width s)
(cond (cond
[(string? s) (string-length s)] [(string? s) (string-length s)]
[(element? s) (apply + (map element-width (element-content s)))] [(element? s) (apply + (map element-width (element-content s)))]
@ -451,13 +427,13 @@
[(part-relative-element? s) (element-width ((part-relative-element-sizer s)))] [(part-relative-element? s) (element-width ((part-relative-element-sizer s)))]
[else 1])) [else 1]))
(define (paragraph-width s) (define (paragraph-width s)
(apply + (map element-width (paragraph-content s)))) (apply + (map element-width (paragraph-content s))))
(define (flow-width f) (define (flow-width f)
(apply max 0 (map block-width (flow-paragraphs f)))) (apply max 0 (map block-width (flow-paragraphs f))))
(define (block-width p) (define (block-width p)
(cond (cond
[(paragraph? p) (paragraph-width p)] [(paragraph? p) (paragraph-width p)]
[(table? p) (table-width p)] [(table? p) (table-width p)]
@ -465,43 +441,40 @@
[(blockquote? p) (blockquote-width p)] [(blockquote? p) (blockquote-width p)]
[(delayed-block? p) 1])) [(delayed-block? p) 1]))
(define (table-width p) (define (table-width p)
(let ([flowss (table-flowss p)]) (let ([flowss (table-flowss p)])
(if (null? flowss) (if (null? flowss)
0 0
(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)
(apply max 0 (map flow-width (itemization-flows p)))) (apply max 0 (map flow-width (itemization-flows p))))
(define (blockquote-width p) (define (blockquote-width p)
(+ 4 (apply max 0 (map paragraph-width (blockquote-paragraphs p))))) (+ 4 (apply max 0 (map paragraph-width (blockquote-paragraphs p)))))
;; ---------------------------------------- ;; ----------------------------------------
(provide part-style?) (provide part-style?)
(define (part-style? p s) (define (part-style? p s)
(let ([st (part-style p)]) (let ([st (part-style p)])
(or (eq? s st) (or (eq? s st)
(and (list? st) (memq s st))))) (and (list? st) (memq s st)))))
;; ---------------------------------------- ;; ----------------------------------------
(define (info-key? l) (define (info-key? l)
(and (pair? l) (and (pair? l)
(symbol? (car l)) (symbol? (car l))
(pair? (cdr l)))) (pair? (cdr l))))
(provide info-key?) (provide info-key?)
(provide/contract (provide/contract
[part-collected-info (part? resolve-info? . -> . collected-info?)] [part-collected-info (part? resolve-info? . -> . collected-info?)]
[collect-put! (collect-info? info-key? any/c . -> . any)] [collect-put! (collect-info? info-key? any/c . -> . any)]
[resolve-get ((or/c part? false/c) resolve-info? info-key? . -> . any)] [resolve-get ((or/c part? false/c) resolve-info? info-key? . -> . any)]
@ -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)])
)