;;; -*- Scheme -*-
;; eggdoc-svnwiki

;; Limitations
;; Nested lists are not handled
;; Elements within lists may not be expanded (untested)
;; Nested definition lists won't render correctly (limitation of svnwiki)
;; #xxx at beginning of line or within <td> is rendered as list (svnwiki bug)
;; Certain eggdocs may contain extraneous whitespace; if at beginning of line,
;;   may result in inadvertent PRE.
;; Poor escaping will no doubt cause problems.
;; <read-syntax> is not a valid svnwiki tag.
;; <img> not handled.  Should use alt= if present.

(module eggdoc-svnwiki
 (eggdoc:make-svnwiki-stylesheet
  eggdoc->svnwiki
  eggdoc:svnwiki-override!)

(import scheme chicken)
(use eggdoc)
(use sxml-transforms sxpath)
(use regex data-structures srfi-1)

;;; tag helpers

(define (eggdoc:warning . rest)  ; Maybe move this to eggdoc.
  (when (eggdoc:warnings)
      (apply warning rest)))

(define (eat-tag . expr)
  (if (pair? expr)
      (cdr expr)
      '() ))
(define (eat-tag-and-warn tag . body)
  (eggdoc:warning (conc "eggdoc-svnwiki: ate " tag " tag"))
  (eat-tag tag body))
(define (alias-tag alias)
  (lambda (tag . body)
    (cons alias body)))

(define (discard . args) '())
(define (discard-and-warn . args)
  (eggdoc:warning (conc "eggdoc-svnwiki: discarded " args))
  '())
(define (make-section prefix)
  (lambda (tag name . contents)
    (list #\newline prefix name #\newline #\newline contents)))
(define make-defsig eggdoc:make-defsig)

;;; main
;; The only character worth escaping is < ; everything else such as { ' etc.
;; occurs in pairs and can't be detected here.  Even < is overloaded;
;; <-> is converted to an entity but <table> is a tag.
(define string->good-svnwiki
  ; (make-char-quotator '((#\< . "<nowiki>&lt;</nowiki>"))) ; incredibly ugly
  identity)  

;; Pull certain headers out and place them in an About section.
;; No reordering is done so they will occur in the same order as in the source.
(define (partition-about doc)
  (receive (headers body)
      (partition (lambda (x)
                   (memq (car x)
                         '(requires history author license)))
                 (cdar doc))
    `((eggdoc:begin
       ,@body
       (eggdoc:about "About this egg" ,@headers)
       ))))
(define (latest-version doc)
  (let ((path ((sxpath '(history (version 1)))
               doc)))
    (if (null? path)
        #f
        (cadar path))))

(define (eggdoc:make-svnwiki-stylesheet Doc)
  (let* ((egg-name (eggdoc:derive-egg-name Doc))
         ;; (egg-version (latest-version Doc))
         )
    `(
      (eggdoc:about ((history *macro* . ,(lambda (tag . versions)
                                           `(subsection "Version history"
                                                     (dl ,versions))))
                     (author *macro*  . ,(lambda (tag name)
                                           `(subsection "Author"
                                                     ,name)))
                     (requires *macro* .  ,(lambda (tag . requires)
                                             (if (null? requires)
                                                 '()
                                                 `(subsection
                                                   "Requirements"
                                                   (p ,(intersperse (map (lambda (x) `(tt ,x))
                                                                         requires)
                                                                    ", "))))))
                     ;; If bare license, assume pre tag, otherwise verbatim
                     (license *macro* . ,(lambda (tag contents)
                                           `(subsection
                                             "License"
                                             ,(if (pair? contents)
                                                  contents
                                                  `(pre (@ (id "license")) ,contents))))))
                    . ,(make-section "== "))
      
      (name *macro* . ,discard)  ;; eat this; advisory element for title and page header
      ;; [though, this will eat ALL "name" elements]

      (version *macro* . ,(lambda (tag number . desc)
                            `((dt ,number) (dd ,desc))))

      (history . ,discard)
      (author . ,discard)
      (license . ,discard)
      
      ;; Sections
      (section          . ,(make-section "== "))
      (subsection       . ,(make-section "=== "))
      (subsubsection    . ,(make-section "==== "))
      (subsubsubsection . ,(make-section "===== "))


      (description *macro* . ,(lambda (tag . contents)
                                `(section ,egg-name
                                          (p ,contents)
                                          (toc))))
      (toc . ,(lambda (tag . body)
                '("[[toc:]]\n")))

      (eggdoc:begin . ,(lambda (tag . body)
                         `(  "[[tags:egg]]"
                             ,@body
                             #\newline)))

      ;; If arglist is empty, download section is not shown (use chicken-setup).
      ;; Otherwise, insert verbatim.
      (download *macro* . ,(lambda (tag name)
                             (if (pair? name)
                                 `(section "Download" ,name)
                                 '() ; Default download is omitted
                                 )))
      
;;       ;; (requires elt_1 .. elt_n) -- creates unordered list
;;       (requires *macro* . ,(lambda (tag . reqs)
;;                              `(section "Requires"
;;                                        ,(unordered-list reqs))))

      
      ;; (usage) or (usage elt_1 .. elt_n)
      ;; If arglist is empty, section is skipped, as (require-extension eggname)
      ;; should be obvious by now.
      ;; Otherwise, inserts elements verbatim.
      (usage *macro* . ,(lambda (tag . reqs)
                          (if (null? reqs)
                              '() ; `(section "Usage" (tt "(require-extension " ,egg-name ")"))
                              `(section "Usage"
                                        ,reqs
                                        #\newline))))

      (documentation *macro* . ,(lambda (tag . elts)
                                  `(section "Documentation" ,elts)))

      ;; should be more descriptive than "group"
      (group . ,eat-tag)

;;; Signatures

      ;; Syntax: (definition (signatures (signature type sig) ...) def)
      ;; Not enforced, though.
      (signature *macro* . ,(lambda (tag type sig)
                              `(#\newline ("<" ,type ">") ,sig ("</" ,type ">"))))
      (signatures . ,eat-tag ;                  (lambda (tag . sigs) (intersperse sigs '((br)) ))
                  )
      (definition . ,(lambda (tag term . def)
                       (list term #\newline def #\newline #\newline)))

      ;; Redundant -- should generate these programatically -- or change to pass type in an attribute
      (macro *macro*     . ,make-defsig)
      (record *macro*    . ,make-defsig)
      (procedure *macro* . ,make-defsig)
      (parameter *macro* . ,make-defsig)
      (read-syntax *macro* . ,make-defsig)
      (with-default-param *macro*
                          . ,(lambda (tag param default)
                               (conc "(" param ") [default: " default "]")))
      
      ;; This works by calling pre-post-order on symbol-table's children
      ;; with the 'describe binding prepended to global bindings (so it's effectively local).
      ;; This means symbol-table can't be a macro so HTML conversion must be
      ;; performed manually.  It may be possible to call post-order using universal-conversion-rules.

      ;; "class" is ignored under svnwiki, but we include it anyway.
      (symbol-table ((describe *macro* . ,(lambda (tag symbol description)
                                            `(tr (td (@ (class "symbol"))
                                                     ,symbol)
                                                 (td ,description)))))
                    . ,(lambda (tag . contents)
                         `(#\newline
                           "<table class=\"symbol-table\">" ,contents "</table>"
                           #\newline)))
      

      ;; the same as license
      (examples *macro* . ,(lambda (tag . contents)
                             `(section "Examples" ,contents)))

;;       (url *macro* . ,(lambda (tag href . contents)
;;                         `(a (@ (href ,href))
;;                             ,(if (pair? contents)
;;                                  contents
;;                                  href))))

      ;; Since svnwiki ignores class/id attributes we could probably pass through
      ;; any table attributes specified by the user for future use;
      ;; but oh well.
      (@ *macro* . ,discard-and-warn)

;;; svnwiki-format output

      (*text* . ,(lambda (trigger str) (if (string? str)
                                      (string->good-svnwiki str)
                                      str)))

      (*default* . ,(lambda (tag . elts)
                      (error 'eggdoc-svnwiki
                             (conc "Illegal tag '" tag "'")))) ;; When commmented out, do NOT accept unknown eggdoc SXML

      (p . ,(lambda (tag . elts)
              (list #\newline elts #\newline)))
      (tt . ,(lambda (tag . elts)
               (list "{{" elts "}}")))
      (code . ,(lambda (tag . elts)
               (list "{{" elts "}}")))
      (strong . ,(lambda (tag . elts) (list "'''" elts "'''")))
      (emph   . ,(lambda (tag . elts) (list "''" elts "''")))
      (br     . ,(lambda (tag) #\newline))
      (b      *macro* . ,(alias-tag 'strong))
      (i      *macro* . ,(alias-tag 'emph))
      (em     *macro* . ,(alias-tag 'emph))

      (& . ,(lambda (tag . elts)
              (map (lambda (e)
                     (case (string->symbol e)
                       ((copyright) "(C)")
                       ((lambda) "lambda")
                       ((mdash) "---")
                       ((ndash) "--")
                       (else
                        (eggdoc:warning (conc "unhandled & element: " e)))))
                   elts)))
      
      ;; svnwiki supports basic tables using HTML-like tags
      (table . ,(lambda (tag . elts)
                  (list "<table>" elts "</table>" #\newline)))
      (th . ,(lambda (tag . elts)                  ; Probably not accepted anyway.
               (list "<th>" elts "</th>")))
      (tr . ,(lambda (tag . elts)
               (list "<tr>" elts "</tr>" #\newline)))
      (td . ,(lambda (tag . elts)
               (list "<td>" elts "</td>")))

      ;; Lists
      (dl . ,(lambda (tag . elts) (list #\newline elts)))  ; must ensure blank line at beginning!
      (dt . ,(lambda (tag . body) (list "; " body " ")))
      (dd . ,(lambda (tag . body) (list ": " body #\newline)))
      ;; Nested lists are not handled.
      (ul ((li . ,(lambda (tag . body) (list "* " body #\newline))))
          . ,(lambda (tag . body) (list #\newline body)))
      (ol ((li . ,(lambda (tag . body) (list "# " body #\newline))))
          . ,(lambda (tag . body) (list #\newline body)))

      ;; div/span
      (div . ,eat-tag-and-warn)
      (span . ,eat-tag-and-warn)

      ;; quoting
      (q . ,(lambda (tag . elts)
              (list #\" elts #\")))
      (blockquote . ,(lambda (tag . body)
                       (list #\newline "<blockquote>" body "</blockquote>" #\newline)))
      
      ;; Pre tags have space before each line; we change the default
      ;; text handler to replace newlines with newline + space.  Also,
      ;; we prepend a single newline.  Note that text of inline elements
      ;; will also be replaced, which may be illegal under svnwiki.
      ;; (Note: we do not escape.  svnwiki usually ignores escapes
      ;; but in some cases this may cause problems.)
      (pre ((*text* . ,(lambda (trigger str)
                         (if (string? str)
                             (string-substitute "\n" "\n "
                                                str   ; (string->good-svnwiki str)
                                                #:global)
                             str))))
       . ,(lambda (tag . elts)
            ;; Prepending newline to <pre> is a recent change because people are
            ;; embedding <pre> in <p>.  This could cause some extraneous space in
            ;; proper documents.
            (list #\newline #\space elts #\newline)))

      ;; Links

      ;; name attributes are ignored (as svnwiki has no name anchors).
      ;; However, links to such anchors (#name) will be passed through
      ;; (and render as expected, but with no functioning target).
      (a *macro* . ,(lambda elems
              (let ((link ((sxpath '(@ href *text*)) elems))
                    (contents ((sxpath '((*not* @))) elems))) ;; get all text and elts (non-@)
                (if (null? link) ;; Not an href= -- a name=, for example
                    contents
                    (if (pair? contents)
                        `(url ,link ,contents)
                        `(url ,link))))))
      
      (url . ,(lambda (tag link . contents)
                (if (pair? contents)
                    (list "[[" link "|" contents "]]") ;; contents is not spliced in
                    (list "[[" link "]]")) ))          ;; so it remains one argument.

      ;; Images -- use alt text, else discard.
      (img *macro* . ,(lambda elems
                        (let ((alt ((sxpath '(@ alt *text*)) elems)))
                          (if (null? alt)
                              (discard-and-warn elems)
                              alt))))

      )))

;; (eggdoc->svnwiki DOC [XML-STYLESHEET])
;; Default stylesheet is (eggdoc:make-svnwiki-stylesheet doc), which is user-visible
;; so you can append to or otherwise modify it, and pass it in.
(define (eggdoc->svnwiki doc . rest)
  (let-optionals rest ((ss (eggdoc:make-svnwiki-stylesheet doc)))
    (SRV:send-reply
     (pre-post-order (partition-about doc) ss))
    (eggdoc:result)))

;; Set default transformer and stylesheet to svnwiki.
(define (eggdoc:svnwiki-override!)
  (eggdoc:default-stylesheet-maker eggdoc:make-svnwiki-stylesheet)
  (eggdoc:default-transformer eggdoc->svnwiki))

)