267 lines
7.9 KiB
Racket
267 lines
7.9 KiB
Racket
|
|
(module docprovide scheme/base
|
|
(require (for-syntax scheme/base
|
|
"private/doctable.ss"))
|
|
|
|
(define-syntaxes (provide-and-document provide-and-document/wrap)
|
|
(let ()
|
|
(define (add-prefix prefix rows)
|
|
(map (lambda (row)
|
|
(cons (car row)
|
|
(map
|
|
(lambda (x)
|
|
(cons prefix x))
|
|
(cdr row))))
|
|
rows))
|
|
|
|
(define (remove-prefixes rows)
|
|
(map (lambda (row)
|
|
(cons (car row)
|
|
(map (lambda (proc)
|
|
(let ([rest (cdr proc)])
|
|
(if (pair? (car rest))
|
|
(cons (cadar rest)
|
|
(cdr rest))
|
|
rest)))
|
|
(cdr row))))
|
|
rows))
|
|
|
|
(define (remove-docs rows exceptions)
|
|
(map (lambda (row)
|
|
(cons (car row)
|
|
(let loop ([l (cdr row)])
|
|
(cond
|
|
[(null? l) null]
|
|
[(memq (let ([i (cadar l)])
|
|
(if (symbol? i)
|
|
i
|
|
(cadr i)))
|
|
exceptions)
|
|
(loop (cdr l))]
|
|
[else (cons (car l) (loop (cdr l)))]))))
|
|
rows))
|
|
|
|
(define (go stx label wrap rows)
|
|
(unless (identifier? label)
|
|
(raise-syntax-error
|
|
'provide-and-document
|
|
"label is not an identifier"
|
|
stx
|
|
label))
|
|
(when wrap
|
|
(unless (identifier? wrap)
|
|
(raise-syntax-error
|
|
'provide-and-document
|
|
"wrap is not an identifier"
|
|
stx
|
|
wrap)))
|
|
(let ([rows (map (lambda (row)
|
|
;; Helper:
|
|
(define (get-existing tag path label exceptions)
|
|
(unless (identifier? tag)
|
|
(raise-syntax-error
|
|
'provide-and-document
|
|
"prefix tag is not an identifier"
|
|
stx
|
|
tag))
|
|
(unless (identifier? label)
|
|
(raise-syntax-error
|
|
'provide-and-document
|
|
"label is not an identifier"
|
|
stx
|
|
label))
|
|
(for-each
|
|
(lambda (except)
|
|
(unless (identifier? except)
|
|
(raise-syntax-error
|
|
'provide-and-document
|
|
"exclusion is not an identifier"
|
|
stx
|
|
except)))
|
|
exceptions)
|
|
(let ([mod ((current-module-name-resolver) path #f #f)])
|
|
;; Execute syntax part at top-level:
|
|
(dynamic-require mod (void))
|
|
;; Extract documentation via top-level:
|
|
(let ([docs ((dynamic-require-for-syntax
|
|
'syntax/private/doctable
|
|
'lookup-documentation)
|
|
mod
|
|
(syntax-e label))])
|
|
(unless docs
|
|
(raise-syntax-error
|
|
'provide-and-document
|
|
"could not find provided documentation"
|
|
stx
|
|
row))
|
|
(remove-docs (add-prefix tag docs)
|
|
(map syntax-e exceptions)))))
|
|
;; Parse row:
|
|
(syntax-case row ()
|
|
[(header proc ...)
|
|
(string? (syntax-e (syntax header)))
|
|
(begin
|
|
;; check form:
|
|
(map (lambda (proc)
|
|
(syntax-case proc ()
|
|
[(name type-sexpr doc-string ...)
|
|
(and (or (identifier? (syntax name))
|
|
(let ([l (syntax->list (syntax name))])
|
|
(and l
|
|
(= (length l) 2)
|
|
(andmap identifier? l))))
|
|
(andmap (lambda (s) (string? (syntax-e s)))
|
|
(syntax->list (syntax (doc-string ...)))))
|
|
'ok]))
|
|
(syntax->list (syntax (proc ...))))
|
|
(add-prefix #f (list (syntax->datum row))))]
|
|
[(all-from tag path label)
|
|
(eq? 'all-from (syntax-e (syntax all-from)))
|
|
(let ([tag (syntax tag)]
|
|
[label (syntax label)]
|
|
[path (syntax->datum (syntax path))])
|
|
(get-existing tag path label null))]
|
|
[(all-from-except tag path label exception ...)
|
|
(eq? 'all-from-except (syntax-e (syntax all-from-except)))
|
|
(let ([tag (syntax tag)]
|
|
[label (syntax label)]
|
|
[path (syntax->datum (syntax path))]
|
|
[exceptions (syntax->list (syntax (exception ...)))])
|
|
(get-existing tag path label exceptions))]))
|
|
rows)]
|
|
[imports (apply
|
|
append
|
|
(map (lambda (row)
|
|
(syntax-case row ()
|
|
[(header . _)
|
|
(string? (syntax-e (syntax header)))
|
|
null]
|
|
[(all-from/-except tag path label except ...)
|
|
(list (with-syntax ([pf (datum->syntax
|
|
stx
|
|
(syntax-e
|
|
(syntax (prefix-in tag path))))])
|
|
(syntax (require pf))))]))
|
|
rows))])
|
|
;; Collapse rows for a section name:
|
|
(let ([rows (let loop ([rows (apply append rows)])
|
|
(if (null? rows)
|
|
null
|
|
(let ([rest (loop (cdr rows))])
|
|
(let ([a (assoc (caar rows) rest)])
|
|
(if a
|
|
(cons (cons (caar rows)
|
|
(append (cdar rows)
|
|
(cdr a)))
|
|
(let loop ([l rest])
|
|
(cond
|
|
[(null? l) null]
|
|
[(equal? (caar l) (caar rows))
|
|
(cdr l)]
|
|
[else (cons (car l) (loop (cdr l)))])))
|
|
(cons (car rows) rest))))))])
|
|
;; Extract procs and eliminate duplicates
|
|
(let ([procs (let ([ht (make-hasheq)])
|
|
(for-each
|
|
(lambda (proc-line)
|
|
(let-values ([(loc-name ext-name)
|
|
(let ([n (cadr proc-line)])
|
|
(if (pair? n)
|
|
(values (car n) (cadr n))
|
|
(values n n)))])
|
|
(hash-set! ht ext-name (list* (car proc-line)
|
|
loc-name
|
|
ext-name))))
|
|
(apply append (map cdr rows)))
|
|
(hash-map ht (lambda (key val) val)))])
|
|
(let ([names (map (lambda (proc)
|
|
(cond
|
|
[(car proc)
|
|
;; Source prefixed:
|
|
`(,#'rename-out [,(string->symbol (format "~a~a"
|
|
(syntax-e (car proc))
|
|
(cadr proc)))
|
|
,(cadr proc)])]
|
|
[(eq? (cadr proc) (cddr proc))
|
|
;; Plain
|
|
(cadr proc)]
|
|
[else
|
|
;; Local renamed:
|
|
`(,#'rename-out [,(cadr proc)
|
|
,(cddr proc)])]))
|
|
procs)]
|
|
[wrapped-name
|
|
(lambda (name)
|
|
(string->symbol (format "~a>>~a"
|
|
(syntax-e wrap)
|
|
(if (pair? name)
|
|
(cadadr name)
|
|
name))))])
|
|
(with-syntax ([procs (datum->syntax
|
|
stx
|
|
(if wrap
|
|
(map (lambda (name)
|
|
`(,#'rename-out
|
|
[,(wrapped-name name)
|
|
,(if (pair? name)
|
|
(cadadr name)
|
|
name)]))
|
|
names)
|
|
names))]
|
|
[(wrap ...) (if wrap
|
|
(map (lambda (name)
|
|
`(,wrap ,(datum->syntax
|
|
wrap
|
|
(wrapped-name name))
|
|
,(datum->syntax
|
|
wrap
|
|
(if (pair? name)
|
|
(caadr name)
|
|
name))))
|
|
names)
|
|
null)]
|
|
[(import ...) imports]
|
|
[src (datum->syntax stx 'source)]
|
|
[rows (remove-prefixes rows)]
|
|
[label label])
|
|
(syntax/loc stx
|
|
(begin
|
|
import ...
|
|
wrap ...
|
|
(provide . procs)
|
|
(define-syntaxes ()
|
|
(begin
|
|
(register-documentation (quote-syntax src) 'label 'rows)
|
|
(values)))))))))))
|
|
|
|
(values
|
|
(lambda (stx)
|
|
(syntax-case stx ()
|
|
[(_ label row ...)
|
|
(go stx
|
|
(syntax label)
|
|
#f
|
|
(syntax->list (syntax (row ...))))]))
|
|
(lambda (stx)
|
|
(syntax-case stx ()
|
|
[(_ label wrap row ...)
|
|
(go stx
|
|
(syntax label)
|
|
(let ([s (syntax wrap)])
|
|
(and (syntax-e s) s))
|
|
(syntax->list (syntax (row ...))))])))))
|
|
|
|
|
|
(define (lookup-documentation path label)
|
|
(let ([mod ((current-module-name-resolver) path #f #f)])
|
|
(dynamic-require mod (void))
|
|
((dynamic-require-for-syntax
|
|
'syntax/private/doctable
|
|
'lookup-documentation)
|
|
mod
|
|
label)))
|
|
|
|
(provide provide-and-document
|
|
provide-and-document/wrap
|
|
lookup-documentation))
|