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))

;; 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))))

;; Iterate over the contents of a define-library, and collect comments on certain defines.
(define (parse-library-contents 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> ...)
                                   ((and (list? i) (eq? (car i) 'define-record-type))
                                    (set! defines (cons (cons (cadr i) (cons (cadr i) (reverse comments))) defines))
                                    (set! comments '()))

                                   ; (define (foo bar baz) quux)
                                   ((and (list? i) (eq? (car i) 'define) (list? (cadr i)))
                                    (set! defines (cons (cons (car (cadr i)) (cons (cadr i) (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) (cons (list (cadr i)) (reverse comments))) defines))
                                    (set! comments '()))

                                   ; (define foo (case-lambda ((bar baz) ...) ((quux aeou) ...) (rest ...)))
                                   ((and (list? i) (eq? (car i) 'define) (list? (list-ref i 2)) (eq? (car (list-ref i 2)) 'case-lambda))
                                    (let* ((extra-comments (map (lambda (vp) (if (list? vp) (sprintf "- `++~S++`" (cons (cadr i) (car vp))) (sprintf "- `++~S++`" (cons (cadr i) vp)))) (cdr (list-ref i 2))))
                                           (entries (cdr (list-ref i 2)))
                                           (first-entry-length (length (car entries)))
                                           (last-entry (car (list-ref entries (- (length entries) 1))))
                                           (repr (sprintf "\x28~S" (cadr i))))
                                     (unless (list? last-entry) (set! last-entry (list (sprintf ". ~A" (symbol->string last-entry)))))
                                     (do ((i 0 (+ i 1)) (n last-entry (cdr n)))
                                         ((eq? n '()) #f)
                                         (when (>= i (- first-entry-length 1)) (set-car! n (sprintf "[~A]" (symbol->string (car n))))))
                                     (for-each (lambda (v) (set! repr (sprintf "~A ~A" repr v))) last-entry)
                                     (set! defines (cons (cons (cadr i) (cons (string-append repr "\x29") (append extra-comments (list "") (reverse comments)))) defines))
                                     (set! comments '())))

                                   ; (define foo ...)
                                   ((and (list? i) (eq? (car i) 'define))
                                    (set! defines (cons (cons (cadr i) (cons (cadr i) (reverse comments))) defines))
                                    (set! comments '()))))
                              (cdr j)))))
              contents)
    
    (define out-path (string-append root "/docs/modules/generated/pages"))
    (define first #t)
    (for-each (lambda (l) (set! out-path (string-append out-path (if first "/" ".") (symbol->string l))) (set! first #f)) (car contents))
    (set! out-path (string-append out-path ".adoc"))

    (define out-file (open-output-file out-path))
    ; Print out the comments
    (fprintf out-file "= `~A`\n\n" (car contents))
    (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)
                          (fprintf out-file "== `+~A+`\n" (cadr val))
                          (for-each (lambda (l) (fprintf out-file "~A\n" l)) (cddr 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 contents)
    (define comments '())
    (for-each (lambda (j)
                  (cond ((eq? (car j) 'define-library) (parse-library-contents (cdr j) (reverse comments)))
                        ((eq? (car j) 'comment) (set! comments (cons (cadr j) comments))))) contents))


(define (process-file fname _)
  (parse-file (read-file-with-rewritten-comments fname)))
     

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