168 lines
6.6 KiB
Scheme
168 lines
6.6 KiB
Scheme
|
|
(module struct mzscheme
|
|
(require (lib "contract.ss")
|
|
(lib "serialize.ss"))
|
|
|
|
(provide provide-structs)
|
|
|
|
(define-syntax (provide-structs stx)
|
|
(syntax-case stx ()
|
|
[(_ (id ([field ct] ...)) ...)
|
|
#`(begin
|
|
(define-serializable-struct id (field ...)) ...
|
|
(provide/contract
|
|
#,@(let ([ids (syntax->list #'(id ...))]
|
|
[fields+cts (syntax->list #'(([field ct] ...) ...))])
|
|
(letrec ([get-fields (lambda (super-id)
|
|
(ormap (lambda (id fields+cts)
|
|
(if (identifier? id)
|
|
(and (module-identifier=? id super-id)
|
|
fields+cts)
|
|
(syntax-case id ()
|
|
[(my-id next-id)
|
|
(module-identifier=? #'my-id super-id)
|
|
#`[#,@(get-fields #'next-id)
|
|
#,@fields+cts]]
|
|
[_else #f])))
|
|
ids fields+cts))])
|
|
(map (lambda (id fields+cts)
|
|
(if (identifier? id)
|
|
#`[struct #,id #,fields+cts]
|
|
(syntax-case id ()
|
|
[(id super)
|
|
#`[struct id (#,@(get-fields #'super)
|
|
#,@fields+cts)]])))
|
|
ids
|
|
fields+cts)))))]))
|
|
|
|
(provide tag?)
|
|
(define (tag? s) (or (string? s)
|
|
(and (pair? s)
|
|
(symbol? (car s))
|
|
(pair? (cdr s))
|
|
(string? (cadr s))
|
|
(null? (cddr s)))))
|
|
|
|
(provide flow-element?)
|
|
(define (flow-element? p)
|
|
(or (paragraph? p)
|
|
(table? p)
|
|
(itemization? p)
|
|
(blockquote? p)
|
|
(delayed-flow-element? p)))
|
|
|
|
(provide-structs
|
|
[part ([tag (or/c false/c tag?)]
|
|
[title-content (or/c false/c list?)]
|
|
[collected-info (or/c false/c collected-info?)]
|
|
[flow flow?]
|
|
[parts (listof part?)])]
|
|
[(styled-part part) ([style any/c])]
|
|
[(unnumbered-part part) ()]
|
|
[flow ([paragraphs (listof flow-element?)])]
|
|
[paragraph ([content list?])]
|
|
[(styled-paragraph paragraph) ([style any/c])]
|
|
[table ([style any/c]
|
|
[flowss (listof (listof (or/c flow? (one-of/c 'cont))))])]
|
|
[delayed-flow-element ([render (any/c part? any/c . -> . flow-element?)])]
|
|
[itemization ([flows (listof flow?)])]
|
|
[blockquote ([style any/c]
|
|
[paragraphs (listof flow-element?)])]
|
|
;; content = list of elements
|
|
[element ([style any/c]
|
|
[content list?])]
|
|
[(target-element element) ([tag tag?])]
|
|
[(link-element element) ([tag tag?])]
|
|
[(index-element element) ([tag tag?]
|
|
[plain-seq (listof string?)]
|
|
[entry-seq list?])]
|
|
[(aux-element element) ()]
|
|
;; specific renders support other elements, especially strings
|
|
|
|
[collected-info ([number (listof (or/c false/c integer?))]
|
|
[parent (or/c false/c part?)]
|
|
[info any/c])]
|
|
|
|
[target-url ([addr string?])]
|
|
[image-file ([path path-string?])])
|
|
|
|
;; ----------------------------------------
|
|
|
|
;; Delayed element has special serialization support:
|
|
(define-values (struct:delayed-element
|
|
make-delayed-element
|
|
delayed-element?
|
|
delayed-element-ref
|
|
delayed-element-set!)
|
|
(make-struct-type 'delayed-element #f
|
|
1 1 #f
|
|
(list (cons prop:serializable
|
|
(make-serialize-info
|
|
(lambda (d)
|
|
(unless (delayed-element-ref d 1)
|
|
(error 'serialize-delayed-element
|
|
"cannot serialize a delayed element that was not resolved: ~e"
|
|
d))
|
|
(vector (delayed-element-ref d 1)))
|
|
#'deserialize-delayed-element
|
|
#f
|
|
(or (current-load-relative-directory) (current-directory)))))))
|
|
(define-syntax delayed-element (list-immutable #'struct:delayed-element
|
|
#'make-delayed-element
|
|
#'delayed-element?
|
|
(list-immutable #'delayed-element-render)
|
|
(list-immutable #'set-delayed-element-render!)
|
|
#t))
|
|
(define delayed-element-render (make-struct-field-accessor delayed-element-ref 0))
|
|
(define set-delayed-element-render! (make-struct-field-mutator delayed-element-set! 0))
|
|
(provide/contract
|
|
(struct delayed-element ([render (any/c part? any/c . -> . list?)])))
|
|
|
|
(provide deserialize-delayed-element)
|
|
(define deserialize-delayed-element
|
|
(make-deserialize-info values values))
|
|
|
|
(provide force-delayed-element)
|
|
(define (force-delayed-element d renderer sec ht)
|
|
(or (delayed-element-ref d 1)
|
|
(let ([v ((delayed-element-ref d 0) renderer sec ht)])
|
|
(delayed-element-set! d 1 v)
|
|
v)))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(provide content->string)
|
|
|
|
(define content->string
|
|
(case-lambda
|
|
[(c) (c->s c element->string)]
|
|
[(c renderer sec ht) (c->s c (lambda (e)
|
|
(element->string e renderer sec ht)))]))
|
|
|
|
(define (c->s c do-elem)
|
|
(apply string-append
|
|
(map do-elem c)))
|
|
|
|
(define element->string
|
|
(case-lambda
|
|
[(c)
|
|
(cond
|
|
[(element? c) (content->string (element-content c))]
|
|
[(string? c) c]
|
|
[else (case c
|
|
[(ndash) "--"]
|
|
[(ldquo rdquo) "\""]
|
|
[(rsquo) "'"]
|
|
[(rarr) "->"]
|
|
[else (format "~s" c)])])]
|
|
[(c renderer sec ht)
|
|
(cond
|
|
[(element? c) (content->string (element-content c) renderer sec ht)]
|
|
[(delayed-element? c)
|
|
(content->string (force-delayed-element c renderer sec ht)
|
|
renderer sec ht)]
|
|
[else (element->string c)])]))
|
|
|
|
)
|
|
|