;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; schematic-docco.scm
;;;
;;; This is a literate programming documentation tool in the style of
;;; Docco (<http://jashkenas.github.io/docco/>). It produces a
;;; side-by-side view of the comments and code of its input source files.
;;;
;;; It requires CHICKEN Scheme with the following extensions:
;;;
;;;   * colorize
;;;   * command-line
;;;   * fmt
;;;   * sxml-transforms
;;;
;;; See this project's README for more information.
;;;
;;; Copyright (c) 2013, Evan Hanson <evhan@foldling.org>
;;; See LICENSE for details.
;;;

(require-extension posix files srfi-1 srfi-13 srfi-14)
(require-extension command-line command-line-getopt-long)
(import colorize fmt sxml-transforms)

(include "schematic-reader.scm")

;;;
;;; Program options & usage.
;;;

(define program-version "0.1.1")

(define program-options
  '(((-h --help))
    ((-v --version))
    ((-t --title)          . <string>)
    ((-o --output)         . <string>)
    ((-l --language)       . <string>)
    ((-F --formatter)      . <command>)
    ((-H --highlighter)    . <command>)
    ((   --comment-string) . <string>)
    ((   --directory)      . <path>)
    ((   --stylesheet)     . <path>)))

(define (print-usage options)
  (display "Usage: ")
  (display (program-name))
  (display " [option ...] [file ...]")
  (newline)
  (for-each
   (lambda (opt)
     (display #\space)
     (display (last (car opt)))
     (display #\space)
     (unless (null? (cdr opt))
       (display (cdr opt)))
     (newline))
   options))

;;;
;;; Utilities.
;;;

(define (underline s)
  (string-append s "\n" (make-string (string-length s) #\=)))

(define ((pipe command) str)
  (let-values (((i o p) (process command)))
    (display str o)
    (close-output-port o)
    (let ((result (read-string #f i)))
      (close-input-port i)
      result)))

(define (language-comment-string language)
  (case language
    ((scheme lisp) '(";;;" ";;"))
    ((perl python ruby shell sh) '("#"))
    ((java javascript c) '("//"))
    ((erlang matlab) '("%"))
    ((haskell lua) '("--"))
    (else #f)))

(define (die . msg)
  (parameterize ((current-output-port (current-error-port)))
    (for-each display msg)
    (newline)
    (exit 1)))

;;;
;;; Program start.
;;;

(current-exception-handler
 (let ((msg  (condition-property-accessor 'exn 'message))
       (args (condition-property-accessor 'exn 'arguments)))
   (lambda (e) (apply die (msg e) ": " (args e)))))

(define command-line-option
  (let* ((options
          (parse-command-line getopt-long (command-line-arguments) program-options))
         (lookup-option
          (lambda (k) (alist-ref k options))))
    (lambda (key)
      (if (list? key)
          (any lookup-option key)
          (lookup-option key)))))

(and-let* ((invalid-argument
            (find (lambda (arg)
                    (or (string-null? arg)
                        (char=? (string-ref arg 0) #\-)))
                  (command-line-option '--))))
  (error "Unrecognized command line option" invalid-argument))

(when (command-line-option '(-h --help))
  (print-usage program-options)
  (exit))

(when (command-line-option '(-v --version))
  (display program-version)
  (newline)
  (exit))

(define directory
  (or (command-line-option '--directory)
      (current-directory)))

(define output
  (cond ((command-line-option '(-o --output)) => string->symbol)
        ('html)))

(define language
  (cond ((command-line-option '(-l --language)) => string->symbol)
        ('scheme)))

;; Set the comment string for the program. If one is given at the
;; command line, use that; otherwise, try to determine it from the
;; language name.
(define comment-string
  (cond ((command-line-option '--comment-string) => list)
        ((language-comment-string language))
        ((die "Unknown language: " language))))

;; The default formatter does nothing.
(define default-formatter identity)

;; The default highlighter is only used when generating HTML and no
;; syntax highlighter was specified at the command line. Otherwise, it
;; too does nothing.
(define default-highlighter
  (case output
    ((ansi) identity)
    ((html)
     (require-library colorize)
     (lambda (s)
       (html-colorize language s)))))

;; The comment and code formatters shell out to user-specified commands
;; when given; otherwise, they fall back to the defaults defined above.
(define format-comment
  (cond ((command-line-option '(-F --formatter)) => pipe)
        (default-formatter)))

(define format-code
  (cond ((command-line-option '(-H --highlighter)) => pipe)
        (default-highlighter)))

;; Use the user-specified stylesheet, or that included with the program
;; if none is given. See the setup file, schematic.setup, for its
;; installation location.
(define stylesheet
  (or (command-line-option '--stylesheet)
      (find (lambda (s) (string-suffix? ".css" s))
            (cdr (assq 'files (extension-information 'schematic))))))

;; All unmatched arguments are treated as input files.
(define files (command-line-option '--))

(define process-input
  (case output
    ;; ANSI goes to standard output.
    ((ansi)
     (require-library fmt)
     (let ((width 0.60)
           (sep " | "))
       (lambda (title reader)
         (fmt #t (columnar width (cat nl (underline title) nl nl) sep))
         (let loop ()
           (let-values (((docs code) (reader)))
             (unless (eof-object? docs)
               (fmt #t (columnar width
                        (cat (wrap-lines (format-comment docs)) nl nl) sep
                        (cat (format-code code) nl nl)))
               (loop)))))))
    ;; HTML is written to files. I don't really like this difference
    ;; in behavior, but we have to put the stylesheet somewhere.
    ((html)
     (require-library sxml-transforms)
     (create-directory directory 'w/parents)
     (file-copy stylesheet (make-pathname directory "schematic.css") 'clobber)
     (lambda (title reader)
       (let loop ((i 1)
                  (rows '()))
         (let-values (((docs code) (reader)))
           (if (eof-object? docs)
               ;; Write output to the file named by `title`.
               (with-output-to-file
                (make-pathname directory title ".html")
                (lambda ()
                  (SRV:send-reply
                   (pre-post-order
                    `("<!doctype html>"
                      (html
                       (head
                        (title ,title)
                        (link
                         (@ (rel "stylesheet")
                            (href "schematic.css"))))
                       (body
                        (div (@ (id "background")))
                        (div (@ (id "container"))
                             (table
                              (@ (cellspacing 0)
                                 (cellpadding 0))
                              (tr (th (@ (class "docs"))
                                      (h1 ,title))
                                  (th (@ (class "code"))))
                              ,@(reverse rows))))))
                    universal-protected-rules))))
               ;; Accumulate formatted sections as table rows.
               (let ((href (string-append "section-" (number->string i))))
                 (loop (+ i 1)
                       (cons `(tr (@ (id ,href))
                                  (td (@ (class "docs"))
                                      (div (@ (class "pilwrap"))
                                           (a (@ (class "pilcrow")
                                                 (href "#" ,href))
                                              (& "para")))
                                      ,(format-comment docs))
                                  (td (@ (class "code"))
                                      (pre (@ (class "highlight"))
                                           ,(format-code code))))
                             rows))))))))
    (else
     (die "Unknown output format: " output))))

;; Create a procedure that, given a reader and port, generates docco
;; output with the given `title`. If an alternate title was specified
;; via the `--title` option, use that instead.
(define (input-processor title)
  (let ((title (or (command-line-option '(-t --title)) title)))
    (lambda (port)
      (process-input
       title
       (make-source-section-reader comment-string port)))))

;; Generate docco output for the given file.
(define (process-file file)
  (call-with-input-file
   file
   (input-processor (pathname-strip-directory file))))

;; If any files were given on the command line, process them in order.
;; Otherwise, read from standard input. A successful run is silent.
(if (pair? files)
    (for-each process-file files)
    ((input-processor "stdin")
     (current-input-port)))