; Evaluation rules to convert OMF or MTOC SXML to an HTML document ; (description) ; ; $Id: OMF-html.scm,v 3.1 2003/03/15 06:45:41 oleg Exp oleg $ (define (scm-file-to-HTML filename-from filename-to) (let ((content (call-with-input-file filename-from read))) (with-output-to-file filename-to (lambda () (generate-HTML content))) (cerr "Created " filename-to nl))) ; Generating HTML (define (generate-HTML Content) (SRV:send-reply (pre-post-order Content (main-ss Content)))) ; Stylesheets (define (main-ss Content) (generic-web-rules Content `( (verbatim-example ; set off pieces of code: one or several lines . ,(lambda (tag . lines) (list "
" (map (lambda (line) (list " " line nl)) lines) " |
" elems "
")))) . ,(lambda (tag . elems) elems)) ; An XML element ; (element name content) ; We create an anchor (string-append "Element." name) (element *preorder* . ,(lambda (tag name content) (pre-post-order `((a (@ (name (anchor ,name))) (n_)) (br) (table (@ (cellspacing 0) (cellpadding 0) (border 0)) (tr (td (@ (width 20)) (n_)) (th (@ (valign "top") (align "left")) (font (@ (size "-1")) "XML DTD"))) (tr (td (@ (width 20)) (n_)) (td (@ (valign "top")) (pre ""))))) (main-ss Content)))) ; The following elements attr, attr-ref, datatype, ; and datatype-ref are mere containers for data. ; These elements are described here for the ease of reference ; and for convenience. ; Their "meaning" (and translation into HTML or DTD) is ; provided by the stylesheets of their parent elements: ; attlist, simple-type, etc. ; An attribute declaration may be either definition or a reference ; A reference points to a definition (in an parameter entity or ; parameter entity set -- in terms of DTD) ; Attribute definition ; (attr name datatype description . other-metadata) ; name is a string ; datatype is either a (datatype ...) element or an (xref ...) ; element ; description is a string or a list ; other metadata: note, example, domain-expr elements ; ; Attribute reference ; (attr-ref name (xref ...) description . other-metadata) ; ; Datatype definition ; (datatype db-type dtd-type default-value) ; where ; db-type: CHAR(4), INT, etc. ; dtd-type: NMTOKEN, CDATA ; default-value: #t (for required), #f (for implied), or other ; (attlist ; An attribute list of an element *preorder* . ,(lambda (tag elem-name . attrs) ; attrs is a list of 'attr' above (pre-post-order `((h4 "Attributes") (attlist-table ,elem-name ,@attrs) (br) (attlist-dtd-frag ,elem-name ,@attrs)) (main-ss Content) ))) ; A reference ; (xref "pe-name") ; (xref "pe-name" "URL") ; where "pe-name" is a string: parameter entity name (xref . ,(lambda (tag pe-name . urls) (if (null? urls) pe-name urls))) ; Generating anchor names for items within DTD (anchor . ,(lambda (tag . name-pieces) (list-intersperse (cons "DTD" name-pieces) #\.))) ; A collection of 'attrs', used to generate a table with ; human-redable description of the attributes ; Used internally. ; (attlist-table name . attrs) re-writes into ; (attlist-table-elem attlist-table-rows) (attlist-table *preorder* . ,(lambda (tag elem-name . attrs) (pre-post-order `(attlist-table-elem ,@(pre-post-order attrs `((attr *preorder* . ,(lambda (tag name datatype description . other-metadata) `(attlist-table-row (a (@ (name (anchor ,elem-name ,name))) ,name) ,description ,datatype ,@other-metadata))) (attr-ref *preorder* . ,(lambda (tag name ref description . other-metadata) `(attlist-table-row (a (@ (href ,ref)) ,name) ,description (n_) ,@other-metadata)))))) (main-ss Content)))) ; (attlist-table-elem attlist-table-rows) ; Presenting the attlist table as an HTML table (attlist-table-elem *preorder* . ,(lambda (tag . rows) (pre-post-order `((table (@ (cellspacing 2) (cellpadding 0) (frame "border") (rules "rows") (width "100%") (bgcolor "#D0D0D0")) ,(pre-post-order rows `((*text* . ,(lambda (trigger str) str)) (*default* . ,(lambda (tag . elems) (cons tag elems))) (note . ,(lambda (tag . elems) (cons '(br) elems))) (example . ,(lambda (tag . elems) (cons '(br) (cons "Example: " elems)))) (domain-expr . ,(lambda (tag . elems) (cons '(br) (cons "Domain expr: " elems)))) (datatype . ,(lambda (tag db-type dtd-type default-value) `(,db-type ,(and (eq? default-value #f) " or omitted") (br) (code ,dtd-type)))) ; A row of the attlist table below ; (attlist-table-row head description type . other-descr) ; where 'head' is often a named anchor over the attribute name, ; 'type' is database/DTD or similar type ; other-descr includes (notes ...) (example ...) etc. (attlist-table-row . ,(lambda (tag head description type . other-descr) `((tr (th (@ (colspan 3) (align "LEFT") (valign "BOTTOM")) ,head)) (tr (td (@ (width 20)) (n_)) (td ,description) (td ,type)) ,(and (pair? other-descr) `(tr (td (@ (width 20)) (n_)) (td (@ (colspan 2)) ,other-descr ))) (tr (td (@ (height 10) (colspan 3)) (n_))) ))) )))) (main-ss Content)))) ; Given the set of attributes, generate a DTD ATTLIST declaration (attlist-dtd-frag ((*text* . ,(lambda (trigger str) str)) (*default* . ,(lambda (tag . elems) '())) ;(cons tag elems))) (datatype . ,(lambda (tag db-type dtd-type default-value) (list " " dtd-type " " (case default-value ((#t) "#REQUIRED") ((#f) "#IMPLIED") (else (list #\' default-value #\')))))) ; (note . ,(lambda _ '())) ; (example . ,(lambda _ '())) ; (domain-expr . ,(lambda _ '())) (xref . ,(lambda (tag pe-name . urls) (list "%" pe-name ";"))) (attr . ,(lambda (tag name datatype description . other-metadata) (list "\n\t" name datatype))) (attr-ref . ,(lambda (tag name ref description . other-metadata) (list "\n\t" ref))) ) . ,(lambda (tag elem-name . attrs) (pre-post-order `(table (@ (cellspacing 0) (cellpadding 0) (border 0)) (tr (td (@ (width 20)) (n_)) (td (@ (valign "top")) (pre "\n")))) universal-conversion-rules))) (attxref ; A cross-ref to an attribute in an element . ,(lambda (tag elem-name attr-name) (list "" elem-name "." attr-name "
\n")))
(attset ; A collection of attributes (a complex type)
*preorder* .
,(lambda (tag set-name . attrs) ; attrs is a list of 'attr' above
(pre-post-order
`((a (@ (name ,set-name)) (n_))
(attlist-table ,set-name ,@attrs)
(br)
(entity-dtd-frag ,set-name ,@attrs))
(main-ss Content) )))
; (table (@ (cellspacing 0) (cellpadding 0) (border 0))
; (tr
; (td (@ (width 20)) (n_))
; (td (@ (valign "top"))
; (pre
; "\n<!ENTITY % " ,set-name " \""
; ,(post-order attrs
; ))
; "\n\">")))))
; universal-protected-rules)))
(entity ; Definition of an internal parsed entity
*preorder*
. ,(lambda (tag name . fragments)
(post-order
`((br)
(table (@ (cellspacing 0) (cellpadding 0) (border 0))
(tr
(td (@ (width 20)) (n_))
(th (@ (valign "top") (align "left"))
(font (@ (size "-1")) "XML DTD")))
(tr
(td (@ (width 20)) (n_))
(td (@ (valign "top"))
(pre
"")))))
universal-conversion-rules)))
; A collection of simple types and datatype declarations
; (simple-types title decl ...)
; where
; decl is one of:
; attr as explained earlier
; (attr (entity-name attr-name) datatype description . other-metadata)
; (decl name datatype description . other-metadata)
; similar to 'attr' but the default value flag in datatype is
; ignored. This only declares the type of (attribute) values
(simple-types ; A simple type: an attribute type
*preorder* .
,(lambda (tag title . attrs) ; attrs is a list of 'attr' above
(pre-post-order
`((a (@ (name ,title)) (n_))
(simple-type-table ,title ,@attrs)
(br)
(simple-type-dtd-frag ,title ,@attrs))
(main-ss Content) )))
; A collection of 'decls', used to generate a table with
; human-redable description of the attributes
; Used internally.
; (simple-type-table title . decls) re-writes into
; (attlist-table-elem attlist-table-rows)
(simple-type-table
*preorder* .
,(lambda (tag title . decls)
(pre-post-order
`(attlist-table-elem
,@(pre-post-order decls
`((attr
*preorder* .
,(lambda (tag name datatype description . other-metadata)
(let*-values
(((entity-name attr-name)
(if (pair? name) (apply values name)
(values name name))))
`(attlist-table-row
((a (@ (name
(anchor ,title ,entity-name)))
,entity-name)
,(and (pair? name)
`((n_) "(" (code ,attr-name) ")")))
,description
,datatype
,@other-metadata))))
(decl
*preorder* .
,(lambda (tag name datatype description . other-metadata)
`(attlist-table-row
(a (@ (name (anchor ,title ,name))) ,name)
,description
,datatype
,@other-metadata))))))
(main-ss Content))))
; Given the set of attributes, generate DTD ENTITIES declaration
(simple-type-dtd-frag
((*text* . ,(lambda (trigger str) str))
(*default* . ,(lambda (tag . elems) '())) ;(cons tag elems)))
(datatype .
,(lambda (tag db-type dtd-type default-value)
(list dtd-type
(case default-value
((#t) " #REQUIRED")
((#f) " #IMPLIED")
((()) #f)
(else
(list " " #\' default-value #\'))))))
(xref .
,(lambda (tag pe-name . urls)
(list "%" pe-name ";")))
(attr .
,(lambda (tag name datatype description . other-metadata)
(let*-values
(((entity-name attr-name)
(if (pair? name) (apply values name)
(values name name))))
(list nl ""))))
(decl .
,(lambda (tag name datatype description . other-metadata)
(list nl "")))
)
. ,(lambda (tag elem-name . decls)
(pre-post-order
`(table (@ (cellspacing 0) (cellpadding 0) (border 0))
(tr
(td (@ (width 20)) (n_))
(td (@ (valign "top"))
(pre ,decls))))
universal-conversion-rules)))
)))