;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; schematic-wiki.scm
;;;
;;; This script converts commented Scheme definitions into svnwiki markup.
;;;
;;; See this project's README for more information.
;;;
;;; Copyright (c) 2013-2018, Evan Hanson <evhan@foldling.org>
;;; See LICENSE for details.
;;;

(import (schematic extract)
        (schematic process)
        (scheme base)
        (scheme process-context)
        (scheme read)
        (scheme write))

(define --comment-prefixes '(";;" ";;;"))
(define --types #false)

(define wiki-tags
  '(constant parameter procedure record string syntax type))

(define (write-wiki-tag type form)
  (display "<")
  (display type)
  (display ">")
  (write form)
  (display "</")
  (display type)
  (display ">\n"))

(define (write-wiki-pre type form)
  (display " ")
  (display type)
  (display " ")
  (write form)
  (display "\n"))

(define (write-wiki-doc doc)
  (display "\n")
  (display doc)
  (display "\n\n"))

(define (process-source input)
  (call-with-port (open-output-string)
   (lambda (output)
     (extract-definitions --comment-prefixes --types input output)
     (call-with-port (open-input-string (get-output-string output))
      (lambda (specs)
        (do ((spec (read specs) (read specs)))
            ((eof-object? spec))
          (for-each (lambda (tag)
                      (let ((type (car tag)))
                        (cond ((memq type wiki-tags)
                               (write-wiki-tag type (cdr tag)))
                              (else
                               (write-wiki-pre type (cdr tag))))))
                    (cdr spec))
          (write-wiki-doc (car spec))))))))

(for-each
 (lambda (option)
   (case (car option)
     ((-h --help)
      (display "Usage: ")
      (display (car (command-line)))
      (display " [-c <string>]")
      (display " [-t]")
      (newline)
      (exit))
     ((-v --version)
      (display version)
      (newline)
      (exit))
     ((-t --types)
      (set! --types #true))
     ((-c --comment-prefix)
      (set! --comment-prefixes (cdr option)))
     ((--)
      (with-exception-handler error-exit
       (lambda ()
         (if (null? (cdr option))
             (process-source (current-input-port))
             (error "Unrecognized command line argument" (cadr option))))))))
 (command-line-options
  '(((-c --comment-prefix) string)
    ((-t --types)))))