docs: improve doc rendering
Change-Id: I6a6a6964b1def9e8e9109fbd9319fa32595f1b72
This commit is contained in:
parent
781e2b5534
commit
fd85edb582
10 changed files with 1442 additions and 43 deletions
|
|
@ -23,6 +23,55 @@
|
|||
(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))))
|
||||
|
||||
;; Iterate over the contents of a define-library, and collect comments on certain defines.
|
||||
(define (parse-library-contents fname contents lib-comments)
|
||||
(define comments '())
|
||||
|
|
@ -35,7 +84,7 @@
|
|||
;; 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)
|
||||
|
|
@ -43,43 +92,55 @@
|
|||
; 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> ...)
|
||||
; (define-record-type <record-name> (make-...) is-record? ...)
|
||||
((and (list? i) (eq? (car i) 'define-record-type))
|
||||
(set! defines (cons (cons (cadr i) (cons (cadr i) (reverse comments))) defines))
|
||||
(set! comments '()))
|
||||
(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) (list? (cadr i)))
|
||||
(set! defines (cons (cons (car (cadr i)) (cons (cadr i) (reverse comments))) defines))
|
||||
(set! comments '()))
|
||||
(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) (cons (list (cadr i)) (reverse comments))) defines))
|
||||
(set! defines (cons (cons (cadr i) (make-doc-entry (make-lambda-doc (cadr i) '() '("val") #f) (reverse comments))) defines))
|
||||
(set! comments '()))
|
||||
|
||||
; (define foo (case-lambda ((bar baz) ...) ((quux aeou) ...) (rest ...)))
|
||||
; 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* ((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))
|
||||
(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) (cons (cadr i) (reverse comments))) defines))
|
||||
(set! defines (cons (cons (cadr i) (make-doc-entry (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))
|
||||
|
|
@ -93,8 +154,12 @@
|
|||
(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))
|
||||
(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))
|
||||
|
|
@ -110,6 +175,6 @@
|
|||
|
||||
(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)
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue