gendoc.bn

#!/usr/bin/env bone
;;;; gendoc.bn -- Documentation generator for Bone Lisp.   -*- bone -*-
;;;; Copyright (C) 2016 Wolfgang Jaehrling
;;;;
;;;; Permission to use, copy, modify, and/or distribute this software for any
;;;; purpose with or without fee is hereby granted, provided that the above
;;;; copyright notice and this permission notice appear in all copies.
;;;;
;;;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
;;;; WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
;;;; MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
;;;; ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
;;;; WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
;;;; ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
;;;; OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.

(version 0 6)

;;; Program options

(use std/prog-arg)

(defvar *options-spec*
  '((index ((flag #t)
            (short #chr "i")
            (desc "Generate index.md file.")))
    (help ((flag #t)
           (short #chr "h")
           (desc "Show this usage message.")))
    (version ((flag #t)
              (short #chr "v")
              (desc "Show version information.")))))


(destructure (options files)
    (parse-prog-args (drop 2 *program-args*) *options-spec*)
  (defvar *options* options)
  (defvar *files* files))

(mysub (bone-version)
  (str+ (num->str (lisp-info 'major-version)) "."
        (num->str (lisp-info 'minor-version)) "."
        (num->str (lisp-info 'patch-version))))

(cond ((assocar? 'help *options*)
       (say-prog-args-help "gendoc" *options-spec* "FILE...")
       (sys.exit 0))
      ((assocar? 'version *options*)
       (say "gendoc " (bone-version) "\n")
       (sys.exit 0)))

;;; Main program

(defvar *index-dst* (when (assocar? 'index *options*)
                      (sys.dst-open? "index.md")))   ; TODO: abort on error
(defvar *current-file* #f)

(mymac (to-index-dst . body)
  `(when *index-dst*
     (with-dst *index-dst*
       ,@body)))

(mysub (spec->name spec)
  (or (car? spec) spec))

(mysub (index-entry name)
  (to-index-dst
   (say "[`" name "`](" *current-file* "#" name ") ")))

(mysub (document type spec docstr)
  (index-entry (spec->name spec))
  (say "### <a name=\"" (spec->name spec) "\"> " type ": `")
  (print spec)
  (say "` </a>\n\n" docstr "\n\n"))

(mysub (look-at-expr x)
  (with head (car? x)
    (awhen (cond ((eq? head 'defsub) 'sub)
                 ((eq? head 'defmac) 'mac)
                 ((eq? head 'defreader) 'reader))
      (document it (nth 1 x) (nth 2 x)))))

(mysub (each-expr sub)
  (with loop (lambda (next)
               (when (not (eof? next))
                 (sub next)
                 (loop (read))))
    (loop (read))))

(mysub (document-file fname)
  (in-reg
   (with-var *current-file* (str+ fname ".html")
     (to-index-dst
      (say "\n\n## " fname "\n\n"))
     (with-file-dst (str+ fname ".md")
       (say "# " fname "\n\n")
       (with-file-src fname
         (each-expr look-at-expr)))
     ())))

(to-index-dst
 (say "# Bone Lisp " (bone-version)))

(each document-file *files*)