(module spod-html mzscheme
(require "scm2xexpr.scm")
(require "spod.scm")
(require (lib "xml.ss" "xml"))
(provide spod-install-html-provider)
(define (spod-html-provider)
(define SYN "scm")
(define TAB 8)
(define (spod-null? a)
(if (not (list? a))
(spod-null? (list a))
(if (null? a)
#t
(if (eq? (car a) 'spod-empty)
(spod-null? (cdr a))
#f))))
(define (spod-merge1 first . rest)
(if (null? rest)
first
(if (eq? first 'spod-empty)
rest
(let ((R (if (and (and (list? (car rest)) (list? (caar rest))) (null? (cdr rest)))
(car rest)
rest)))
(if (list? first)
(if (list? (car first))
(append first R)
(cons first R))
(cons first R))))))
(define (spod-merge . args)
(let ((R (apply spod-merge1 args)))
R))
(define (list-of-list? x)
(if (list? x)
(if (null? x)
#f
(if (list? (car x))
#t
#f))
#f))
(define (header? x)
(if (xexpr? x)
(let ((e (car x)))
(or (eq? e 'h1) (eq? e 'h2) (eq? e 'h3) (eq? e 'h4)))
#f))
(define (xexpr? x)
(if (list? x)
(if (null? x)
#f
(if (symbol? (car x))
(if (null? (cdr x))
#f
(if (list? (cadr x))
(if (null? (cadr x))
#t
(if (list? (caadr x))
(if (null? (caadr x))
#f
(if (symbol? (caaadr x))
#t
#f))
#f))
#f))
#f))
#f))
(define (xexpr-with-attrs? x)
(if (xexpr? x)
(if (null? (cdr x))
#f
(if (list? (cadr x))
(or (null? (cadr x)) (list-of-list? (cadr x)))
#f))
#f))
(define (post-process1 pod)
(define (take-until-next-header L)
(if (null? L)
'()
(if (header? (car L))
'()
(cons (car L) (take-until-next-header (cdr L))))))
(define (drop-until-next-header L)
(if (null? L)
'()
(if (header? (car L))
L
(drop-until-next-header (cdr L)))))
(define (process L)
(if (null? L)
'()
(if (list-of-list? (car L))
(post-process1 (car L))
(if (list? (car L))
(if (header? (car L))
(append
(list (car L) (append `(div ((class ,(format "indent-~a" (caar L)))))
(process (take-until-next-header (cdr L)))))
(process (drop-until-next-header (cdr L))))
(cons (car L) (process (cdr L))))
(begin
(if (xexpr-with-attrs? L)
(cons (car L) (cons (cadr L) (process (cddr L))))
(if (xexpr? L)
(cons (car L) (cons (cadr L) (process (cddr L))))
(cons (car L) (process (cdr L))))))))))
(if (list? pod)
(process pod)
pod))
(define (post-process-2 P SPACE)
(if (null? P)
'()
(if (xexpr? P)
(cons (car P)
(cons (cadr P)
(post-process-2 (cddr P)
(if (string=? SPACE "")
""
(if (eq? (car P) 'pre) "" " ")))))
(if (list? P)
(map (lambda (e) (post-process-2 e SPACE)) P)
(if (comment? P)
P
(format "~a~a" P SPACE))))))
(define (post-process pod)
(let ((P (post-process1 pod)))
(post-process-2 P " ")))
(define (->spod pod . name)
(let ((xexpr (post-process (append `(div ((class "spod")))
pod))))
(let ((html (xexpr->string xexpr)))
(if (not (null? name))
(let ((fh (open-output-file (format "~a.htmlpart" (car name)) 'replace)))
(display html fh)
(close-output-port fh)))
html)))
(define (post args)
(map (lambda (e)
(if (list? e)
(if (null? (cdr e))
(car e)
e)
e))
args))
(define (head1 . args)
(cons 'h1 (cons '() (post args))))
(define (head2 . args)
(cons 'h2 (cons '() (post args))))
(define (head3 . args)
(cons 'h3 (cons '() (post args))))
(define (head4 . args)
(cons 'h4 (cons '() (post args))))
(define (bold . args)
(cons 'b (cons '() (post args))))
(define (italics . args)
(cons 'em (cons '() (post args))))
(define (code . args)
(cons 'code (cons '() (post args))))
(define (scode . args) (cons 'code (cons '() (post args))))
(define (link where . text)
`(a ((href ,where)) ,(if (null? text)
where
text)))
(define (image description link position . size)
(let ((attribs `((alt ,description) (src ,link) (class ,(format "image-~a" position)))))
(if (not (null? size)) (append attribs `((style ,(format "width:~a;" (car size))))))
`(img ,attribs)))
(define (p . args)
(cons 'p (cons '() (post args))))
(define (lb . args)
(append args '((br ()))))
(define (items . args)
(cons 'ul (cons '() (post args))))
(define (item . args)
(cons 'li (cons '() (post args))))
(define (verbatim . args)
(if (or (string-ci=? SYN "scm") (string-ci=? SYN "ss"))
(append `(pre ((class ,SYN)))
(list
(scheme-text->xexpr
(apply string-append
(map (lambda (e)
(if (procedure? e)
(format "~a~%" (e))
(format "~a~%" e)))
args)))))
(append `(pre ((class ,SYN))
(apply string-append
(map (lambda (e)
(if (procedure? e)
(format "~a~%" (e))
(format "~a~%" e)))))))))
(define (syn language . tab)
(set! SYN (format "~a" (if (procedure? language) (language) language)))
(set! TAB (if (null? tab) 8 (car tab)))
(make-comment (format "syn: ~a, tab: ~a" SYN (if (procedure? TAB) (TAB) TAB))))
(define (spodf . args)
args)
(define TABLENO 0)
(define (table sizes name caption border frame position size . args)
(set! TABLENO (+ TABLENO 1))
`(a ((name ,(if (string=? (format "~a" name) "")
(format "table~a" TABLENO)
(format "~a" name))))
(table ((style ,(format "border: ~apx solid black;width:~a;"
(if (eq? border 'border) 1 0)
size))
(class ,(format "table-~a" position)))
,(if (string=? (format "~a" caption) "")
(make-comment "no caption")
`(caption ,caption))
args)))
(define (srow . args)
`(tr () ,args))
(define (scell . args)
`(td ((class "left")) ,args))
(define (sccell . args)
`(td ((class "center")) ,args))
(define (srcell . args)
`(td ((class "right")) ,args))
(define (over . args)
`(div ((class "indent")) ,args))
(lambda (cmd . args)
(letrec ((f (lambda (cmds)
(if (null? cmds)
(error (format "spod-html-provider: No such command '~a" cmd))
(if (eq? (caar cmds) cmd)
(apply (cadar cmds) args)
(f (cdr cmds)))))))
(f (list
(list 'null? spod-null?)
(list 'spod-merge spod-merge)
(list '->spod ->spod)
(list 'post-process post-process)
(list 'over over)
(list 'srcell srcell)
(list 'sccell sccell)
(list 'scell scell)
(list 'srow srow)
(list 'table table)
(list 'spodf spodf)
(list 'verbatim verbatim)
(list 'syn syn)
(list 'item item)
(list 'items items)
(list 'lb lb)
(list 'p p)
(list 'image image)
(list 'link link)
(list 'scode scode)
(list 'code code)
(list 'italics italics)
(list 'bold bold)
(list 'head1 head1)
(list 'head2 head2)
(list 'head3 head3)
(list 'head4 head4)))))
)
(define (spod-install-html-provider)
(spod-install-provider (spod-html-provider)))
(spod-install-html-provider)
)
![[logo]](/logo.png){kind=logo}