docgen.scm

#! /usr/local/bin/guile \
-e main -s
!#

(use-modules ((sxml xpath)
              #:select (sxpath))
             (ice-9 getopt-long)
             (ice-9 ftw))

(define *processors* '())

(define (add-processor name l)
  (set! *processors* (cons (cons name l) *processors*))
  *processors*)

(define (get-processor name)
  (let ((pair (assoc name *processors*)))
   (if pair
     (cdr pair)
     #f)))

(add-processor
  'define-module
  (lambda (l port)
    (let ((inner (process-inner port))
          (name (car l))
          (exports (map symbol->string (exported-functions l))))
     (append `(module (@ (name ,name))) (extract-exports inner exports)))))

(define (process-define l port)
  (append `(function (@ (name ,(symbol->string (caar l))) (usage ,(car l))))
          (let ((second (cadr l)))
           (if (string? second)
             `((documentation ,second))
             '()))))

(add-processor
  'define
  process-define)

(add-processor
  'define*
  process-define)

(define (exported-functions expr)
  (cadr (member #:export expr)))

(define (extract-exports ll exports)
  (filter (lambda (l)
            (and (eq? 'function (car l))
                 (member (car ((sxpath '(@ name *text*)) l)) exports)))
          ll))

(define (process-inner port)
  (define (helper acc)
    (let ((expr (read port)))
     (cond
       ((eof-object? expr) (reverse acc))
       ((list? expr)
        (let* ((front (car expr))
               (proc (get-processor front)))
         (if proc
           (helper (cons (proc (cdr expr) port) acc))
           (helper acc))))
       (else (helper acc)))))
  (helper '()))

(define (process-file name)
  (call-with-input-file
    name
    (lambda (port)
      (append `(file (@ (name ,name))) (process-inner port)))))

(define (write-function l port)
  (let ((name (car ((sxpath '(@ name *text*)) l)))
        (usage (cadar ((sxpath '(@ usage)) l)))
        (documentation (car ((sxpath '(documentation *text*)) l))))
    (newline port)
    (format port "### ~a ###" name)
    (newline port)
    (format port "Scheme Procedure: `~a`" usage)
    (newline port)
    (newline port)
    (display "<pre>" port)
    (display documentation port)
    (display "</pre>" port)
    (newline port)))

(define (write-module l port)
  (let ((name (cadar ((sxpath '(@ name)) l)))
        (functions ((sxpath '(function)) l)))
    (display "## Usage ##" port)
    (format port "~%```scheme~%(use-modules ~a)~%```~%~%" name)
    (display "## Functions ##" port)
    (newline port)
    (for-each (lambda (l) (write-function l port)) functions)
    (newline port)))

(define (walk-directory directory)
  (define (enter? name stat result) #t)
  (define (leaf name stat result)
    (if (or (string-suffix? ".ss" (basename name))
            (string-suffix? ".scm" (basename name)))
      (cons (process-file name) result)
      result))
  (define (down name stat result) result)
  (define (up name stat result) result)
  (define (skip name stat result) result)
  (define (error name stat result) result)
  (file-system-fold enter? leaf down up skip error
                    '()
                    directory))

(define (name->string name)
  (format #f "~{~a~^ ~}" name))

(define (main args)
  (let* ((option-spec '((help (single-char #\h) (value #f))
                        (input-dir (single-char #\i) (value #t))
                        (output-dir (single-char #\o) (value #t))))
         (options (getopt-long args option-spec))
         (help-wanted (option-ref options 'help #f))
         (input-dir (option-ref options 'input-dir "."))
         (output-dir (option-ref options 'output-dir ".")))
    (cond
      (help-wanted (format #t "Usage: ~a OPTIONS...\nGenerate documentation for Scheme code.\n\n\t-h, --help\t\tDisplay this help\n\t-i, --input-dir\t\tinput folder\n\t-o, --output-dir\toutput folder\n" (car args)))
      (else
        (let ((modules ((sxpath '(// module)) (walk-directory input-dir))))
         (for-each (lambda (m)
                     (let ((filename (name->string
                                       (cadar ((sxpath '(@ name)) m)))))
                      (call-with-output-file
                        (string-append output-dir "/" filename ".md")
                        (lambda (port)
                          (write-module m port)))))
                   modules)
         (call-with-output-file
           (string-append output-dir "/Module Listings.md")
           (lambda (port)
             (let ((names (map (lambda (pair)
                                 (let ((name (cadr pair)))
                                  (name->string name)))
                               ((sxpath '(@ name)) modules))))
               (for-each (lambda (name)
                           (format port "### [[~a]] ###~2%" name))
                         names)))))))))