123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204 |
- (define-module (ice-9 documentation)
- :use-module (ice-9 rdelim)
- :export (file-commentary
- documentation-files search-documentation-files
- object-documentation)
- :autoload (ice-9 regex) (match:suffix)
- :no-backtrace)
- (define (file-commentary filename . cust)
-
-
-
-
-
-
- (define default-in-line-re (make-regexp "^;;; Commentary:"))
- (define default-after-line-re (make-regexp "^;;; Code:"))
- (define default-scrub (let ((dirt (make-regexp "^;+")))
- (lambda (line)
- (let ((m (regexp-exec dirt line)))
- (if m (match:suffix m) line)))))
-
-
- (let ((in-line-re (if (> 1 (length cust))
- default-in-line-re
- (let ((v (car cust)))
- (cond ((regexp? v) v)
- ((string? v) (make-regexp v))
- (else default-in-line-re)))))
- (after-line-re (if (> 2 (length cust))
- default-after-line-re
- (let ((v (cadr cust)))
- (cond ((regexp? v) v)
- ((string? v) (make-regexp v))
- (else default-after-line-re)))))
- (scrub (if (> 3 (length cust))
- default-scrub
- (let ((v (caddr cust)))
- (cond ((procedure? v) v)
- (else default-scrub))))))
- (call-with-input-file filename
- (lambda (port)
- (let loop ((line (read-delimited "\n" port))
- (doc "")
- (parse-state 'before))
- (if (or (eof-object? line) (eq? 'after parse-state))
- doc
- (let ((new-state
- (cond ((regexp-exec in-line-re line) 'in)
- ((regexp-exec after-line-re line) 'after)
- (else parse-state))))
- (if (eq? 'after new-state)
- doc
- (loop (read-delimited "\n" port)
- (if (and (eq? 'in new-state) (eq? 'in parse-state))
- (string-append doc (scrub line) "\n")
- doc)
- new-state)))))))))
- (define documentation-files
- (map (lambda (vicinity)
- (in-vicinity (vicinity) "guile-procedures.txt"))
- (list %library-dir
- %package-data-dir
- %site-dir
- (lambda () "."))))
- (define entry-delimiter "\f")
- (define (find-documentation-in-file name file)
- (and (file-exists? file)
- (call-with-input-file file
- (lambda (port)
- (let ((name (symbol->string name)))
- (let ((len (string-length name)))
- (read-delimited entry-delimiter port)
- (let loop ((entry (read-delimited entry-delimiter port)))
- (cond ((eof-object? entry) #f)
-
- ((and
- (>= (string-length entry) len)
-
- (string=? (substring entry 0 len) name)
-
- (memq (string-ref entry len) '(#\newline)))
-
- (substring entry (+ len 2) (- (string-length entry) 2)))
- (else (loop (read-delimited entry-delimiter port)))))))))))
- (define (search-documentation-files name . files)
- (or-map (lambda (file)
- (find-documentation-in-file name file))
- (cond ((null? files) documentation-files)
- (else files))))
- (define (object-documentation object)
- "Return the docstring for OBJECT.
- OBJECT can be a procedure, macro or any object that has its
- `documentation' property set."
- (or (and (procedure? object)
- (procedure-documentation object))
- (object-property object 'documentation)
- (and (macro? object)
- (object-documentation (macro-transformer object)))
- (and (procedure? object)
- (procedure-name object)
- (let ((docstring (search-documentation-files
- (procedure-name object))))
- (if docstring
- (set-procedure-property! object 'documentation docstring))
- docstring))))
|