/usr/share/racket/collects/syntax/docprovide.rkt is in racket-common 6.7-3.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 | #lang racket/base
(require (for-syntax racket/base
"private/doctable.rkt"))
(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 #t)])
;; 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 #t)])
(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)
|