(module eggdoc
(eggdoc:version
eggdoc:doctype
eggdoc:css
eggdoc:make-defsig
eggdoc:warnings ; whether to display transform errors
eggdoc:make-stylesheet ; generic stylesheet
eggdoc:make-html-stylesheet ; HTML stylesheet
eggdoc:transform ; generic transformer
eggdoc->html/really ; HTML transformer
eggdoc->html ; alias to eggdoc:transform :(
eggdoc:result ; last parse result (semi-internal)
eggdoc:default-stylesheet-maker ; internal
eggdoc:default-transformer ; internal
eggdoc:derive-egg-name ; internal
)
(import scheme chicken data-structures)
(require-extension sxml-transforms)
;; TODO:
;; - examples tag requires explicit pre. One way to get around is to add a
;; 'verbatim tag and examples would cease to be special.
(define eggdoc:version "1.3.1")
(define eggdoc:doctype (make-parameter ""))
(define eggdoc:warnings (make-parameter #t))
;; Alist containing parse result for last parse. Officially undocumented.
;; Returned from the eggdoc transformer, but some eggdoc scripts discard it.
(define eggdoc:result (make-parameter '()))
;; CSS text put verbatim between tags; must be wrapped
;; in HTML comments.
(define eggdoc:css (make-parameter "
"
))
;; Get egg name from DOC (and implicitly add to eggdoc:result).
(define (eggdoc:derive-egg-name doc)
(let ((name (alist-ref 'name (cdar doc))))
(unless name
(error 'eggdoc "name element required"))
(let ((name (car name))) ; just take the first elt, don't squash the list
(eggdoc:result (cons (cons 'name name)
(eggdoc:result)))
name)))
(define (unordered-list elts)
`(ul ,(map (lambda (x) (list 'li x))
elts)))
;; Helper function -- convert e.g. a (parameter) tag into a definition/signatures group.
(define eggdoc:make-defsig
(lambda (tag sig . body)
`(definition (signatures (signature ,(symbol->string tag) ,sig))
,body)))
(define make-defsig eggdoc:make-defsig)
(define (eggdoc:make-html-stylesheet Doc)
(let ((egg-name (eggdoc:derive-egg-name Doc)))
;; *macro* is required if you wish the rule to be reprocessed--i.e. you output
;; SXML and need it translated then to HTML. You can also use *preorder* and
;; call pre-post-order again directly.
`((history *macro* . ,(lambda (tag . versions)
`(section "Version"
(ul ,versions))))
(name *macro* . ,(lambda _ '())) ;; eat this; advisory element for title and page header
;; [though, this will eat ALL "name" elements]
(version *macro* . ,(lambda (tag number . desc)
`(li ,number " " ,desc)))
(section *macro* . ,(lambda (tag name . contents)
`((div (@ (class "section"))
(h3 ,name)
,contents)))) ;; add div for section-contents?
(subsection *macro* . ,(lambda (tag name . contents)
`(div (@ (class "subsection"))
(h4 ,name)
,contents)))
(subsubsection *macro* . ,(lambda (tag name . contents)
`(div (@ (class "subsubsection"))
(h5 ,name)
,contents)))
(subsubsubsection *macro* . ,(lambda (tag name . contents)
`(div (@ (class "subsubsubsection"))
(h6 ,name)
,contents)))
(author *macro* . ,(lambda (tag name)
`(section "Author"
,name)))
(description *macro* . ,(lambda (tag . contents) `(section "Description" ,contents)))
;; Create title from egg name
;; Warning: contents may hit apply parameter limit.
(eggdoc:begin *macro* . ,(lambda (tag . contents)
(let ((name egg-name))
`((eggdoc-doctype)
(eggdoc-version)
(html (head (title "Eggs Unlimited - " ,name)
(eggdoc-style))
(body
(div (@ (id "header"))
(h2 ,name)
(div (@ (id "eggheader"))
(a (@ (href "index.html"))
(img (@ (src "egg.jpg")
(alt "[Picture of an egg]"))))))
(div (@ (id "body"))
,contents)
(div (@ (id "footer"))
(hr)
(a (@ (href "index.html")) "< Egg index")
(div (@ (id "revision-history"))
#\$ "Revision$ " #\$ "Date$")
(n_)))))))) ;; nbsp so div block takes up space
(eggdoc-doctype . ,(lambda (tag)
(eggdoc:doctype)))
(eggdoc-version . ,(lambda (tag)
`(#\newline "")))
(eggdoc-style . ,(lambda (tag)
`("")))
(download *macro* . ,(lambda (tag name)
(if (pair? name)
`(section "Download"
,name)
`(section "Download"
(a (@ (href ,name))
,name)))))
;; (requires elt_1 .. elt_n) -- creates unordered list
(requires *macro* . ,(lambda (tag . reqs)
`(section "Requires"
,(unordered-list reqs))))
;; (usage) or (usage elt_1 .. elt_n)
;; If arglist is empty, defaults to "(require-extension ")
;; Otherwise, inserts elements verbatim
(usage *macro* . ,(lambda (tag . reqs)
(if (null? reqs)
`(section "Usage"
(tt "(require-extension " ,egg-name ")"))
`(section "Usage"
,reqs))))
(documentation *macro* . ,(lambda (tag . elts)
`(section "Documentation" ,elts)))
;; should be more descriptive than "group"
(group *macro* . ,(lambda (tag . elts)
`(dl ,elts)))
;;; Signatures
;; Syntax: (definition (signatures (signature type sig) ...) def)
;; Not enforced, though.
(signature *macro* . ,(lambda (tag type sig)
`((strong ,type ":") " " ,sig)))
(signatures *macro* . ,(lambda (tag . sigs)
(intersperse sigs '((br)) )))
(definition *macro* . ,(lambda (tag term . def)
`((dt (@ (class "definition"))
,term)
(dd ,def))))
;; Redundant -- should generate these programatically -- or change to pass type in an attribute
(macro *macro* . ,make-defsig)
(record *macro* . ,make-defsig)
(procedure *macro* . ,make-defsig)
(parameter *macro* . ,make-defsig)
(with-default-param *macro*
. ,(lambda (tag param default)
(conc "(" param ") [default: " default "]")))
;; This works by calling pre-post-order on symbol-table's children
;; with the 'describe binding prepended to global bindings (so it's effectively local).
;; This means symbol-table can't be a macro so HTML conversion must be
;; performed manually. It may be possible to call post-order using universal-conversion-rules.
(symbol-table ((describe *macro* . ,(lambda (tag symbol description)
`(tr (td (@ (class "symbol"))
,symbol)
(td ,description)))))
. ,(lambda (tag . contents)
`(")))
;; If bare license, assume pre tag, otherwise verbatim
(license *macro* . ,(lambda (tag contents)
`(section
"License"
,(if (pair? contents)
contents
`(pre (@ (id "license")) ,contents)))))
;; the same as license
(examples *macro* . ,(lambda (tag . contents)
`(section "Examples"
(div (@ (id "examples"))
,contents))))
(url *macro* . ,(lambda (tag href . contents)
`(a (@ (href ,href))
,(if (pair? contents)
contents
href))))
,@ universal-conversion-rules)))
;; HTML transformer
;; (eggdoc:transform [XML-STYLESHEET])
;; Default stylesheet is (eggdoc:make-stylesheet doc), which is user-visible
;; so you can append to or otherwise modify it, and pass it in.
(define (eggdoc->html/really doc . rest)
(let-optionals rest ((ss (eggdoc:make-html-stylesheet doc)))
(SRV:send-reply (pre-post-order doc ss))
(eggdoc:result)))
;;; API shim
;; This indirection is necessary because the existing API is not
;; extensible, and I don't want to revamp it since eggdoc is
;; deprecated. EGGDOC->HTML is the gateway to the default
;; transformer, so named for historical reasons. Client documents
;; should continue to use EGGDOC->HTML and EGGDOC:MAKE-STYLESHEET,
;; which point to internal implementations that may be overridden by
;; other eggs (eggdoc-svnwiki). Clients may also use EGGDOC:TRANSFORM
;; (alias of EGGDOC->HTML).
(define eggdoc:default-stylesheet-maker
(make-parameter eggdoc:make-html-stylesheet))
(define eggdoc:default-transformer
(make-parameter eggdoc->html/really))
(define (eggdoc:make-stylesheet doc)
((eggdoc:default-stylesheet-maker) doc))
(define (eggdoc:transform doc . rest)
(apply (eggdoc:default-transformer) doc rest))
(define eggdoc->html eggdoc:transform)
)