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

(import (foldling command-line)
        (schematic read)
        (schematic process)
        (scheme base)
        (scheme process-context)
        (scheme read)
        (scheme write))

(define program-version (make-parameter "0.1.3"))

(define comment-prefixes '(";;" ";;;"))

(cond-expand
  (chicken)
  (else
   (define (symbol-append . a)
     (string->symbol
      (apply string-append (map symbol->string a))))))

;;;
;;; Write helpers.
;;;

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

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

;;
;; Read helpers.
;;

;; `read`, but returns `#false` on error.
(define (read/guard port)
  (guard (_ (else #false))
    (read port)))

;;
;; Reads the `car` of the pair on `port`, returning `#false` if the read
;; operation signals an error or if no pair is encountered.
;;
;; Does not handle multiline or datum comments.
;;
(define (read-car port)
  ;; Discard whitespace and line comments.
  (do ((c (peek-char port) (peek-char port)))
      ((or (eof-object? c) (not (memq c '(#\; #\space #\tab #\newline)))))
    (case (read-char port)
      ((#\;) (read-line port))))
  ;; Read one datum past a single opening parenthesis.
  (case (read-char port)
    ((#\() (read/guard port))
    (else #false)))

;;;
;;; Basic pattern matching.
;;;

;; Matches `form` against `pattern`, returning a list of all elements
;; from `form` that corresponded to a vector in `pattern`, or `#false`
;; if the two forms didn't otherwise match (in the sense of `equal?`).
(define (match form pattern)
  (let ((env '()))
    (define (extract x p)
      (cond ((vector? p)
             (set! env (cons x env))
             #true)
            ((and (pair? x) (pair? p))
             (and (extract (car x) (car p))
                  (extract (cdr x) (cdr p))))
            (else (equal? x p))))
    (and (extract form pattern)
         (reverse env))))

;; `case`-like syntax for `match`, above.
(define-syntax match-case
  (syntax-rules (else =>)
    ((_ form) (if #false #true))
    ((_ form (else . body)) (begin . body))
    ((_ form (pattern => proc) . clauses)
     (let ((results (match form (quote pattern))))
       (if (not results)
           (match-case form . clauses)
           (apply proc results))))
    ((_ form (pattern . body) . clauses)
     (if (match form (quote pattern))
         (begin . body)
         (match-case form . clauses)))))

;; Emit svnwiki fragments for Scheme source.
(define (process-source port)
  (port-fold-source-sections
   (lambda (docs code carry)
     (when (pair? carry)
       (set! docs (car carry))
       (set! code (string-append (cdr carry) code)))
     (cond
       ((string=? docs ""))
       ((call-with-port (open-input-string code) read/guard) =>
        (lambda (form)
          (match-case form
            ((define (#(name) . #(args)) . #(_)) =>
             (lambda (name args _)
               (write-wiki-tag 'procedure (cons name args))
               (write-wiki-docs docs)))
            ((define #(name) (lambda #(args) . #(_))) =>
             (lambda (name args _)
               (write-wiki-tag 'procedure (cons name args))
               (write-wiki-docs docs)))
            ((define #(name) (case-lambda . #(clauses))) =>
             (lambda (name clauses)
               (for-each (lambda (args)
                           (write-wiki-tag 'procedure `(,name ,@args)))
                         (map car clauses))
               (write-wiki-docs docs)))
            ((define #(name) (make-parameter . #(_))) =>
             (lambda (name _)
               (write-wiki-tag 'parameter name)
               (write-wiki-docs docs)))
            ((define #(name) #(value)) =>
             (lambda (name value)
               (cond ((string? value)
                      (write-wiki-tag 'string name)
                      (write-wiki-docs docs))
                     ((not (pair? value))
                      (write-wiki-tag 'constant name)
                      (write-wiki-docs docs)))))
            ((define-syntax #(name) (syntax-rules #(_) . #(clauses))) =>
             (lambda (name _ clauses)
               (for-each (lambda (args)
                           (write-wiki-tag 'syntax `(,name ,@args)))
                         (map cdar clauses))
               (write-wiki-docs docs)))
            ((define-syntax #(name) . #(_)) =>
             (lambda (name _)
               (write-wiki-tag 'syntax name)
               (write-wiki-docs docs)))
            ((define-record-type #(name) #(make) #(pred) . #(fields)) =>
             (lambda (name make pred fields)
               (write-wiki-tag 'record name)
               (write-wiki-tag 'procedure make)
               (write-wiki-tag 'procedure `(,pred object))
               (for-each (lambda (p)
                           (write-wiki-tag 'procedure `(,p ,name)))
                         (map cadr fields))
               (for-each (lambda (p)
                           (when (pair? p)
                             (write-wiki-tag 'procedure `(,(car p) ,name value))))
                         (map cddr fields))
               (write-wiki-docs docs)))
            ((define-record #(name) . #(fields)) => ; CHICKEN.
             (lambda (name fields)
               (write-wiki-tag 'record name)
               (write-wiki-tag 'procedure `(,(symbol-append 'make- name) ,@fields))
               (write-wiki-tag 'procedure `(,(symbol-append name '?) object))
               (for-each (lambda (f)
                           (write-wiki-tag 'procedure `(,(symbol-append name '- f) ,name)))
                         fields)
               (for-each (lambda (f)
                           (write-wiki-tag 'procedure `(,(symbol-append name '- f '-set!) ,name value)))
                         fields)
               (write-wiki-docs docs))))))
       (else
        (case (call-with-port (open-input-string code) read-car)
          ((define-library) #false)   ; R7RS.
          ((module) #false)           ; CHICKEN.
          ((define-module) #false)    ; Gauche.
          (else (cons docs code)))))) ; Carry into the next section.
   #false
   comment-prefixes
   port))

;; Parse the command line and process input.
(for-each
 (lambda (option)
   (case (car option)
     ((-h --help)
      (display "Usage: ")
      (display (car (command-line)))
      (newline)
      (exit))
     ((-v --version)
      (display program-version)
      (newline)
      (exit))
     ((-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))))))))
 (parse-command-line
  '(((-h --help))
    ((-v --version))
    ((-c --comment-prefix) string))))