manual-form.rkt (17118B)
1 #lang scheme/base 2 (require "../decode.rkt" 3 "../struct.rkt" 4 "../scheme.rkt" 5 "../basic.rkt" 6 "../manual-struct.rkt" 7 "qsloc.rkt" 8 "manual-utils.rkt" 9 "manual-vars.rkt" 10 "manual-scheme.rkt" 11 "manual-bind.rkt" 12 scheme/list 13 (for-syntax scheme/base 14 syntax/parse 15 racket/syntax) 16 (for-label scheme/base)) 17 18 (provide defform defform* defform/subs defform*/subs defform/none 19 defidform defidform/inline 20 specform specform/subs 21 specsubform specsubform/subs specspecsubform specspecsubform/subs 22 specsubform/inline 23 defsubform defsubform* 24 racketgrammar racketgrammar* 25 (rename-out [racketgrammar schemegrammar] 26 [racketgrammar* schemegrammar*]) 27 var svar 28 (for-syntax kind-kw id-kw link-target?-kw 29 literals-kw subs-kw contracts-kw)) 30 31 (begin-for-syntax 32 (define-splicing-syntax-class kind-kw 33 #:description "#:kind keyword" 34 (pattern (~seq #:kind kind)) 35 (pattern (~seq) 36 #:with kind #'#f)) 37 38 (define-splicing-syntax-class id-kw 39 #:description "#:id keyword" 40 (pattern (~seq #:id [defined-id:id defined-id-expr])) 41 (pattern (~seq #:id defined-id:id) 42 #:with defined-id-expr #'(quote-syntax defined-id)) 43 (pattern (~seq #:id [#f #f]) 44 #:with defined-id #'#f 45 #:with defined-id-expr #'#f) 46 (pattern (~seq) 47 #:with defined-id #'#f 48 #:with defined-id-expr #'#f)) 49 50 (define-splicing-syntax-class link-target?-kw 51 #:description "#:link-target? keyword" 52 (pattern (~seq #:link-target? expr)) 53 (pattern (~seq) 54 #:with expr #'#t)) 55 56 (define-splicing-syntax-class literals-kw 57 #:description "#:literals keyword" 58 (pattern (~seq #:literals (lit:id ...))) 59 (pattern (~seq) 60 #:with (lit ...) #'())) 61 62 (define-splicing-syntax-class contracts-kw 63 #:description "#:contracts keyword" 64 (pattern (~seq #:contracts (~and cs ([contract-nonterm:id contract-expr] ...)))) 65 (pattern (~seq) 66 #:with (~and cs ((contract-nonterm contract-expr) ...)) #'())) 67 68 (define-syntax-class grammar 69 #:description "grammar" 70 (pattern ([non-term-id:id non-term-form ...+] ...))) 71 72 (define-splicing-syntax-class subs-kw 73 #:description "#:grammar keyword" 74 #:attributes (g (g.non-term-id 1) (g.non-term-form 2)) 75 (pattern (~seq #:grammar g:grammar)) 76 (pattern (~seq) #:with g:grammar #'())) 77 ) 78 79 (define-syntax (defform*/subs stx) 80 (syntax-parse stx 81 [(_ k:kind-kw lt:link-target?-kw d:id-kw l:literals-kw [spec spec1 ...] 82 g:grammar 83 c:contracts-kw 84 desc ...) 85 (with-syntax* ([defined-id (if (syntax-e #'d.defined-id) 86 #'d.defined-id 87 (syntax-case #'spec () 88 [(spec-id . _) #'spec-id]))] 89 [defined-id-expr (if (syntax-e #'d.defined-id-expr) 90 #'d.defined-id-expr 91 #'(quote-syntax defined-id))] 92 [(new-spec ...) 93 (for/list ([spec (in-list (syntax->list #'(spec spec1 ...)))]) 94 (let loop ([spec spec]) 95 (if (and (identifier? spec) 96 (free-identifier=? spec #'defined-id)) 97 (datum->syntax #'here '(unsyntax x) spec spec) 98 (cond 99 [(syntax? spec) (datum->syntax spec 100 (loop (syntax-e spec)) 101 spec 102 spec)] 103 [(pair? spec) (cons (loop (car spec)) 104 (loop (cdr spec)))] 105 [else spec]))))]) 106 #'(with-togetherable-racket-variables 107 (l.lit ...) 108 ([form [defined-id spec]] [form [defined-id spec1]] ... 109 [non-term (g.non-term-id g.non-term-form ...)] ...) 110 (*defforms k.kind lt.expr defined-id-expr 111 '(spec spec1 ...) 112 (list (lambda (x) (racketblock0/form new-spec)) ...) 113 '((g.non-term-id g.non-term-form ...) ...) 114 (list (list (lambda () (racket g.non-term-id)) 115 (lambda () (racketblock0/form g.non-term-form)) 116 ...) 117 ...) 118 (list (list (lambda () (racket c.contract-nonterm)) 119 (lambda () (racketblock0 c.contract-expr))) 120 ...) 121 (lambda () (list desc ...)))))])) 122 123 (define-syntax (defform* stx) 124 (syntax-parse stx 125 [(_ k:kind-kw lt:link-target?-kw d:id-kw l:literals-kw [spec ...] 126 subs:subs-kw c:contracts-kw desc ...) 127 (syntax/loc stx 128 (defform*/subs #:kind k.kind 129 #:link-target? lt.expr 130 #:id [d.defined-id d.defined-id-expr] 131 #:literals (l.lit ...) 132 [spec ...] subs.g #:contracts c.cs desc ...))])) 133 134 (define-syntax (defform stx) 135 (syntax-parse stx 136 [(_ k:kind-kw lt:link-target?-kw d:id-kw l:literals-kw spec 137 subs:subs-kw c:contracts-kw desc ...) 138 (syntax/loc stx 139 (defform*/subs #:kind k.kind 140 #:link-target? lt.expr 141 #:id [d.defined-id d.defined-id-expr] 142 #:literals (l.lit ...) 143 [spec] subs.g #:contracts c.cs desc ...))])) 144 145 (define-syntax (defform/subs stx) 146 (syntax-parse stx 147 [(_ k:kind-kw lt:link-target?-kw d:id-kw l:literals-kw spec subs desc ...) 148 (syntax/loc stx 149 (defform*/subs #:kind k.kind 150 #:link-target? lt.expr 151 #:id [d.defined-id d.defined-id-expr] 152 #:literals (l.lit ...) 153 [spec] subs desc ...))])) 154 155 (define-syntax (defform/none stx) 156 (syntax-parse stx 157 [(_ k:kind-kw lt:link-target?-kw l:literals-kw spec subs:subs-kw c:contracts-kw desc ...) 158 (syntax/loc stx 159 (with-togetherable-racket-variables 160 (l.lit ...) 161 ([form/none spec] 162 [non-term (subs.g.non-term-id subs.g.non-term-form ...)] ...) 163 (*defforms k.kind lt.expr #f 164 '(spec) 165 (list (lambda (ignored) (racketblock0/form spec))) 166 '((subs.g.non-term-id subs.g.non-term-form ...) ...) 167 (list (list (lambda () (racket subs.g.non-term-id)) 168 (lambda () (racketblock0/form subs.g.non-term-form)) 169 ...) 170 ...) 171 (list (list (lambda () (racket c.contract-nonterm)) 172 (lambda () (racketblock0 c.contract-expr))) 173 ...) 174 (lambda () (list desc ...)))))])) 175 176 (define-syntax (defidform/inline stx) 177 (syntax-case stx (unsyntax) 178 [(_ id) 179 (identifier? #'id) 180 #'(defform-site (quote-syntax id))] 181 [(_ (unsyntax id-expr)) 182 #'(defform-site id-expr)])) 183 184 (define-syntax (defidform stx) 185 (syntax-parse stx 186 [(_ k:kind-kw lt:link-target?-kw spec-id desc ...) 187 #'(with-togetherable-racket-variables 188 () 189 () 190 (*defforms k.kind lt.expr (quote-syntax/loc spec-id) 191 '(spec-id) 192 (list (lambda (x) (make-omitable-paragraph (list x)))) 193 null 194 null 195 null 196 (lambda () (list desc ...))))])) 197 198 (define (into-blockquote s) 199 (make-blockquote "leftindent" 200 (if (splice? s) 201 (flow-paragraphs (decode-flow (splice-run s))) 202 (list s)))) 203 204 (define-syntax (defsubform stx) 205 (syntax-case stx () 206 [(_ . rest) #'(into-blockquote (defform . rest))])) 207 208 (define-syntax (defsubform* stx) 209 (syntax-case stx () 210 [(_ . rest) #'(into-blockquote (defform* . rest))])) 211 212 (define-syntax (spec?form/subs stx) 213 (syntax-parse stx 214 [(_ has-kw? l:literals-kw spec g:grammar 215 c:contracts-kw 216 desc ...) 217 (syntax/loc stx 218 (with-racket-variables 219 (l.lit ...) 220 ([form/maybe (has-kw? spec)] 221 [non-term (g.non-term-id g.non-term-form ...)] ...) 222 (*specsubform 'spec '(l.lit ...) (lambda () (racketblock0/form spec)) 223 '((g.non-term-id g.non-term-form ...) ...) 224 (list (list (lambda () (racket g.non-term-id)) 225 (lambda () (racketblock0/form g.non-term-form)) 226 ...) 227 ...) 228 (list (list (lambda () (racket c.contract-nonterm)) 229 (lambda () (racketblock0 c.contract-expr))) 230 ...) 231 (lambda () (list desc ...)))))])) 232 233 (define-syntax (specsubform stx) 234 (syntax-parse stx 235 [(_ l:literals-kw spec subs:subs-kw c:contracts-kw desc ...) 236 (syntax/loc stx 237 (spec?form/subs #f #:literals (l.lit ...) spec subs.g #:contracts c.cs desc ...))])) 238 239 (define-syntax (specsubform/subs stx) 240 (syntax-parse stx 241 [(_ l:literals-kw spec g:grammar desc ...) 242 (syntax/loc stx 243 (spec?form/subs #f #:literals (l.lit ...) spec 244 ([g.non-term-id g.non-term-form ...] ...) 245 desc ...))])) 246 247 (define-syntax-rule (specspecsubform spec desc ...) 248 (make-blockquote "leftindent" (list (specsubform spec desc ...)))) 249 250 (define-syntax-rule (specspecsubform/subs spec subs desc ...) 251 (make-blockquote "leftindent" (list (specsubform/subs spec subs desc ...)))) 252 253 (define-syntax (specform stx) 254 (syntax-parse stx 255 [(_ l:literals-kw spec subs:subs-kw c:contracts-kw desc ...) 256 (syntax/loc stx 257 (spec?form/subs #t #:literals (l.lit ...) spec subs.g #:contracts c.cs desc ...))])) 258 259 (define-syntax (specform/subs stx) 260 (syntax-parse stx 261 [(_ l:literals-kw spec g:grammar 262 desc ...) 263 (syntax/loc stx 264 (spec?form/subs #t #:literals (l.lit ...) spec ([g.non-term-id g.non-term-form ...] ...) 265 desc ...))])) 266 267 (define-syntax-rule (specsubform/inline spec desc ...) 268 (with-racket-variables 269 () 270 ([form/maybe (#f spec)]) 271 (*specsubform 'spec null #f null null null (lambda () (list desc ...))))) 272 273 (define-syntax racketgrammar 274 (syntax-rules () 275 [(_ #:literals (lit ...) id clause ...) 276 (racketgrammar* #:literals (lit ...) [id clause ...])] 277 [(_ id clause ...) (racketgrammar #:literals () id clause ...)])) 278 279 (define-syntax racketgrammar* 280 (syntax-rules () 281 [(_ #:literals (lit ...) [id clause ...] ...) 282 (with-racket-variables 283 (lit ...) 284 ([non-term (id clause ...)] ...) 285 (*racketgrammar '(lit ...) 286 '(id ... clause ... ...) 287 (lambda () 288 (list (list (racket id) 289 (racketblock0/form clause) ...) 290 ...))))] 291 [(_ [id clause ...] ...) 292 (racketgrammar* #:literals () [id clause ...] ...)])) 293 294 (define-syntax-rule (var id) 295 (*var 'id)) 296 297 (define-syntax-rule (svar id) 298 (*var 'id)) 299 300 301 (define (meta-symbol? s) (memq s '(... ...+ ?))) 302 303 (define (defform-site kw-id) 304 (let ([target-maker (id-to-form-target-maker kw-id #t)]) 305 (define-values (content ref-content) (definition-site (syntax-e kw-id) kw-id #t)) 306 (if target-maker 307 (target-maker 308 content 309 (lambda (tag) 310 (make-toc-target2-element 311 #f 312 (if kw-id 313 (make-index-element 314 #f content tag 315 (list (datum-intern-literal (symbol->string (syntax-e kw-id)))) 316 (list ref-content) 317 (with-exporting-libraries 318 (lambda (libs) 319 (make-form-index-desc (syntax-e kw-id) 320 libs)))) 321 content) 322 tag 323 ref-content))) 324 content))) 325 326 (define (*defforms kind link? kw-id forms form-procs subs sub-procs contract-procs content-thunk) 327 (parameterize ([current-meta-list '(... ...+)]) 328 (make-box-splice 329 (cons 330 (make-blockquote 331 vertical-inset-style 332 (list 333 (make-table 334 boxed-style 335 (append 336 (for/list ([form (in-list forms)] 337 [form-proc (in-list form-procs)] 338 [i (in-naturals)]) 339 (list 340 ((if (zero? i) (add-background-label (or kind "syntax")) values) 341 (list 342 ((or form-proc 343 (lambda (x) 344 (make-omitable-paragraph 345 (list (to-element `(,x . ,(cdr form))))))) 346 (and kw-id 347 (if (eq? form (car forms)) 348 (if link? 349 (defform-site kw-id) 350 (to-element #:defn? #t kw-id)) 351 (to-element #:defn? #t kw-id)))))))) 352 (if (null? sub-procs) 353 null 354 (list (list flow-empty-line) 355 (list (make-flow 356 (list (let ([l (map (lambda (sub) 357 (map (lambda (f) (f)) sub)) 358 sub-procs)]) 359 (*racketrawgrammars "specgrammar" 360 (map car l) 361 (map cdr l)))))))) 362 (make-contracts-table contract-procs))))) 363 (content-thunk))))) 364 365 (define (*specsubform form lits form-thunk subs sub-procs contract-procs content-thunk) 366 (parameterize ([current-meta-list '(... ...+)]) 367 (make-blockquote 368 "leftindent" 369 (cons 370 (make-blockquote 371 vertical-inset-style 372 (list 373 (make-table 374 boxed-style 375 (cons 376 (list 377 (make-flow 378 (list 379 (if form-thunk 380 (form-thunk) 381 (make-omitable-paragraph (list (to-element form))))))) 382 (append 383 (if (null? sub-procs) 384 null 385 (list (list flow-empty-line) 386 (list (make-flow 387 (list (let ([l (map (lambda (sub) 388 (map (lambda (f) (f)) sub)) 389 sub-procs)]) 390 (*racketrawgrammars "specgrammar" 391 (map car l) 392 (map cdr l)))))))) 393 (make-contracts-table contract-procs)))))) 394 (flow-paragraphs (decode-flow (content-thunk))))))) 395 396 (define (*racketrawgrammars style nonterms clauseses) 397 (make-table 398 `((valignment baseline baseline baseline baseline baseline) 399 (alignment right left center left left) 400 (style ,style)) 401 (cdr 402 (append-map 403 (lambda (nonterm clauses) 404 (list* 405 (list flow-empty-line flow-empty-line flow-empty-line 406 flow-empty-line flow-empty-line) 407 (list (to-flow nonterm) flow-empty-line (to-flow "=") flow-empty-line 408 (make-flow (list (car clauses)))) 409 (map (lambda (clause) 410 (list flow-empty-line flow-empty-line 411 (to-flow "|") flow-empty-line 412 (make-flow (list clause)))) 413 (cdr clauses)))) 414 nonterms clauseses)))) 415 416 (define (*racketrawgrammar style nonterm clause1 . clauses) 417 (*racketrawgrammars style (list nonterm) (list (cons clause1 clauses)))) 418 419 (define (*racketgrammar lits s-expr clauseses-thunk) 420 (let ([l (clauseses-thunk)]) 421 (*racketrawgrammars #f 422 (map (lambda (x) 423 (make-element #f 424 (list (hspace 2) 425 (car x)))) 426 l) 427 (map cdr l)))) 428 429 (define (*var id) 430 (to-element (*var-sym id))) 431 432 (define (*var-sym id) 433 (string->symbol (format "_~a" id))) 434 435 (define (make-contracts-table contract-procs) 436 (if (null? contract-procs) 437 null 438 (append 439 (list (list flow-empty-line)) 440 (list (list (make-flow 441 (map (lambda (c) 442 (make-table 443 "argcontract" 444 (list 445 (list (to-flow (hspace 2)) 446 (to-flow ((car c))) 447 flow-spacer 448 (to-flow ":") 449 flow-spacer 450 (make-flow (list ((cadr c)))))))) 451 contract-procs)))))))