main.ss
;; docgen: A simple html documentation generator
;; Copyright (C) 2007 Dimitris Vyzovitis <vyzo@media.mit.edu>
;;
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2 of the License, or
;; (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program; if not, write to the Free Software
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston,
;; MA  02110-1301, USA

(require (lib "xml.ss" "xml")
         (lib "kw.ss")
         (lib "plt-match.ss")
         (lib "list.ss" "srfi" "1"))
(require-for-syntax (lib "list.ss" "srfi" "1"))

(define call/values call-with-values)
(define-syntax (apply/values stx)
  (syntax-case stx ()
    ((_ p)
     #'(p))
    ((_ p prod)
     #'(call/values (lambda () prod)
                    (lambda vals (apply p vals))))
    ((_ p arg ...)
     (let* ((args (syntax->list #'(arg ...)))
            (pre (drop-right args 1))
            (prod (last args)))
       #`(call/values (lambda () #,prod)
                      (lambda vals (apply p #,@pre vals)))))))

(define-syntax define-rule
  (syntax-rules ()
    ((_ rule rx)
     (define (rule s)
       (cond
        ((regexp-match rx s) => cdr)
        (else #f))))))
         
(define-syntax expand-rule
  (syntax-rules (else)
    ((_ obj ((rule id ...) body ...) rest ...)
     (cond
      ((rule obj) =>
       (lambda (vals)
         (call/values
           (lambda () (apply values vals))
           (lambda (id ...) body ...))))
      (else 
       (expand-rule obj rest ...))))
    ((_ obj (else body ...))
     (begin body ...))
    ((_ obj) (void))))

(define-syntax rule-case
  (syntax-rules ()
    ((_ obj rule ...)
     (let ((tmp obj))
       (expand-rule tmp rule ...)))))

(define-rule skip #px"^==+\\s+_.*")
(define-rule section #px"^==\\s+(.*)$")
(define-rule section/pre #px"^===\\s+(.*)$")
(define-rule subsection #px"^--\\s+(.*)$")
(define-rule subsubsection #px"^---\\s+(.*)$")
(define-rule object #px"^>\\s+([^)]*)$")
(define-rule proc #px"^>\\s+[(](\\S+)\\s*(.*)[)]\\s*$")
(define-rule procv #px"\\s+->\\s+([^(]*)$")
(define-rule procvs #px"\\s+->\\s+[(]([^)]*)[)]\\s*$")
(define-rule stx #px"^>\\s+[(](\\S+)\\s*(.*)[)]\\s*: syntax\\s*$")
(define-rule expr #px"^>>\\s+(.*)$")
(define-rule begin-pre #px"^#\\|")
(define-rule end-pre #px"^\\|#")

(define (parse inp)
  (define next-id
    (let ((id 0))
      (lambda () (begin0 id (set! id (add1 id))))))
  
  (define (empty? s) (equal? s ""))
  
  (define (make-make-section strength)
    (lambda (title)
      (let* ((id (format "toc:~a"  (next-id)))
             (link (format "#~a" id)))
        (values `(a ((name ,id)) (,strength ,title))
                `(a ((href ,link)) ,title)))))
  
  (define make-section (make-make-section 'h2))
  (define make-subsection (make-make-section 'h3))
  (define (make-subsubsection title) `(h4 ,title))

  (define (make-toc anchor subtoc)
    (if (and subtoc (not (null? subtoc)))
        `(li ,anchor (ul ,@(map (lambda (x) `(li ,x)) (reverse subtoc))))
        `(li ,anchor)))
  (define (make-pre body)
    `(pre ,@(map (lambda (line) (format "~a~n" line)) (reverse body))))
  (define (make-object obj)
    `(div ((class "ident")) ,obj))
  (define (make-proc name args)
    `(div (span ((class "procspec")) "procedure: ") 
          "(" (span ((class "ident")) ,name) 
          ,@(if (empty? args) null (list " " args)) ")"))
  (define (make-procv what)
    `(div "-> "  ,what))
  (define (make-procvs what)
    `(div "-> values: " ,what))
  (define (make-stx name args)
    `(div (span ((class "stxspec")) "syntax: ") 
          "(" (span ((class "ident")) ,name) 
          ,@(if (empty? args) null (list " " args)) ")"))
  (define (make-expr what)
    `(div ,what))
  (define (make-p what)
    `(p ,@(fold (lambda (x xs) (list* x " " xs)) null what)))

  (define (parse-section/pre title body toc)
    (define (->body sbody)
      (let-values (((head entry) (make-section title)))
        (values (list* (make-pre sbody) head body)
                (cons (make-toc entry #f) toc))))
    
    (let lp ((sbody null))
      (let ((in (read-line inp)))
        (if (eof-object? in)
            (->body sbody)
            (rule-case in
              ((skip) (lp sbody))
              ((section title)
               (apply/values parse-section title (->body sbody)))
              ((section/pre title)
               (apply/values parse-section/pre title (->body sbody)))
              (else (lp (cons in sbody))))))))

  (define (parse-pre)
    (let lp ((body null))
      (let ((in (read-line inp)))
        (when (eof-object? in) (error 'parse-pre "unterminated pre section"))
        (rule-case in
          ((end-pre) (make-pre body))
          (else (lp (cons in body)))))))

  (define (parse-section title body toc)
    (define (->body sbody stoc)
      (let-values (((head entry) (make-section title)))
        (values (append! sbody (cons head body))
                (cons (make-toc entry stoc) toc))))
    
    (define ->sbody
      (case-lambda 
        ((head pbody sbody)
         (if (null? pbody)
             (cons head sbody)
             (list* head (make-p pbody) sbody)))
        ((pbody sbody)
         (if (null? pbody)
             sbody
             (cons (make-p pbody) sbody)))))

    (let lp ((sbody null) (stoc null) (pbody null))
      (let ((in (read-line inp)))
        (if (eof-object? in)
            (->body (->sbody pbody sbody) stoc)
            (rule-case in
              ((skip) (lp sbody stoc pbody))
              ((section title)
               (apply/values parse-section title 
                             (->body (->sbody pbody sbody) stoc)))
              ((section/pre title)
               (apply/values parse-section/pre title 
                             (->body (->sbody pbody sbody) stoc)))
              ((subsection title)
               (let-values (((head entry) (make-subsection title)))
                 (lp (->sbody head pbody sbody) (cons entry stoc) null)))
              ((subsubsection title)
               (lp (->sbody (make-subsubsection title) pbody sbody) stoc null))
              ((object what)
               (lp (->sbody (make-object what) pbody sbody) stoc null))
              ((proc name args)
               (lp (->sbody (make-proc name args) pbody sbody) stoc null))
              ((procv what)
               (lp (->sbody (make-procv what) pbody sbody) stoc null))
              ((procvs what)
               (lp (->sbody (make-procvs what) pbody sbody) stoc null))
              ((stx name args)
               (lp (->sbody (make-stx name args) pbody sbody) stoc null))
              ((expr what)
               (lp sbody stoc (cons (make-expr what) pbody)))
              ((begin-pre)
               (lp sbody stoc (cons (parse-pre) pbody)))
              (else
               (if (empty? in)
                   (lp (->sbody pbody sbody) stoc null)
                   (lp sbody stoc (cons in pbody)))))))))
  
  (define (finish body toc)
    (values (reverse body) `(ul ,@(reverse toc))))

  (let lp ()
    (let ((in (read-line inp)))
      (when (eof-object? in) 
        (error 'parse "empty doc"))
      (rule-case in
        ((skip) (lp))
        ((section title)
         (apply/values finish (parse-section title null null)))
        ((section/pre title)
         (apply/values finish (parse-section/pre title null null)))
        (else 
         (error 'parse "bad doc: no section"))))))
                   
(define/kw (docgen name inp outp #:key (style #f) (keywords #f))
  (let-values (((body toc) (parse inp)))
    (parameterize ((empty-tag-shorthand html-empty-tags))
      (write-xml/content
       (xexpr->xml
        `(html (head 
                (title ,name)
                (link ((rel "stylesheet")
                       (type "text/css")
                       (href ,(if style style "doc.css"))))
                ,@(if keywords
                      `((meta ((name "keywords"))
                              ((content ,keywords))))
                      null))
               (body
                (h1 ,name)
                (h2 "Contents")
                ,toc
                ,@body)))
       outp)
      (flush-output outp))))

(define (main)
  (define (run name inf outf)
    (let ((inp (open-input-file inf))
          (outp (open-output-file outf 'truncate)))
      (docgen name inp outp)
      (close-input-port inp)
      (close-output-port outp)))
  
  (match (current-command-line-arguments)
    ((vector name)
     (run name "doc.txt" "doc.html"))
    ((vector name inf outf)
     (run name inf outf))
    (else
     (error 'main "Arguments: name [input-file-name output-file-name]"))))