(module spod mzscheme
        (provide spod
                 spod-extend
                 spod-join
                 spod-comma
                 spod-concat
                 spod-nlnl
                 spod-nl
                 spod-append
                 spod-empty
                 spod-enclose
                 spod-apply
                 spod-merge
                 spod-null?
                 spod-module-def
                 spod-module-add
                 spod-module-doc
                 %spod-module-add
                 spod-define
                 ->spod
                 extract-spod
                 spod-install-provider
                 spod-provider
                 )

        ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
        
        (define SPOD-PROVIDER #f)
        
        (define (spod-install-provider provider)
          (set! SPOD-PROVIDER provider))
        
        (define (spod-provider)
          SPOD-PROVIDER)
        
        ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

        (define-syntax spod-define
          (syntax-rules ()
            ((_ documentation
                function-definition
                body ...)
             (begin
               (spod-module-add (s=== (format "~a" 'function-definition))
                                documentation)
               (define function-definition body ...))
             )))

        ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

        (define (spod-null?  a)
          (SPOD-PROVIDER 'null? a))

        (define (spod-join sym list-of-stuff)

          (define (value e)
            e)

          (define (i-cons L)
            (if (null? L)
                L
                (if (null? (cdr L))
                    (list (value (car L)))
                    (cons (value (car L)) (cons sym (i-cons (cdr L)))))))

          ;(display (format "spod-join: ~s ~s~%" sym list-of-stuff))
          (let ((R
                 (if (not (list? list-of-stuff))
                     (spod-join sym (list list-of-stuff))
                     (if (eq? sym 'spod-empty)
                         list-of-stuff
                         (i-cons list-of-stuff)))))
            ;(display (format "spod-join: R=~s~%" R))
            R)
          )

        (define (spod-concat list-of-stuff)
          (spod-join " " list-of-stuff))

        (define (spod-comma list-of-stuff)
          (spod-join ", " list-of-stuff))

        (define (spod-nl list-of-stuff)
          (spod-join "\n" list-of-stuff))

        (define (spod-append list-of-stuff)
          (spod-join 'spod-empty list-of-stuff))

        (define (spod-nlnl sentence)
          (if (not (list? sentence))
              (spod-nlnl (list sentence))
              (append sentence (list "\n\n"))))

        (define (spod-enclose left middle right)
          (if (not (list? middle))
              (spod-enclose left (list middle) right)
              (cons left (append middle (list right)))))

        (define (spod-empty)
          'spod-empty)

        (define (spod-merge . args)
          (lambda () (apply SPOD-PROVIDER 'spod-merge (extract-spod args))))
        
        ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

        (define (spod-standard-provider)
          
          (define (spod-merge first . rest)

            (define (g x)
              (if (not (list? x))
                  x
                  (if (null? x)
                      x
                      (if (list? (car x))
                          (append (g (car x)) (g (cdr x)))
                          (if (eq? (car x) 'spod-empty )
                              (g (cdr x))
                              (cons (car x) (g (cdr x))))))))

            (if (null? rest)
                first
                (g (cons first rest))))
          
          (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 (head1 . args)
            (spod-nlnl
             (spod-concat (cons "=head1" args))))

          (define (head2 . args)
            (spod-nlnl
             (spod-concat (cons "=head2" args))))

          (define (head3 . args)
            (spod-nlnl
             (spod-concat (cons "=head3" args))))

          (define (head4 . args)
            (spod-nlnl
             (spod-concat (cons "=head4" args))))

          (define (bold . args)
            (spod-enclose "B%=HOD%%" (spod-concat args) "%%HOD=%"))

          (define (italics . args)
            (spod-enclose "I%=HOD%%" (spod-concat args) "%%HOD=%"))

          (define (code . args)
            (spod-enclose "C%=HOD%%" (spod-concat args) "%%HOD=%"))

          (define (scode . args)
            (spod-enclose "S%=HOD%%" (apply code args) "%%HOD=%"))

          (define (link where . text)
            (spod-enclose "L%=HOD%%" (spod-merge (if (null? text)
                                                     where
                                                     (spod-concat text)) "|" where ) "%%HOD=%"))

          (define (image description link position . size)
            (define (find-ext pos)
              (if (< pos 0)
                  ""
                  (if (char=? (string-ref link pos) #\.)
                      (substring link (+ pos 1) (string-length link))
                      (find-ext (- pos 1)))))

            (let ((type (find-ext (- (string-length link) 1))))
              (spod-nlnl
               (spod-concat (list "=image"
                                  (spod-comma description link link type position (if (null? size)
                                                                                      (spod-empty)
                                                                                      (car size)))
                                  )))))

          (define (p . args)
            (spod-nlnl
             (spod-concat args)))

          (define (lb . args)
            (spod-append (list (spod-concat args) "E%=HOD%%lb%%HOD=%\n")))

          (define (items . args)
            (spod-enclose "=over 1\n\n" (spod-append args) "=back\n\n"))

          (define (item . args)
            (spod-nlnl
             (spod-append (list (spod-nlnl "=item *") (spod-concat args)))))

          (define (verbatim . args)
            (map (lambda (s)
                   (if (string? s)
                       (regexp-replace* "[<]" (regexp-replace* "[>]" s "%%HOD=%") "%=HOD%%")
                       s))
                 (spod-nlnl
                  (spod-merge " " (spod-join "\n " args)))))

          (define (syn language . tab)
            (spod-nlnl
             (string-append (format "=syn ~a,~a" language (if (null? tab) 8 (car tab))))))

          (define (spodf . args)
            (spod-append args))

          (define (table sizes name caption border frame position size  . args)
            (spod-merge
             (spod-nlnl (spod "=table " (spod-comma
                                         (cons (spod-concat sizes)
                                               (list caption
                                                     (if (eq? border 'border) 1 0)
                                                     (if (eq? frame 'frame) 1 0)
                                                     name
                                                     position
                                                     size)))))
             args
             (spod-nlnl (spod "=table"))))


          (define (srow . args)
            (spod-merge
             (spod-nlnl "=row")
             args))

          (define (scell . args)
            (spod-merge
             (spod-nlnl "=cell")
             args
             (spod-nlnl "")))

          (define (sccell . args)
            (spod-merge
             (spod-nlnl "=ccell")
             args
             (spod-nlnl "")))

          (define (srcell . args)
            (spod-merge
             (spod-nlnl "=rcell")
             args
             (spod-nlnl "")))

          (define (over . args)
            (spod-merge
             (spod-nlnl "=over 1")
             (spod-nlnl args)
             (spod-nlnl "=back")))
          
          (define (->spod pod . name)
            (define (g pod)
              (apply spod-merge
                     (map (lambda (e)
                            (if (procedure? e)
                                (e)
                                e))
                          pod)))

            (let ((fh (if (null? name)
                          (current-output-port)
                          (if (port? name)
                              name
                              (open-output-file (string-append (format "~a.pod" (car name))) 'text 'replace)))))
              (let ((do-close (not (null? name))))
                (let ((S (replace-escapes
                          (string-append "=pod\n\n"
                                         (apply string-append (map (lambda (e) (format "~a" e))
                                                                   (g pod)))
                                         "=cut\n\n"))))
                  (display S fh)
                  (if do-close
                      (close-output-port fh))
                  S))))
          
          
          (lambda (cmd . args)
            (letrec ((f (lambda (cmds)
                          (if (null? cmds)
                              (error (format "spod-standard-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 '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)))))
          )
        
        (spod-install-provider (spod-standard-provider))

        ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

        (define extensions (list))

        (define (spod-extension op . args)

          (define (f E)
            (if (null? E)
                (eval (cons op args))
                (let ((S (apply (car E) (cons op args))))
                  (if (eq? S #f)
                      (f (cdr E))
                      S))))

          (f extensions))

        (define (spod-extend function)
          (set! extensions (cons function extensions)))

        (define (_sinfo copyright authors license version . id)
          (spod-nlnl
           (spod (s== "Info")
                 (stable '(15 5 80) 'info "" 'no-border 'no-frame 'center ""
                         (sr (sc "Copyright") (scc ":") (sc copyright))
                         (sr (sc "Author(s)") (scc ":") (sc authors))
                         (sr (sc "License") (scc ":") (sc license))
                         (sr (sc "Version") (scc ":") (sc version))
                         (if (null? id)
                             (spod)
                             (spod (sr (sc "Id") (sc ":") (sc (car id)))))))))
        
        (define (spod-work op . args)
          ;(display (format "op=~s, args=~s~%" op args))
          (cond
           ((eq? op '=)        (lambda () (apply (spod-provider) 'head1 args)))
           ((eq? op '==)       (lambda () (apply (spod-provider) 'head2 args)))
           ((eq? op '===)      (lambda () (apply (spod-provider) 'head3 args)))
           ((eq? op '====)     (lambda () (apply (spod-provider) 'head4 args)))
           ((eq? op '*)        (lambda () (apply (spod-provider) 'bold args)))
           ((eq? op '/)        (lambda () (apply (spod-provider) 'italics args)))
           ((eq? op '%)        (lambda () (apply (spod-provider) 'code args)))
           ((eq? op '%%)       (lambda () (apply (spod-provider) 'scode args)))
           ((eq? op 'image)    (lambda () (apply (spod-provider) 'image args)))
           ((eq? op 'table)    (lambda () (apply (spod-provider) 'table args)))
           ((eq? op 'row)      (lambda () (apply (spod-provider) 'srow args)))
           ((eq? op 'cell)     (lambda () (apply (spod-provider) 'scell args)))
           ((eq? op 'ccell)    (lambda () (apply (spod-provider) 'sccell args)))
           ((eq? op 'rcell)    (lambda () (apply (spod-provider) 'srcell args)))
           ((eq? op 'link)     (lambda () (apply (spod-provider) 'link args)))
           ((eq? op 'p)        (lambda () (apply (spod-provider) 'p args)))
           ((eq? op '\\)       (lambda () (apply (spod-provider) 'lb args)))
           ((eq? op 'items)    (lambda () (apply (spod-provider) 'items args)))
           ((eq? op '-)        (lambda () (apply (spod-provider) 'item args)))
           ((eq? op 'verbatim) (lambda () (apply (spod-provider) 'verbatim args)))
           ((eq? op 'syn)      (lambda () (apply (spod-provider) 'syn args)))
           ((eq? op 'spod)     (lambda () (apply (spod-provider) 'spodf args)))
           ((eq? op 'info)     (lambda () (apply _sinfo args)))
           ((eq? op 'over)     (lambda () (apply (spod-provider) 'over args)))
           (else
            ;(display (format "spod-work doesn't know ~a~%" op))
            (lambda () (apply spod-extension (cons op args))))))

        ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
          
        (define-syntax spod-internal
          (syntax-rules ()
            ((_ op)
             (spod-work 'op))
            ((_ op a1)
             (spod-work 'op a1))
            ((_ op a1 ...)
             (spod-work 'op a1 ...))
            ))

        (define-syntax spod1
          (lambda (x)
            (syntax-case x (s= s== s=== s==== sover
                               stable sr sc scc scr
                               sinfo
                               sp spp
                               s\\ s* s/ s% s%%
                               simage slink
                               sitems s-
                               sverb ssyn spod)
                         ((_ (s= a1 ...))
                          (syntax (spod-internal = (spod a1) ...)))
                         ((_ (s== a1 ...))
                          (syntax (spod-internal == (spod a1) ...)))
                         ((_ (s=== a1 ...))
                          (syntax (spod-internal === (spod a1) ...)))
                         ((_ (s==== a1 ...))
                          (syntax (spod-internal ==== (spod a1) ...)))
                         ((_ (s* a1 ...))
                          (syntax (spod-internal * (spod a1) ...)))
                         ((_ (s/ a1 ...))
                          (syntax (spod-internal / (spod a1) ...)))
                         ((_ (s% a1 ...))
                          (syntax (spod-internal % (spod a1) ...)))
                         ((_ (s%% a1 ...))
                          (syntax (spod-internal %% (spod a1) ...)))
                         ((_ (simage a1 ...))
                          (syntax (spod-internal image (spod a1) ...)))
                         ((_ (sitems a1 ...))
                          (syntax (spod-internal items (spod a1) ...)))
                         ((_ (s- a1 ...))
                          (syntax (spod-internal - (spod a1) ...)))
                         ((_ (sverb a1 ...))
                          (syntax (spod-internal verbatim (spod a1) ...)))
                         ((_ (ssyn a1 ...))
                          (syntax (spod-internal syn (spod a1) ...)))
                         ((_ (slink a1 ...))
                          (syntax (spod-internal link (spod a1) ...)))
                         ((_ (sp a1 ...))
                          (syntax (spod-internal p (spod a1) ...)))
                         ((_ (spp a1 ...))
                          (syntax (spod (sp 'a1 ...))))
                         ((_ (s\\ a1 ...))
                          (syntax (spod-internal \\ (spod a1) ...)))
                         ((_ (sinfo a1 ...))
                          (syntax (spod-internal info (spod a1) ...)))
                         ((_ (stable a1 ...))
                          (syntax (spod-internal table (spod a1) ...)))
                         ((_ (sr a1 ...))
                          (syntax (spod-internal row (spod a1) ...)))
                         ((_ (sc a1 ...))
                          (syntax (spod-internal cell (spod a1) ...)))
                         ((_ (scc a1 ...))
                          (syntax (spod-internal ccell (spod a1) ...)))
                         ((_ (scr a1 ...))
                          (syntax (spod-internal rcell (spod a1) ...)))
                         ((_ (spod a1 ...))
                          (syntax (spod-internal spod (spod a1) ...)))
                         ((_ (sover a1 ...))
                          (syntax (spod-internal over (spod a1) ...)))
                         ((_ (any ...))
                          (syntax (any ...)))
                         ((_ a)
                          (syntax a)))))


        (define-syntax spod
          (lambda (x)
            (syntax-case x (quote)
                         ((_ (quote a))
                          (syntax 'a))
                         ((_)
                          (syntax 'spod-empty))
                         ((_ a1 ...)
                          (syntax (spod-merge (spod1 a1) ...)))
                         )))

        (define-syntax spod-apply
          (syntax-rules ()
            ((_ op list-of-args)
             (apply spod-work (cons 'op  list-of-args)))))

        (define %spod-current-module-doc (spod))

        (define (spod-module-def)
          (set! %spod-current-module-doc (spod)))

        (define (%spod-module-add doc)
          (set! %spod-current-module-doc (spod-merge %spod-current-module-doc doc)))

        (define-syntax spod-module-add
          (syntax-rules ()
            ((_ d1 ...)
             (%spod-module-add (spod d1 ...)))))

        (define-syntax spod-module-doc
          (syntax-rules ()
            ((_)
             %spod-current-module-doc)
            ))

        ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

        (define BHODRE (regexp "%=HOD%%"))
        (define EHODRE (regexp "%%HOD=%"))

        (define (replace-escapes S)
          (regexp-replace* EHODRE
                           (regexp-replace* BHODRE
                                            (let ((L (string->list S)))
                                              (apply string-append
                                                     (map (lambda (c)
                                                            (cond
                                                             ((char=? c #\<) "E<lt>")
                                                             ((char=? c #\>) "E<gt>")
                                                             (else (string c))))
                                                          L))) "<")
                           ">"))


        (define (extract-spod pod)
          (if (procedure? pod)
              (extract-spod (pod))
              (if (list? pod)
                  (map extract-spod pod)
                  pod)))
        
        (define (->spod pod . name)
          (apply SPOD-PROVIDER (cons '->spod (cons (extract-spod pod) name))))

        )