88 lines
4.4 KiB
Scheme
88 lines
4.4 KiB
Scheme
(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)))
|
|
|
|
; If we then see either a define or a define-record-type, emit the comments.
|
|
((and (list? i) (or (eq? (car i) 'define) (eq? (car i) 'define-record-type)))
|
|
(if (list? (cadr i))
|
|
; TODO(puck): bad code
|
|
(set! defines (cons (cons (car (cadr i)) (cons (cadr i) (reverse comments))) defines))
|
|
(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 "= `~S`\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 "== `+~S+`\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)
|