(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)

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

  (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)
    (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-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 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 (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 (_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 (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 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 (spod-work op . args)
    ;(display (format "op=~s, args=~s~%" op args))
    (cond 
     ((eq? op '=)        (apply head1 args))
     ((eq? op '==)       (apply head2 args))
     ((eq? op '===)      (apply head3 args))
     ((eq? op '====)     (apply head4 args))
     ((eq? op '*)        (apply bold args))
     ((eq? op '/)        (apply italics args))
     ((eq? op '%)        (apply code args))
     ((eq? op '%%)       (apply scode args))
     ((eq? op 'image)    (apply image args))
     ((eq? op 'table)    (apply table args))
     ((eq? op 'row)      (apply srow args))
     ((eq? op 'cell)     (apply scell args))
     ((eq? op 'ccell)    (apply sccell args))
     ((eq? op 'rcell)    (apply srcell args))
     ((eq? op 'link)     (apply link args))
     ((eq? op 'p)        (apply p args))
     ((eq? op '\\)       (apply lb args))
     ((eq? op 'items)    (apply items args))
     ((eq? op '-)        (apply item args))
     ((eq? op 'verbatim) (apply verbatim args))
     ((eq? op 'syn)      (apply syn args))
     ((eq? op 'spod)     (apply spodf args))
     ((eq? op 'info)     (apply _sinfo args))
     ((eq? op 'over)     (apply _over args))
     (else 
      ;(display (format "spod-work doesn't know ~a~%" op))
      (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 (->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))))
	

  )