(module spod-roos mzscheme
	(require "spod.scm")
	(provide (all-from-except "spod.scm" spod)
		 (rename spod-roos spod))

   (define (_synopsis . args)
     (spod-merge 
      (spod (s== "Synopsis")) 
      (spod-apply verbatim args)))

   (define (_class-name name)
     (spod (s= 'class (format "~a" name))))

   (define (_class-constructor funcdef . doc)
     (if (spod-null? doc)
	 (spod)
	 (spod-nlnl
	  (spod-merge
	   (spod (s== "Constructor:" (s% (format "~a" funcdef))))
	   doc))))

   (define (_class-supers . supers)
     (if (spod-null? supers)
	 (spod)
	 (if (and (list? (car supers)) (null? (cdr supers)))
	     (apply _class-supers (car supers))
	     (spod-nlnl
	      (spod-merge
	       (spod (s== "Super classes"))
	       (spod-comma (map (lambda (super)
				  (spod (slink super)))
				supers)))))))

   (define (_class-derived . derived)
     (if (spod-null? derived)
	 (spod)
	 (if (and (list? (car derived)) (null? (cdr derived)))
	     (apply _class-derived (car derived))
	     (spod-nlnl
	      (spod-merge
	       (spod (s== "Derived classes"))
	       (spod-comma (map (lambda (deriv)
				  (spod (slink deriv)))
				derived)))))))

   (define (_class-doc . doc)
     (if (spod-null? doc)
	 (spod)
	 (spod-nlnl
	  (spod-merge
	   (spod (s== "Overview"))
	   doc))))

   (define (_class-cleanup . doc)
     (if (spod-null? doc)
	 (spod)
	 (spod-nlnl
	  (spod-merge
	   (spod (s== "Explicit Cleanup"))
	   doc))))

   (define (_private-members pd . members)
     (if (spod-null? members)
	 (spod)
	 (spod-nlnl
	  (spod-merge
	   (spod (s== "Private members") pd)
	   members))))

   (define (_public-members pd . members)
     (if (spod-null? members)
	 (spod)
	 (spod-nlnl
	  (spod-merge
	   (spod (s== "Public members") pd)
	   members))))

   (define (_member-function funcdef . doc)
     (spod-nlnl
      (spod-merge
       (spod (s==== (s% (format "~a" funcdef))))
       doc)))

   (define (_member-variable var . doc)
     (spod-nlnl
      (spod-merge
	(spod (s==== (s% (format "~a" var))))
	doc)))

   (define (_see-also . references)
     (spod-merge
      (spod-nlnl (spod (s== "See also")))
      (spod-nlnl (spod-comma (map (lambda (ref) (spod (slink ref))) references)))))

   (define (_named-pars . args)
     (spod-merge
      (spod (sover (spod-nlnl (spod (s* (s/ "Named parameters"))))
		   (stable '(30 70) 'np "" 'no-border 'no-frame 'center ""
			   (map (lambda (np)
				  (spod (sr (sc (car np)) (sc (cadr np)))))
				args))))))

   (define (_par . args)
      (list 
       (spod (s% (car args)))
       (spod-merge (cdr args))))
		      

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

   (define (spod-roos-work op . args)
     ;(display (format "roos-spod: op=~a, args=~a~%" op args))
     (cond
      ((eq? op 'synopsis)        (apply _synopsis args))
      ((eq? op 'class-name)      (apply _class-name args))
      ((eq? op 'class-supers)    (apply _class-supers args))
      ((eq? op 'class-derived)   (apply _class-derived args))
      ((eq? op 'class-doc)       (apply _class-doc args))
      ((eq? op 'class-def)       (apply _class-constructor args))
      ((eq? op 'private-members) (apply _private-members args))
      ((eq? op 'public-members)  (apply _public-members args))
      ((eq? op 'member-function) (apply _member-function args))
      ((eq? op 'member-variable) (apply _member-variable args))
      ((eq? op 'class-cleanup)   (apply _class-cleanup args))
      ((eq? op 'see-also)        (apply _see-also args))
      ((eq? op 'named-pars)      (apply _named-pars args))
      ((eq? op 'par)             (apply _par args))
      (else 
       (display (format "not part of spod-roos~%"))
       #f)))


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

   (define-syntax spod1
     (lambda (x)
       (syntax-case x (class-synopsis 
		       class-name class-def class-doc class-supers class-derived class-cleanup
		       class-private class-public 
		       member-function member-var
		       named-pars par
		       see-also)
         ((_ (class-synopsis a1 ...))
	  (syntax (spod-internal synopsis (spod-roos a1) ...)))
	 ((_ (see-also a1 ...))
	  (syntax (spod-internal see-also (spod-roos a1) ...)))
	 ((_ (class-name a1 ...))
	  (syntax (spod-internal class-name (spod-roos a1) ...)))
	 ((_ (class-def a1 ...))
	  (syntax (spod-internal class-def (spod-roos a1) ...)))
	 ((_ (class-cleanup a1 ...))
	  (syntax (spod-internal class-cleanup (spod-roos a1) ...)))
	 ((_ (class-doc a1 ...))
	  (syntax (spod-internal class-doc (spod-roos a1) ...)))
	 ((_ (class-supers a1 ...))
	  (syntax (spod-internal class-supers (spod-roos a1) ...)))
	 ((_ (class-derived a1 ...))
	  (syntax (spod-internal class-derived (spod-roos a1) ...)))
	 ((_ (class-private pd a1 ...))
	  (syntax (spod-internal private-members pd (spod-roos a1) ...)))
	 ((_ (class-public pd a1 ...))
	  (syntax (spod-internal public-members pd (spod-roos a1) ...)))
	 ((_ (member-function a1 ...))
	  (syntax (spod-internal member-function (spod-roos a1) ...)))
	 ((_ (member-var a1 ...))
	  (syntax (spod-internal member-variable (spod-roos a1) ...)))
	 ((_ (named-pars p1 ...))
	  (syntax (spod-internal named-pars (spod-roos p1) ...)))
	 ((_ (par p ...))
	  (syntax (spod-internal par (spod-roos p) ...)))
	 ((_ (any ...))
	  (syntax (spod (any ...))))
	 ((_ a)
	  (syntax (spod a))))))


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


)