(module spod-html mzscheme
        (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)
;            (display (format "first=~s rest=~s ~%" 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)))
 ;             (display (format "result=~s~%" R))
              R))
          
          (define (list-of-list? x)
            (if (list? x)
                (if (null? x)
                    #f
                    (if (list? (car x))
                        #t
                        #f))
                #f))
          
          (define (header? xexpr)
            (if (list-of-list? xexpr)
                #f
                (if (list? xexpr)
                    (let ((e (car xexpr)))
                      (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))
                        #t
                        #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-process 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-process (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))))
                          (if (xexpr-with-attrs? L)
                              (cons (car L) (cons (cadr L) (process (cddr L))))
                              (if (xexpr? L)
                                  (cons (car L) (process (cdr L)))
                                  (cons (car L) (process (cdr L)))))))))
            
            (if (list? pod)
                (process pod)
                pod))
          
          (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 (post args)))

          (define (head2 . args)
            (cons 'h2 (post args)))

          (define (head3 . args)
            (cons 'h3 (post args)))

          (define (head4 . args)
            (cons 'h4 (post args)))

          (define (bold . args)
            (cons 'b (post args)))

          (define (italics . args)
            (cons 'em (post args)))

          (define (code . args)
            (cons 'code (post args)))

          (define (scode . args)     ;;; NEED POSTPROCESSING ON SPACES HERE!
            (cons 'code (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 (post args)))

          (define (lb . args)
            (append args '((br))))

          (define (items . args)
            (cons 'ul (post args)))

          (define (item . args)
            (cons 'li (post args)))

          (define (verbatim . args)
            `(pre ((class ,SYN)) ,args))

          (define (syn language . tab)
            (set! SYN language)
            (set! TAB (if (null? tab) 8 (car tab)))
            (make-comment (format "syn: ~a, tab: ~a" SYN 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)
        
        )