zilch/docs/docread/docread.scm

(import (scheme base) (scheme file) (scheme write) (chicken read-syntax) (chicken process-context) (chicken irregex) (chicken format) (chicken process) (chicken file) (zilch zexpr) (srfi 132))

;; Return a string version of the passed-in val, but properly quoted as s-expression.
(define (quotify val)
  (call-with-port (open-output-string) (lambda (port) (write val port) (get-output-string port))))

;; Read a file, and rewrite all doc comments (comments starting with ";;") with comment s-expressions.
(define (read-file-with-rewritten-comments f)
  (define port (open-input-file f))
  (define str-out (open-output-string))
  (write-string "(\n" str-out)
  (do ((buf (string) (read-string 2048 port))) ((eof-object? buf) #f) (write-string buf str-out))
  (close-input-port port)
  (write-string "\n)" str-out)
  (define comments-fixed
    (irregex-replace/all
      ; Written weirdly to avoid the regexp catching itself.
      ; TODO(puck): only apply at the start of lines?
      (string->irregex ";{2,} *([^\\n]*)" 'm)
      (get-output-string str-out)

      ;; TODO: do we need the space here? this could also be a reader macro instead.
      (lambda (m) (string-append " " (quotify (list 'comment (irregex-match-substring m 1)))))))
  (call-with-port (open-input-string comments-fixed) (lambda (port) (read port))))

(define-record-type <lambda-doc>
 (make-lambda-doc name arguments optionals trailing)
 lambda-doc?
 (name lambda-doc-name)
 (arguments lambda-doc-arguments)
 (optionals lambda-doc-optionals)
 (trailing lambda-doc-trailing))

(define-record-type <doc-entry>
  (make-doc-entry name comments)
  doc-entry?
  (name doc-entry-name)
  (comments doc-entry-comments))

(define (parse-lambda-deps name data optional-count)
 (define arguments '())
 (define optionals '())
 (define trailing #f)
 (let loop ((i 0) (data data))
  (cond
   ((null? data) (make-lambda-doc name (reverse arguments) (reverse optionals) #f))
   ((symbol? data) (make-lambda-doc name (reverse arguments) (reverse optionals) data))
   ((and optional-count (> i optional-count)) (set! optionals (cons (car data) optionals)) (loop (+ i 1) (cdr data)))
   (else (set! arguments (cons (car data) arguments)) (loop (+ i 1) (cdr data))))))

(define (render-lambda-doc port doc)
  (fprintf port "``++\x28~A" (lambda-doc-name doc))
  (for-each
   (lambda (arg)
    (fprintf port " ~A" arg))
   (lambda-doc-arguments doc))
  (fprintf port "++")
  (for-each
   (lambda (arg)
    (fprintf port " _++[~A]++_" arg))
   (lambda-doc-optionals doc))
  (when (lambda-doc-trailing doc)
   (fprintf port " . _++~A++_" (lambda-doc-trailing doc)))
  (fprintf port "\x29``"))


(define (get-anchor-safe-name entry)
 (define name (symbol->string (if (lambda-doc? (doc-entry-name entry)) (lambda-doc-name (doc-entry-name entry)) (doc-entry-name entry))))
 (string-map (lambda (ch) (if (or (char=? ch #\<) (char=? ch #\>) (char=? ch #\%)) #\_ ch)) name))

(define (lambda-doc->string doc)
 (call-with-port (open-output-string)
  (lambda (p) (render-lambda-doc p doc) (get-output-string p))))

(define table-of-contents
 '(((zilch lang rust) . ())
   ((zilch lang ninja) . ())
   ((zilch lang go) . ())
   ((zilch nix) . ())
   ((zilch lib) . ())
   ((zilch) . ())))

; Returns whether `left` is a prefix of `right`.
(define (is-prefix left right)
  (define
   res
   (let loop ((left left) (right right))
    (cond
     ((and (null? left) (null? right)) #t)
     ((null? left) #t)
     ((null? right) #f)
     ((equal? (car left) (car right)) (loop (cdr left) (cdr right)))
     (else #f))))
  res)

(define (add-to-toc name path)
  (let loop ((item table-of-contents))
    (cond
     ((null? item) (error "Unknown TOC root" name))
     ((equal? name (caar item)) (set-cdr! (car item) (cons (sprintf "** xref:generated:~A[++~A++]\n" path name) (cdar item))))
     ((is-prefix (caar item) name) (set-cdr! (car item) (cons (sprintf "*** xref:generated:~A[++~A++]\n" path name) (cdar item))))
     (else (loop (cdr item))))))

;; Iterate over the contents of a define-library, and collect comments on certain defines.
(define (parse-library-contents fname contents lib-comments)
    (define comments '())
    (define defines '())
    (define imports '())
    (define exports '())

    (for-each (lambda (j)
                  (cond
                   ;; Track imports and exports respectively.
                   ((eq? (car j) 'import) (set! imports (append (cdr j) imports)))
                   ((eq? (car j) 'export) (set! exports (append (cdr j) exports)))

                   ((eq? (car j) 'begin)
                    ; For each top-level object in the (begin) block...
                    (for-each (lambda (i)
                                  (cond
                                   ; If we see a preprocessed comment, collect it
                                   ((and (list? i) (eq? (car i) 'comment)) (set! comments (cons (cadr i) comments)))

                                   ; (define-record-type <record-name> (make-...) is-record? ...)
                                   ((and (list? i) (eq? (car i) 'define-record-type))
                                    (let* ((arguments (cddr (cddr i)))
                                           (extra-comments (map (lambda (v) (sprintf "- ``++~A++``" v)) arguments)))
                                     (set! defines (cons (cons (cadr i) (make-doc-entry (cadr i) (append extra-comments '("") (reverse comments)))) defines))
                                     (set! comments '())))

                                   ; (define (foo bar baz) quux)
                                   ((and (list? i) (eq? (car i) 'define) (pair? (cadr i)))
                                    (let* ((def (cadr i)) (name (car def)) (args (cdr def)))
                                     (set! defines (cons (cons name (make-doc-entry (make-lambda-doc name args '() #f) (reverse comments))) defines))
                                     (set! comments '())))

                                   ; (define foo (make-parameter ...))
                                   ((and (list? i) (eq? (car i) 'define) (list? (list-ref i 2)) (eq? (car (list-ref i 2)) 'make-parameter))
                                    (set! defines (cons (cons (cadr i) (make-doc-entry (make-lambda-doc (cadr i) '() '("val") #f) (reverse comments))) defines))
                                    (set! comments '()))

                                   ; This parser assumes that each `case-lambda` entry is in order of increasing size, and optionally ends with a "catchall"
                                   ; so e.g.
                                   ; (define foo
                                   ;  (case-lambda
                                   ;    ((foo) ...)
                                   ;    ((foo bar) ...)
                                   ;    ((foo bar baz) ...)
                                   ;    (quux ...)))
                                   ((and (list? i) (eq? (car i) 'define) (list? (list-ref i 2)) (eq? (car (list-ref i 2)) 'case-lambda))
                                    (let* ((name (list-ref i 1))
                                           (cases (cdr (list-ref i 2)))
                                           (required-argument-count (length (caar cases)))
                                           (last-entry (car (list-ref cases (- (length cases) 1))))
                                           (trailing (if (list? last-entry) #f last-entry))
                                           (generic-definition
                                            (parse-lambda-deps name
                                              (if (list? last-entry)
                                               last-entry
                                               (car (list-ref cases (- (length cases) 2))))
                                             required-argument-count))
                                           (case-definitions (map (lambda (v) (parse-lambda-deps name (car v) #f)) cases)))
                                     (set! defines (cons (cons (cadr i) (make-doc-entry generic-definition (append (map (lambda (v) (string-append "- " (lambda-doc->string v))) case-definitions) '("") (reverse comments)))) defines))
                                     (set! comments '())))

                                   ; (define foo ...)
                                   ((and (list? i) (eq? (car i) 'define))
                                    (set! defines (cons (cons (cadr i) (make-doc-entry (cadr i) (reverse comments))) defines))
                                    (set! comments '()))))
                              (cdr j)))))
              contents)

    (define first #t)
    (define file-path "")
    (for-each (lambda (l) (set! file-path (string-append file-path (if first "" ".") (symbol->string l))) (set! first #f)) (car contents))
    (set! file-path (string-append file-path ".adoc"))
    (define out-path (string-append root "/docs/modules/generated/pages/" file-path))
    (add-to-toc (car contents) file-path)

    (define out-file (open-output-file out-path))
    ; Print out the comments
    (fprintf out-file "= `~A`\n\nhttps://puck.moe/git/zilch/tree~A[source code]\n\n" (car contents) fname)
    (for-each (lambda (l) (fprintf out-file "~A\n" l)) lib-comments)
    (fprintf out-file "\n:toc:\n\n")
    (for-each (lambda (i)
                  (define val (assoc i defines))
                  (unless (eq? val #f)
                          (when (null? (doc-entry-comments (cdr val)))
                            (fprintf (current-error-port) "~S: ~S is undocumented!\n" (car contents) i))
                          (if (lambda-doc? (doc-entry-name (cdr val)))
                            (begin (fprintf out-file "[#~A]\n== " (get-anchor-safe-name (cdr val))) (render-lambda-doc out-file (doc-entry-name (cdr val))) (fprintf out-file "\n"))
                            (fprintf out-file "[#~A]\n== `+~A+`\n" (get-anchor-safe-name (cdr val)) (doc-entry-name (cdr val))))
                          (for-each (lambda (l) (fprintf out-file "~A\n" l)) (doc-entry-comments (cdr val)))
                          (fprintf out-file "\n")))
              exports)
    (close-output-port out-file))

(define root (call-with-input-pipe "git rev-parse --show-toplevel" (lambda (p) (define path (read-string 9999999 p)) (string-copy path 0 (- (string-length path) 1)))))

(define (parse-file fname contents)
    (define comments '())
    (for-each (lambda (j)
                  (cond ((eq? (car j) 'define-library) (parse-library-contents fname (cdr j) (reverse comments)))
                        ((eq? (car j) 'comment) (set! comments (cons (cadr j) comments))))) contents))


(define (process-file fname _)
  (parse-file (string-copy fname (string-length root)) (read-file-with-rewritten-comments fname)))


(find-files root #:test ".*\\.(sld|scm)" #:action process-file)

(call-with-output-file (string-append root "/docs/modules/generated/partials/nav.adoc")
 (lambda (p)
  (for-each
   (lambda (chunk)
    (define sorted (list-sort string<? (cdr chunk)))
    (when (or (null? sorted) (not (string=? (string-copy (car sorted) 0 3) "** ")))
     (fprintf p "** ++~A++\n" (car chunk)))
    (for-each (lambda (line) (write-string line p)) sorted)
    (write-string "\n" p))
   (reverse table-of-contents))))