;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; schematic-docco.scm
;;;
;;; This is a literate programming documentation tool in the style of
;;; 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-2015, Evan Hanson
;;; 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 process)
(schematic read)
(sxml-transforms))
;;;
;;; Program options & usage.
;;;
(define program-options
'(((-h --help))
((-v --version))
((-t --title) . )
((-o --output) . )
((-l --language) . )
((-F --formatter) . )
((-H --highlighter) . )
(( --comment-string) . )
(( --directory) . )
(( --stylesheet) . )))
(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 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
`(""
(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)))