manual-form.rkt (26771B)
1 #lang scheme/base 2 ;; Added #:result option to defform. 3 ;; This file is mostly based on scribble-lib/scribble/private/manual-form.rkt 4 ;; With pieces from scribble-lib/scribble/private/manual-proc.rkt 5 ;; And pieces from scribble-lib/scribble/private/manual-scheme.rkt 6 7 (require scribble/decode 8 scribble/struct 9 scribble/scheme 10 scribble/basic 11 scribble/manual-struct 12 scribble/private/qsloc 13 scribble/private/manual-utils 14 scribble/private/manual-vars 15 "manual-scheme.rkt" 16 scribble/private/manual-bind 17 scheme/list 18 syntax/parse/define 19 (only-in scribble/core 20 make-style 21 make-table-columns 22 make-nested-flow 23 [make-paragraph make-paragraph2] 24 nested-flow) 25 (for-syntax scheme/base 26 syntax/parse 27 syntax/srcloc 28 racket/syntax) 29 (for-label scheme/base)) 30 31 (provide defform defform* defform/subs defform*/subs defform/none 32 defidform defidform/inline 33 specform specform/subs 34 specsubform specsubform/subs specspecsubform specspecsubform/subs 35 specsubform/inline 36 defsubform defsubform* 37 racketgrammar racketgrammar* 38 (rename-out [racketgrammar schemegrammar] 39 [racketgrammar* schemegrammar*]) 40 var svar 41 (for-syntax kind-kw id-kw link-target?-kw 42 literals-kw subs-kw contracts-kw)) 43 44 (begin-for-syntax 45 (define-splicing-syntax-class kind-kw 46 #:description "#:kind keyword" 47 (pattern (~seq #:kind kind)) 48 (pattern (~seq) 49 #:with kind #'#f)) 50 51 (define-splicing-syntax-class id-kw 52 #:description "#:id keyword" 53 (pattern (~seq #:id [defined-id:id defined-id-expr])) 54 (pattern (~seq #:id defined-id:id) 55 #:with defined-id-expr #'(quote-syntax defined-id)) 56 (pattern (~seq #:id [#f #f]) 57 #:with defined-id #'#f 58 #:with defined-id-expr #'#f) 59 (pattern (~seq) 60 #:with defined-id #'#f 61 #:with defined-id-expr #'#f)) 62 63 (define-splicing-syntax-class link-target?-kw 64 #:description "#:link-target? keyword" 65 (pattern (~seq #:link-target? expr)) 66 (pattern (~seq) 67 #:with expr #'#t)) 68 69 (define-splicing-syntax-class literals-kw 70 #:description "#:literals keyword" 71 (pattern (~seq #:literals (lit:id ...))) 72 (pattern (~seq) 73 #:with (lit ...) #'())) 74 75 (define-splicing-syntax-class result-kw 76 #:description "#:literals keyword" 77 (pattern (~seq #:result r) 78 #:with maybe-result #'(r)) 79 (pattern (~seq) 80 #:with maybe-result #'())) 81 (define-splicing-syntax-class results-kw 82 #:description "#:literals keyword" 83 (pattern (~seq #:results (result ...)))) 84 85 (define-splicing-syntax-class contracts-kw 86 #:description "#:contracts keyword" 87 (pattern (~seq #:contracts (~and cs ([contract-nonterm:id contract-expr] ...)))) 88 (pattern (~seq) 89 #:with (~and cs ((contract-nonterm contract-expr) ...)) #'())) 90 91 (define-syntax-class grammar 92 #:description "grammar" 93 (pattern ([non-term-id:id non-term-form ...+] ...))) 94 95 (define-splicing-syntax-class subs-kw 96 #:description "#:grammar keyword" 97 #:attributes (g (g.non-term-id 1) (g.non-term-form 2)) 98 (pattern (~seq #:grammar g:grammar)) 99 (pattern (~seq) #:with g:grammar #'())) 100 ) 101 102 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 103 ;; Adjusted from manual-scheme.rkt 104 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 105 (define-syntax-rule (define-/form* id base) 106 (define-syntax (id stx) 107 (syntax-case stx () 108 [(_ . a) 109 ;; Remove the context from any ellipsis in `a`: 110 (with-syntax ([a (strip-ellipsis-context #'a)]) 111 #'(base . a))]))) 112 113 (define-for-syntax (strip-ellipsis-context a) 114 (define a-ellipsis (datum->syntax a '...)) 115 (let loop ([a a]) 116 (cond 117 [(identifier? a) 118 (if (free-identifier=? a a-ellipsis #f) 119 (datum->syntax #f '... a a) 120 a)] 121 [(syntax? a) 122 (datum->syntax a (loop (syntax-e a)) a a)] 123 [(pair? a) 124 (cons (loop (car a)) 125 (loop (cdr a)))] 126 [(vector? a) 127 (list->vector 128 (map loop (vector->list a)))] 129 [(box? a) 130 (box (loop (unbox a)))] 131 [(prefab-struct-key a) 132 => (lambda (k) 133 (apply make-prefab-struct 134 k 135 (loop (cdr (vector->list (struct->vector a))))))] 136 [else a]))) 137 138 (define-/form* racketblock0/form* racketblock0) 139 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 140 141 142 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 143 ;; From manual-proc.rkt 144 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 145 (define-syntax (result-contract stx) 146 (syntax-case stx (values) 147 [(_ (values c ...)) 148 #'(list (racketblock0 c) ...)] 149 [(_ c) 150 (if (string? (syntax-e #'c)) 151 (raise-syntax-error 'defproc 152 "expected a result contract, found a string" #'c) 153 #'(racketblock0 c))] 154 [(_) 155 #'#f])) 156 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 157 158 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 159 ;; Adjusted from manual-proc.rkt 160 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 161 (define (end result-contract) 162 (define res 163 (let ([res (result-contract)]) 164 (and res 165 (if (list? res) 166 ;; multiple results 167 (if (null? res) 168 'nbsp 169 (let ([w (apply + (map block-width res))]) 170 (if (or (ormap table? res) (w . > . 40)) 171 (make-table 172 #f (map (lambda (fe) (list (make-flow (list fe)))) res)) 173 (make-table 174 #f 175 (list (let loop ([res res]) 176 (if (null? (cdr res)) 177 (list (make-flow (list (car res)))) 178 (list* (make-flow (list (car res))) 179 flow-spacer 180 (loop (cdr res)))))))))) 181 res)))) 182 (if res 183 (list flow-spacer (to-flow 'rarr) 184 flow-spacer (make-flow (list res))) 185 (list))) 186 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 187 188 (define-syntax (defform*/subs stx) 189 (syntax-parse stx 190 [(_ k:kind-kw lt:link-target?-kw d:id-kw l:literals-kw [spec spec1 ...] 191 (~optional results:results-kw) 192 g:grammar 193 c:contracts-kw 194 desc ...) 195 (with-syntax* ([defined-id (if (syntax-e #'d.defined-id) 196 #'d.defined-id 197 (syntax-case #'spec () 198 [(spec-id . _) #'spec-id]))] 199 [defined-id-expr (if (syntax-e #'d.defined-id-expr) 200 #'d.defined-id-expr 201 #'(quote-syntax defined-id))] 202 [(new-spec ...) 203 (for/list ([spec (in-list (syntax->list #'(spec spec1 ...)))]) 204 (let loop ([spec spec]) 205 (if (and (identifier? spec) 206 (free-identifier=? spec #'defined-id)) 207 (datum->syntax #'here '(unsyntax x) spec spec) 208 #;(syntax-case spec () 209 [(a . b) 210 (datum->syntax spec 211 (cons (loop #'a) (loop #'b)) 212 spec 213 spec)] 214 [id 215 (and (identifier? #'id) 216 (or (free-identifier=? #'id #'syntax) 217 (free-identifier=? #'id #'unsyntax) 218 (free-identifier=? #'id #'quasisyntax))) 219 (if (= (source-location-span #'id) 2) 220 (datum->syntax #'here 221 `(unsyntax ',(syntax-e #'id)) 222 spec 223 spec) 224 (datum->syntax #'here 225 `(unsyntax (RACKET ,(syntax-e #'id))) 226 spec 227 spec))]) 228 229 230 (cond 231 [(and (identifier? spec) 232 (or (free-identifier=? spec #'quote) 233 (free-identifier=? spec #'unquote) 234 (free-identifier=? spec #'quasiquote))) 235 (if (= (source-location-span spec) 1) 236 (datum->syntax #'here 237 `(unsyntax ',(syntax-e spec)) 238 spec 239 spec) 240 (datum->syntax #'here 241 `(unsyntax (RACKET ,(syntax-e spec))) 242 spec 243 spec))] 244 [(and (identifier? spec) 245 (or (free-identifier=? spec #'syntax) 246 (free-identifier=? spec #'unsyntax) 247 (free-identifier=? spec #'quasisyntax))) 248 (if (= (source-location-span spec) 2) 249 (datum->syntax #'here 250 `(unsyntax ',(syntax-e spec)) 251 spec 252 spec) 253 (datum->syntax #'here 254 `(unsyntax (RACKET ,(syntax-e spec))) 255 spec 256 spec))] 257 [(syntax? spec) (datum->syntax spec 258 (loop (syntax-e spec)) 259 spec 260 spec)] 261 [(pair? spec) (cons (loop (car spec)) 262 (loop (cdr spec)))] 263 [else spec]))))] 264 [(maybe-result ...) (if (attribute results) 265 #'(results.result ...) 266 (map (λ _ #'()) 267 (syntax->list #'(spec spec1 ...))))]) 268 #'(with-togetherable-racket-variables 269 (l.lit ...) 270 ([form [defined-id spec]] [form [defined-id spec1]] ... 271 [non-term (g.non-term-id g.non-term-form ...)] ...) 272 (*defforms k.kind lt.expr defined-id-expr 273 '(spec spec1 ...) 274 (list 275 (lambda (x) 276 (top-align 277 make-table 278 "prototype" 279 (list 280 (list (list (racketblock0/form* new-spec))) 281 (list (list (make-flow (top-align 282 make-table 283 "prototype" 284 (list (end (λ () (result-contract . maybe-result))))))))))) 285 ...) 286 '((g.non-term-id g.non-term-form ...) ...) 287 (list (list (lambda () (racket g.non-term-id)) 288 (lambda () (racketblock0/form g.non-term-form)) 289 ...) 290 ...) 291 (list (list (lambda () (racket c.contract-nonterm)) 292 (lambda () (racketblock0 c.contract-expr))) 293 ...) 294 (lambda () (list desc ...)))))])) 295 296 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 297 ;; From manual-proc 298 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 299 (define top-align-styles (make-hash)) 300 (define (top-align make-table style-name cols) 301 (if (null? cols) 302 (make-table style-name null) 303 (let* ([n (length (car cols))] 304 [k (cons style-name n)]) 305 (make-table 306 (hash-ref top-align-styles 307 k 308 (lambda () 309 (define s 310 (make-style style-name 311 (list (make-table-columns (for/list ([i n]) 312 (make-style #f '(top))))))) 313 (hash-set! top-align-styles k s) 314 s)) 315 cols)))) 316 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 317 318 (define-syntax (defform* stx) 319 (syntax-parse stx 320 [(_ k:kind-kw lt:link-target?-kw d:id-kw l:literals-kw [spec ...] 321 (~optional r:results-kw) 322 subs:subs-kw c:contracts-kw desc ...) 323 (quasisyntax/loc stx 324 (defform*/subs #:kind k.kind 325 #:link-target? lt.expr 326 #:id [d.defined-id d.defined-id-expr] 327 #:literals (l.lit ...) 328 [spec ...] 329 #,@(if (attribute r) #'(#:results [r.result ...]) #'()) 330 subs.g #:contracts c.cs desc ...))])) 331 332 (define-syntax (defform stx) 333 (syntax-parse stx 334 [(_ k:kind-kw lt:link-target?-kw d:id-kw l:literals-kw spec 335 r:result-kw 336 subs:subs-kw c:contracts-kw desc ...) 337 (syntax/loc stx 338 (defform*/subs #:kind k.kind 339 #:link-target? lt.expr 340 #:id [d.defined-id d.defined-id-expr] 341 #:literals (l.lit ...) 342 [spec] #:results [r.maybe-result] subs.g #:contracts c.cs desc ...))])) 343 344 (define-syntax (defform/subs stx) 345 (syntax-parse stx 346 [(_ k:kind-kw lt:link-target?-kw d:id-kw l:literals-kw spec r:result-kw subs desc ...) 347 (syntax/loc stx 348 (defform*/subs #:kind k.kind 349 #:link-target? lt.expr 350 #:id [d.defined-id d.defined-id-expr] 351 #:literals (l.lit ...) 352 [spec] #:results [r.maybe-result] subs desc ...))])) 353 354 (define-syntax (defform/none stx) 355 (syntax-parse stx 356 [(_ k:kind-kw lt:link-target?-kw l:literals-kw spec subs:subs-kw c:contracts-kw desc ...) 357 (syntax/loc stx 358 (with-togetherable-racket-variables 359 (l.lit ...) 360 ([form/none spec] 361 [non-term (subs.g.non-term-id subs.g.non-term-form ...)] ...) 362 (*defforms k.kind lt.expr #f 363 '(spec) 364 (list (lambda (ignored) (racketblock0/form spec))) 365 '((subs.g.non-term-id subs.g.non-term-form ...) ...) 366 (list (list (lambda () (racket subs.g.non-term-id)) 367 (lambda () (racketblock0/form subs.g.non-term-form)) 368 ...) 369 ...) 370 (list (list (lambda () (racket c.contract-nonterm)) 371 (lambda () (racketblock0 c.contract-expr))) 372 ...) 373 (lambda () (list desc ...)))))])) 374 375 (define-syntax (defidform/inline stx) 376 (syntax-case stx (unsyntax) 377 [(_ id) 378 (identifier? #'id) 379 #'(defform-site (quote-syntax id))] 380 [(_ (unsyntax id-expr)) 381 #'(defform-site id-expr)])) 382 383 (define-syntax (defidform stx) 384 (syntax-parse stx 385 [(_ k:kind-kw lt:link-target?-kw spec-id desc ...) 386 #'(with-togetherable-racket-variables 387 () 388 () 389 (*defforms k.kind lt.expr (quote-syntax/loc spec-id) 390 '(spec-id) 391 (list (lambda (x) (make-omitable-paragraph (list x)))) 392 null 393 null 394 null 395 (lambda () (list desc ...))))])) 396 397 (define (into-blockquote s) 398 (make-blockquote "leftindent" 399 (if (splice? s) 400 (flow-paragraphs (decode-flow (splice-run s))) 401 (list s)))) 402 403 (define-syntax (defsubform stx) 404 (syntax-case stx () 405 [(_ . rest) #'(into-blockquote (defform . rest))])) 406 407 (define-syntax (defsubform* stx) 408 (syntax-case stx () 409 [(_ . rest) #'(into-blockquote (defform* . rest))])) 410 411 (define-syntax (spec?form/subs stx) 412 (syntax-parse stx 413 [(_ has-kw? l:literals-kw (~or (~seq #:unwrap (spec ...)) 414 (~and (~seq spec0) (~seq spec ...))) 415 g:grammar 416 c:contracts-kw 417 desc ...) 418 #:with spec* (or (attribute spec0) #'(spec ...)) 419 (syntax/loc stx 420 (with-racket-variables 421 (l.lit ...) 422 ([form/maybe (has-kw? spec*)] 423 [non-term (g.non-term-id g.non-term-form ...)] ...) 424 (*specsubform 'spec* '(l.lit ...) (lambda () (racketblock0/form* spec ...)) 425 '((g.non-term-id g.non-term-form ...) ...) 426 (list (list (lambda () (racket g.non-term-id)) 427 (lambda () (racketblock0/form g.non-term-form)) 428 ...) 429 ...) 430 (list (list (lambda () (racket c.contract-nonterm)) 431 (lambda () (racketblock0 c.contract-expr))) 432 ...) 433 (lambda () (list desc ...)))))])) 434 435 (begin-for-syntax 436 (define-splicing-syntax-class unwrappable-spec 437 (pattern (~seq #:unwrap s) #:with (m-u-spec ...) #'(#:unwrap s)) 438 (pattern (~seq spec) #:with (m-u-spec ...) #'(spec)))) 439 440 (define-syntax (specsubform stx) 441 (syntax-parse stx 442 [(_ l:literals-kw :unwrappable-spec subs:subs-kw c:contracts-kw desc ...) 443 (syntax/loc stx 444 (spec?form/subs #f #:literals (l.lit ...) m-u-spec ... subs.g #:contracts c.cs desc ...))])) 445 446 (define-syntax (specsubform/subs stx) 447 (syntax-parse stx 448 [(_ l:literals-kw :unwrappable-spec g:grammar desc ...) 449 (syntax/loc stx 450 (spec?form/subs #f #:literals (l.lit ...) m-u-spec ... 451 ([g.non-term-id g.non-term-form ...] ...) 452 desc ...))])) 453 454 (define-simple-macro (specspecsubform :unwrappable-spec desc ...) 455 (make-blockquote "leftindent" (list (specsubform m-u-spec ... desc ...)))) 456 457 (define-simple-macro (specspecsubform/subs :unwrappable-spec subs desc ...) 458 (make-blockquote "leftindent" (list (specsubform/subs m-u-spec ... subs desc ...)))) 459 460 (define-syntax (specform stx) 461 (syntax-parse stx 462 [(_ l:literals-kw spec subs:subs-kw c:contracts-kw desc ...) 463 (syntax/loc stx 464 (spec?form/subs #t #:literals (l.lit ...) spec subs.g #:contracts c.cs desc ...))])) 465 466 (define-syntax (specform/subs stx) 467 (syntax-parse stx 468 [(_ l:literals-kw spec g:grammar 469 desc ...) 470 (syntax/loc stx 471 (spec?form/subs #t #:literals (l.lit ...) spec ([g.non-term-id g.non-term-form ...] ...) 472 desc ...))])) 473 474 (define-syntax-rule (specsubform/inline spec desc ...) 475 (with-racket-variables 476 () 477 ([form/maybe (#f spec)]) 478 (*specsubform 'spec null #f null null null (lambda () (list desc ...))))) 479 480 (define-syntax racketgrammar 481 (syntax-rules () 482 [(_ #:literals (lit ...) id clause ...) 483 (racketgrammar* #:literals (lit ...) [id clause ...])] 484 [(_ id clause ...) (racketgrammar #:literals () id clause ...)])) 485 486 (define-syntax racketgrammar* 487 (syntax-rules () 488 [(_ #:literals (lit ...) [id clause ...] ...) 489 (with-racket-variables 490 (lit ...) 491 ([non-term (id clause ...)] ...) 492 (*racketgrammar '(lit ...) 493 '(id ... clause ... ...) 494 (lambda () 495 (list (list (racket id) 496 (racketblock0/form clause) ...) 497 ...))))] 498 [(_ [id clause ...] ...) 499 (racketgrammar* #:literals () [id clause ...] ...)])) 500 501 (define-syntax-rule (var id) 502 (*var 'id)) 503 504 (define-syntax-rule (svar id) 505 (*var 'id)) 506 507 508 (define (meta-symbol? s) (memq s '(... ...+ ?))) 509 510 (define (defform-site kw-id) 511 (let ([target-maker (id-to-form-target-maker kw-id #t)]) 512 (define-values (content ref-content) (definition-site (syntax-e kw-id) kw-id #t)) 513 (if target-maker 514 (target-maker 515 content 516 (lambda (tag) 517 (make-toc-target2-element 518 #f 519 (if kw-id 520 (make-index-element 521 #f content tag 522 (list (datum-intern-literal (symbol->string (syntax-e kw-id)))) 523 (list ref-content) 524 (with-exporting-libraries 525 (lambda (libs) 526 (make-form-index-desc (syntax-e kw-id) 527 libs)))) 528 content) 529 tag 530 ref-content))) 531 content))) 532 533 (define (*defforms kind link? kw-id forms form-procs subs sub-procs contract-procs content-thunk) 534 (parameterize ([current-meta-list '(... ...+)]) 535 (make-box-splice 536 (cons 537 (make-blockquote 538 vertical-inset-style 539 (list 540 (make-table 541 boxed-style 542 (append 543 (for/list ([form (in-list forms)] 544 [form-proc (in-list form-procs)] 545 [i (in-naturals)]) 546 (list 547 ((if (zero? i) (add-background-label (or kind "syntax")) values) 548 ;(list 549 ;(make-nested-flow (make-style #f '()) 550 (list 551 ((or form-proc 552 (lambda (x) 553 (make-omitable-paragraph 554 (list (to-element `(,x . ,(cdr form))))))) 555 (and kw-id 556 (if (eq? form (car forms)) 557 (if link? 558 (defform-site kw-id) 559 (to-element #:defn? #t kw-id)) 560 (to-element #:defn? #t kw-id)))))))) 561 (if (null? sub-procs) 562 null 563 (list (list flow-empty-line) 564 (list (make-flow 565 (list (let ([l (map (lambda (sub) 566 (map (lambda (f) (f)) sub)) 567 sub-procs)]) 568 (*racketrawgrammars "specgrammar" 569 (map car l) 570 (map cdr l)))))))) 571 (make-contracts-table contract-procs))))) 572 (content-thunk))))) 573 574 (define (*specsubform form lits form-thunk subs sub-procs contract-procs content-thunk) 575 (parameterize ([current-meta-list '(... ...+)]) 576 (make-blockquote 577 "leftindent" 578 (cons 579 (make-blockquote 580 vertical-inset-style 581 (list 582 (make-table 583 boxed-style 584 (cons 585 (list 586 (make-flow 587 (list 588 (if form-thunk 589 (form-thunk) 590 (make-omitable-paragraph (list (to-element form))))))) 591 (append 592 (if (null? sub-procs) 593 null 594 (list (list flow-empty-line) 595 (list (make-flow 596 (list (let ([l (map (lambda (sub) 597 (map (lambda (f) (f)) sub)) 598 sub-procs)]) 599 (*racketrawgrammars "specgrammar" 600 (map car l) 601 (map cdr l)))))))) 602 (make-contracts-table contract-procs)))))) 603 (flow-paragraphs (decode-flow (content-thunk))))))) 604 605 (define (*racketrawgrammars style nonterms clauseses) 606 (make-table 607 `((valignment baseline baseline baseline baseline baseline) 608 (alignment right left center left left) 609 (style ,style)) 610 (cdr 611 (append-map 612 (lambda (nonterm clauses) 613 (list* 614 (list flow-empty-line flow-empty-line flow-empty-line 615 flow-empty-line flow-empty-line) 616 (list (to-flow nonterm) flow-empty-line (to-flow "=") flow-empty-line 617 (make-flow (list (car clauses)))) 618 (map (lambda (clause) 619 (list flow-empty-line flow-empty-line 620 (to-flow "|") flow-empty-line 621 (make-flow (list clause)))) 622 (cdr clauses)))) 623 nonterms clauseses)))) 624 625 (define (*racketrawgrammar style nonterm clause1 . clauses) 626 (*racketrawgrammars style (list nonterm) (list (cons clause1 clauses)))) 627 628 (define (*racketgrammar lits s-expr clauseses-thunk) 629 (let ([l (clauseses-thunk)]) 630 (*racketrawgrammars #f 631 (map (lambda (x) 632 (make-element #f 633 (list (hspace 2) 634 (car x)))) 635 l) 636 (map cdr l)))) 637 638 (define (*var id) 639 (to-element (*var-sym id))) 640 641 (define (*var-sym id) 642 (string->symbol (format "_~a" id))) 643 644 (define (make-contracts-table contract-procs) 645 (if (null? contract-procs) 646 null 647 (append 648 (list (list flow-empty-line)) 649 (list (list (make-flow 650 (map (lambda (c) 651 (make-table 652 "argcontract" 653 (list 654 (list (to-flow (hspace 2)) 655 (to-flow ((car c))) 656 flow-spacer 657 (to-flow ":") 658 flow-spacer 659 (make-flow (list ((cadr c)))))))) 660 contract-procs)))))))