;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; 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 libraries:
;;;
;;;   * (colorize)
;;;   * (fmt)
;;;   * (foldling command-line)
;;;   * (sxml-transforms)
;;;
;;; See this project's README for more information.
;;;
;;; Copyright (c) 2013, Evan Hanson <evhan@foldling.org>
;;; See LICENSE for details.
;;;

(import (files)
        (posix)
        (srfi 1)
        (srfi 13)
        (srfi 14))

(import (colorize)
        (fmt)
        (foldling command-line)
        (foldling command-line getopt-long)
        (schematic read)
        (sxml-transforms))

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

(define program-version "0.1.3")

(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 65535 i))) ; sic
      (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
  (cond ((command-line-option '--stylesheet))
        ((assq 'files (extension-information 'schematic))
         => (lambda (f)
              (find (lambda (s) (string-suffix? ".css" s))
                    (cdr f))))
        ("schematic.css")))

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

;; Read all source sections from the given `port`, returning a list of
;; docs/code string pairs in reverse order of appearance.
(define (read-source-sections comment-strings port)
  (port-fold-source-sections
   (lambda (docs code acc)
     (cons (cons docs code) acc))
   '()
   comment-strings
   port))

;; Write SXML as HTML to the given port.
(define write-html
  (case-lambda
    ((sxml)
     (SRV:send-reply (pre-post-order sxml universal-protected-rules)))
    ((sxml port)
     (parameterize ((current-output-port port))
       (SRV:send-reply (pre-post-order sxml universal-protected-rules))))))

(define process-input
  (case output
    ;; ANSI goes to standard output.
    ((ansi)
     (require-library fmt)
     (let ((width 0.60)
           (sep " | "))
       (lambda (title comment-strings port)
         (fmt #t (columnar width (cat nl (underline title) nl nl) sep))
         (port-fold-source-sections
          (lambda (docs code _)
            (fmt #t (columnar width
                     (cat (wrap-lines (format-comment docs)) nl nl) sep
                     (cat (format-code code) nl nl))))
          #f ; Ignored.
          comment-strings
          port))))
    ;; 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 comment-strings port)
       (with-output-to-file (make-pathname directory title ".html")
        (lambda ()
          (write-html
           `("<!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"))))
                     ,@(let ((sections (read-source-sections comment-strings port)))
                         (fold (lambda (section id sxml)
                                 (let ((docs (car section))
                                       (code (cdr section))
                                       (href (string-append "section-" (number->string id))))
                                   (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))))
                                         sxml)))
                               '()
                               sections
                               (list-tabulate (length sections) values)))))))))))))
    (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 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)))