manual-proc.rkt (52874B)
1 #lang racket/base 2 (require "../struct.rkt" 3 "../scheme.rkt" 4 "../basic.rkt" 5 "../manual-struct.rkt" 6 (only-in "../core.rkt" 7 make-style 8 make-table-columns 9 content?) 10 "../html-properties.rkt" 11 "qsloc.rkt" 12 "manual-utils.rkt" 13 "manual-vars.rkt" 14 "manual-style.rkt" 15 "manual-scheme.rkt" 16 "manual-bind.rkt" 17 "manual-method.rkt" 18 "manual-ex.rkt" 19 "on-demand.rkt" 20 scheme/string 21 scheme/list 22 racket/contract 23 (for-syntax racket/base 24 syntax/parse) 25 (for-label racket/base 26 racket/contract 27 racket/class)) 28 29 (provide defproc defproc* defstruct defstruct* 30 defparam defparam* defboolparam 31 defthing defthing* 32 defthing/proc ; XXX unknown contract 33 ;; private: 34 *defthing) ; XXX unknown contract 35 36 (define-on-demand dots0 37 (make-element meta-color (list "..."))) 38 (define-on-demand dots1 39 (make-element meta-color (list "...+"))) 40 41 (define (make-openers n) 42 (racketparenfont 43 (case n [(1) "("] [(0) ""] [(2) "(("] [else (make-string n #\()]))) 44 (define (make-closers n) 45 (racketparenfont 46 (case n [(1) ")"] [(0) ""] [(2) "))"] [else (make-string n #\))]))) 47 48 (define-syntax (arg-contract stx) 49 (syntax-case stx (... ...+ _...superclass-args...) 50 [(_ [id contract]) 51 (identifier? #'id) 52 #'(racketblock0 contract)] 53 [(_ [id contract val]) 54 (identifier? #'id) 55 #'(racketblock0 contract)] 56 [(_ [kw id contract]) 57 (and (keyword? (syntax-e #'kw)) (identifier? #'id)) 58 #'(racketblock0 contract)] 59 [(_ [kw id contract val]) 60 (and (keyword? (syntax-e #'kw)) (identifier? #'id)) 61 #'(racketblock0 contract)] 62 [(_ (... ...)) #'#f] 63 [(_ (... ...+)) #'#f] 64 [(_ _...superclass-args...) #'#f] 65 [(_ arg) (raise-syntax-error 'defproc "bad argument form" #'arg)])) 66 67 (define-syntax (arg-default stx) 68 (syntax-case stx (... ...+ _...superclass-args...) 69 [(_ [id contract]) 70 (identifier? #'id) 71 #'#f] 72 [(_ [id contract val]) 73 (identifier? #'id) 74 #'(racketblock0 val)] 75 [(_ [kw id contract]) 76 (keyword? (syntax-e #'kw)) 77 #'#f] 78 [(_ [kw id contract val]) 79 (keyword? (syntax-e #'kw)) 80 #'(racketblock0 val)] 81 [_ #'#f])) 82 83 (define-syntax (extract-proc-id stx) 84 (syntax-case stx () 85 [(_ k e id) 86 (identifier? #'id) 87 (if (and (syntax-e #'k) 88 (free-identifier=? #'k #'id)) 89 #'e 90 #`(quote-syntax/loc id))] 91 [(_ k e (proto arg ...)) 92 #'(extract-proc-id k e proto)] 93 [(_ thing) (raise-syntax-error 'defproc "bad prototype" #'thing)])) 94 95 (define-syntax (arg-contracts stx) 96 (syntax-case stx () 97 [(_ id arg ...) 98 (identifier? #'id) 99 #'(list (lambda () (arg-contract arg)) ...)] 100 [(_ (proto arg1 ...) arg ...) 101 #'(arg-contracts proto arg1 ... arg ...)] 102 [_ (raise-syntax-error 'defproc "bad prototype" stx)])) 103 104 (define-syntax (arg-defaults stx) 105 (syntax-case stx () 106 [(_ id arg ...) 107 (identifier? #'id) 108 #'(list (lambda () (arg-default arg)) ...)] 109 [(_ (proto arg1 ...) arg ...) 110 #'(arg-defaults proto arg1 ... arg ...)] 111 [_ (raise-syntax-error 'defproc "bad prototype" stx)])) 112 113 (define-syntax (result-contract stx) 114 (syntax-case stx (values) 115 [(_ (values c ...)) 116 #'(list (racketblock0 c) ...)] 117 [(_ c) 118 (if (string? (syntax-e #'c)) 119 (raise-syntax-error 'defproc 120 "expected a result contract, found a string" #'c) 121 #'(racketblock0 c))])) 122 123 (define no-value #f) 124 125 (define-syntax (result-value stx) 126 (syntax-case stx (no-value let) 127 [(_ no-value) #'#f] 128 [(_ (let () e ...)) #'(racketblock0 e ...)] 129 [(_ v) #'(racketblock0 v)])) 130 131 (begin-for-syntax 132 (define-splicing-syntax-class kind-kw 133 #:attributes (kind) ;; Expr[String/#f] 134 #:description "#:kind keyword" 135 (pattern (~optional (~seq #:kind k)) 136 #:declare k (expr/c #'(or/c content? #f) #:name "#:kind argument") 137 #:with kind #'(~? k.c #f))) 138 139 (define-splicing-syntax-class value-kw 140 #:description "#:value keyword" 141 (pattern (~optional (~seq #:value value) 142 #:defaults ([value #'no-value])))) 143 144 (define-splicing-syntax-class link-target?-kw 145 #:description "#:link-target? keyword" 146 (pattern (~seq #:link-target? expr)) 147 (pattern (~seq) 148 #:with expr #'#t)) 149 150 (define-syntax-class id-or-false 151 (pattern i:id) 152 (pattern #f #:with i #'#f)) 153 154 (define-splicing-syntax-class id-kw 155 #:description "#:id keyword" 156 (pattern (~optional (~seq #:id [key:id-or-false expr]) 157 #:defaults ([key #'#f] 158 [expr #'#f])))) 159 160 (define-splicing-syntax-class mode-kw 161 #:description "#:mode keyword" 162 (pattern (~optional (~seq #:mode m:id) 163 #:defaults ([m #'procedure])))) 164 165 (define-splicing-syntax-class within-kw 166 #:description "#:within keyword" 167 (pattern (~optional (~seq #:within cl:id) 168 #:defaults ([cl #'#f])))) 169 ) 170 171 (define-syntax (defproc stx) 172 (syntax-parse stx 173 [(_ kind:kind-kw 174 lt:link-target?-kw 175 i:id-kw 176 (id arg ...) 177 result 178 value:value-kw 179 desc ...) 180 (syntax/loc stx 181 (defproc* 182 #:kind kind.kind 183 #:link-target? lt.expr 184 #:id [i.key i.expr] 185 [[(id arg ...) result #:value value.value]] 186 desc ...))])) 187 188 (define-syntax (defproc* stx) 189 (syntax-parse stx 190 [(_ kind:kind-kw 191 lt:link-target?-kw 192 d:id-kw 193 mode:mode-kw 194 within:within-kw 195 [[proto result value:value-kw] ...] 196 desc ...) 197 (syntax/loc stx 198 (with-togetherable-racket-variables 199 () 200 ([proc proto] ...) 201 (let ([alt-id d.expr]) 202 (*defproc kind.kind 203 lt.expr 204 'mode.m (quote-syntax/loc within.cl) 205 (list (extract-proc-id d.key alt-id proto) ...) 206 'd.key 207 '[proto ...] 208 (list (arg-contracts proto) ...) 209 (list (arg-defaults proto) ...) 210 (list (lambda () (result-contract result)) ...) 211 (lambda () (list desc ...)) 212 (list (result-value value.value) ...)))))])) 213 214 (define-struct arg 215 (special? kw id optional? starts-optional? ends-optional? depth)) 216 217 (define (*defproc kind link? mode within-id 218 stx-ids sym prototypes arg-contractss arg-valss result-contracts content-thunk 219 [result-values (map (lambda (x) #f) result-contracts)]) 220 (define max-proto-width (current-display-width)) 221 (define ((arg->elem show-opt-start?) arg next-depth) 222 (let* ([e (cond [(not (arg-special? arg)) 223 (if (arg-kw arg) 224 (if (eq? mode 'new) 225 (make-element 226 #f (list (racketparenfont "[") 227 (racketidfont (datum-intern-literal (keyword->string (arg-kw arg)))) 228 spacer 229 (to-element (make-var-id (arg-id arg))) 230 (racketparenfont "]"))) 231 (make-element 232 #f (list (to-element (arg-kw arg)) 233 spacer 234 (to-element (make-var-id (arg-id arg)))))) 235 (to-element (make-var-id (arg-id arg))))] 236 [(eq? (arg-id arg) '...+) dots1] 237 [(eq? (arg-id arg) '...) dots0] 238 [(eq? (arg-id arg) '_...superclass-args...) (to-element (arg-id arg))] 239 [else (to-element (make-var-id (arg-id arg)))])] 240 [e (if (arg-ends-optional? arg) 241 (make-element #f (list e (racketoptionalfont "]"))) 242 e)] 243 [num-closers (- (arg-depth arg) next-depth)] 244 [e (if (zero? num-closers) 245 e 246 (make-element 247 #f (list e (make-closers num-closers))))]) 248 (if (and show-opt-start? (arg-starts-optional? arg)) 249 (make-element #f (list (racketoptionalfont "[") e)) 250 e))) 251 (define (prototype-depth p) 252 (let loop ([p (car p)]) 253 (if (symbol? p) 0 (+ 1 (loop (car p)))))) 254 (define (prototype-args p) 255 (define (parse-arg v in-optional? depth next-optional? next-special-dots?) 256 (let* ([id (if (pair? v) ((if (keyword? (car v)) cadr car) v) v)] 257 [kw (and (pair? v) (keyword? (car v)) (car v))] 258 [default? (and (pair? v) (pair? ((if kw cdddr cddr) v)))]) 259 (make-arg (symbol? v) kw id default? 260 (and default? (not in-optional?)) 261 (or (and (not default?) 262 in-optional?) ; => must be special 263 (and default? 264 (not next-optional?) 265 (not next-special-dots?))) 266 depth))) 267 (let loop ([p p] [depth 0]) 268 (define head 269 (if (symbol? (car p)) 270 null 271 (loop (car p) (add1 depth)))) 272 (append 273 head 274 (let loop ([p (cdr p)] [in-optional? #f]) 275 (cond 276 [(null? p) null] 277 [(null? (cdr p)) 278 (list (parse-arg (car p) in-optional? depth #f #f))] 279 [else 280 (let ([a (parse-arg 281 (car p) 282 in-optional? 283 depth 284 (let ([v (cadr p)]) 285 (and (pair? v) 286 (not 287 (null? ((if (keyword? (car v)) cdddr cddr) v))))) 288 (and (not (pair? (cadr p))) 289 (not (eq? '_...superclass-args... (cadr p)))))]) 290 (cons a (loop (cdr p) 291 (and (arg-optional? a) 292 (not (arg-ends-optional? a))))))]))))) 293 (define (next-args-depth args) 294 (if (null? args) 295 0 296 (arg-depth (car args)))) 297 (define (prototype-size args first-combine next-combine special-combine?) 298 (let loop ([s args] [combine first-combine]) 299 (if (null? s) 300 0 301 (combine 302 (loop (cdr s) next-combine) 303 (let ([a (car s)]) 304 (+ (- (arg-depth a) (next-args-depth (cdr s))) 305 (if (arg-special? a) 306 (string-length (symbol->string (arg-id a))) 307 (+ (if (arg-kw a) 308 (+ (if (eq? mode 'new) 2 0) 309 (string-length (keyword->string (arg-kw a))) 310 3 311 (string-length (symbol->string (arg-id a)))) 312 (string-length (symbol->string (arg-id a)))) 313 (if (and special-combine? 314 (pair? (cdr s)) 315 (arg-special? (cadr s)) 316 (not (eq? '_...superclass-args... 317 (arg-id (cadr s))))) 318 (+ 1 (string-length (symbol->string (arg-id (cadr s))))) 319 0))))))))) 320 (define (extract-id p stx-id) 321 (let loop ([p p]) 322 (if (symbol? (car p)) 323 (let ([s (car p)]) 324 (if (eq? s sym) 325 (syntax-e stx-id) 326 (car p))) 327 (loop (car p))))) 328 (define (do-one stx-id prototype args arg-contracts arg-vals result-contract result-value 329 first? add-background-label?) 330 (let ([names (remq* '(... ...+) (map arg-id args))]) 331 (unless (= (length names) (length (remove-duplicates names eq?))) 332 (error 'defproc "duplicate argument names in prototype for ~s: ~s" 333 (syntax->datum stx-id) names))) 334 (define tagged 335 (cond 336 [(or (eq? mode 'new) 337 (eq? mode 'make)) 338 (define content 339 (list (if (eq? mode 'new) 340 (racket new) 341 (racket make-object)))) 342 (define new-elem 343 (if (and first? link?) 344 (let* ([target-maker (id-to-target-maker within-id #f)]) 345 (if target-maker 346 (target-maker 347 content 348 (lambda (ctag) 349 (let ([tag (constructor-tag ctag)]) 350 (make-toc-target-element 351 #f 352 (list (make-index-element 353 #f 354 content 355 tag 356 (list (datum-intern-literal (symbol->string (syntax-e within-id))) 357 (if (eq? mode 'new) 358 "new" 359 "make-object")) 360 content 361 (with-exporting-libraries 362 (lambda (libs) 363 (make-constructor-index-desc 364 (syntax-e within-id) 365 libs ctag))))) 366 tag)))) 367 (car content))) 368 (car content))) 369 (make-element #f (list new-elem spacer (to-element within-id)))] 370 [(eq? mode 'send) 371 (make-element 372 #f 373 (list (racket send) spacer 374 (name-this-object (syntax-e within-id)) spacer 375 (if (and first? link?) 376 (let* ([mname (extract-id prototype stx-id)] 377 [target-maker (id-to-target-maker within-id #f)] 378 [content (*method mname within-id #:defn? #t)] 379 [ref-content (*method mname within-id)]) 380 (if target-maker 381 (target-maker 382 content 383 (lambda (ctag) 384 (let ([tag (method-tag ctag mname)]) 385 (make-toc-target2-element 386 #f 387 (list (make-index-element 388 #f 389 content 390 tag 391 (list (datum-intern-literal (symbol->string mname))) 392 (list ref-content) 393 (with-exporting-libraries 394 (lambda (libs) 395 (make-method-index-desc 396 (syntax-e within-id) 397 libs mname ctag))))) 398 tag 399 ref-content)))) 400 content)) 401 (*method (extract-id prototype stx-id) within-id #:defn? #t))))] 402 [(and first? link?) 403 (define the-id (extract-id prototype stx-id)) 404 (let ([target-maker (id-to-target-maker stx-id #t)]) 405 (define-values (content ref-content) (definition-site the-id stx-id #f)) 406 (if target-maker 407 (target-maker 408 content 409 (lambda (tag) 410 (make-toc-target2-element 411 #f 412 (make-index-element 413 #f content tag 414 (list (datum-intern-literal (symbol->string the-id))) 415 (list ref-content) 416 (with-exporting-libraries 417 (lambda (libs) 418 (make-procedure-index-desc the-id libs)))) 419 tag 420 ref-content))) 421 content))] 422 [else 423 (define the-id (extract-id prototype stx-id)) 424 ((if link? annote-exporting-library values) 425 (let ([sig (current-signature)]) 426 (if sig 427 (*sig-elem #:defn? #t (sig-id sig) the-id) 428 (to-element #:defn? #t (make-just-context the-id stx-id)))))])) 429 (define p-depth (prototype-depth prototype)) 430 (define flat-size (+ (prototype-size args + + #f) 431 p-depth 432 (element-width tagged))) 433 (define short? (or (flat-size . < . 40) ((length args) . < . 2))) 434 (define res 435 (let ([res (result-contract)]) 436 (if (list? res) 437 ;; multiple results 438 (if (null? res) 439 'nbsp 440 (let ([w (apply + (map block-width res))]) 441 (if (or (ormap table? res) (w . > . 40)) 442 (make-table 443 #f (map (lambda (fe) (list (make-flow (list fe)))) res)) 444 (make-table 445 #f 446 (list (let loop ([res res]) 447 (if (null? (cdr res)) 448 (list (make-flow (list (car res)))) 449 (list* (make-flow (list (car res))) 450 flow-spacer 451 (loop (cdr res)))))))))) 452 res))) 453 (define tagged+arg-width (+ (prototype-size args max max #t) 454 p-depth 455 (element-width tagged))) 456 (define result-next-line? 457 ((+ (if short? flat-size tagged+arg-width) (block-width res)) 458 . >= . (- max-proto-width 7))) 459 (define end (list flow-spacer (to-flow 'rarr) 460 flow-spacer (make-flow (list res)))) 461 (define (get-label) 462 (case mode 463 [(new make) "constructor"] 464 [(send) "method"] 465 [else (or kind "procedure")])) 466 (append 467 (list 468 (list 469 ((if add-background-label? (add-background-label (get-label)) values) 470 (make-flow 471 (if short? 472 ;; The single-line case: 473 (top-align 474 make-table-if-necessary 475 "prototype" 476 (list 477 (cons 478 (to-flow 479 (make-element 480 #f 481 `(,(make-openers (add1 p-depth)) 482 ,tagged 483 ,(let ([num-closers (- p-depth (next-args-depth args))]) 484 (if (zero? num-closers) 485 '() 486 (make-closers num-closers))) 487 ,@(if (null? args) 488 (list (make-closers p-depth)) 489 (let loop ([args args]) 490 (cond 491 [(null? args) null] 492 [else 493 (append 494 (list spacer ((arg->elem #t) (car args) (next-args-depth (cdr args)))) 495 (loop (cdr args)))]))) 496 ,(racketparenfont ")")))) 497 (if result-next-line? null end)))) 498 ;; The multi-line case: 499 (let ([not-end (if result-next-line? 500 (list flow-spacer) 501 (list flow-spacer flow-spacer 502 flow-spacer flow-spacer))] 503 [one-ok? (and (not (eq? mode 'new)) (tagged+arg-width . < . (- max-proto-width 5)))]) 504 (list 505 (top-align 506 make-table 507 "prototype" 508 (cons 509 (cons 510 (to-flow 511 (make-element 512 #f 513 (list 514 (make-openers (add1 p-depth)) 515 tagged))) 516 (if one-ok? 517 (list* 518 (if (arg-starts-optional? (car args)) 519 (to-flow (make-element #f (list spacer (racketoptionalfont "[")))) 520 flow-spacer) 521 (to-flow ((arg->elem #f) (car args) (next-args-depth (cdr args)))) 522 not-end) 523 (list* 'cont 'cont not-end))) 524 (let loop ([args (if one-ok? (cdr args) args)]) 525 (if (null? args) 526 null 527 (let ([dots-next? 528 (or (and (pair? (cdr args)) 529 (arg-special? (cadr args)) 530 (not (eq? '_...superclass-args... 531 (arg-id (cadr args))))))]) 532 (cons 533 (list* 534 (if (eq? mode 'new) 535 (flow-spacer/n 3) 536 flow-spacer) 537 (if (arg-starts-optional? (car args)) 538 (to-flow (make-element #f (list spacer (racketoptionalfont "[")))) 539 flow-spacer) 540 (let ([a ((arg->elem #f) (car args) (next-args-depth (cdr args)))] 541 [next (if dots-next? 542 (make-element 543 #f (list spacer 544 ((arg->elem #f) 545 (cadr args) 546 (next-args-depth (cddr args))))) 547 "")]) 548 (to-flow 549 (cond 550 [(null? ((if dots-next? cddr cdr) args)) 551 (make-element 552 #f 553 (list a next (racketparenfont ")")))] 554 [(equal? next "") a] 555 [else 556 (make-element #f (list a next))]))) 557 (if (and (null? ((if dots-next? cddr cdr) args)) 558 (not result-next-line?)) 559 end 560 not-end)) 561 (loop ((if dots-next? cddr cdr) 562 args))))))))))))))) 563 (if result-next-line? 564 (list (list (make-flow (top-align 565 make-table-if-necessary 566 "prototype" 567 (list end))))) 568 null) 569 (append-map 570 (lambda (arg arg-contract arg-val) 571 (cond 572 [(not (arg-special? arg)) 573 (let* ([arg-cont (arg-contract)] 574 [base-len (+ 5 (string-length (symbol->string (arg-id arg))) 575 (block-width arg-cont))] 576 [arg-val (and arg-val (arg-val))] 577 [def-len (if (arg-optional? arg) (block-width arg-val) 0)] 578 [base-list 579 (list (to-flow (hspace 2)) 580 (to-flow (to-element (make-var-id (arg-id arg)))) 581 flow-spacer 582 (to-flow ":") 583 flow-spacer 584 (make-flow (list arg-cont)))]) 585 (list 586 (list 587 (make-flow 588 (if (and (arg-optional? arg) 589 ((+ base-len 3 def-len) . >= . max-proto-width)) 590 (list 591 (top-align 592 make-table 593 "argcontract" 594 (list base-list (list flow-spacer flow-spacer flow-spacer 595 (to-flow "=") flow-spacer 596 (make-flow (list arg-val)))))) 597 (let ([show-default? 598 (and (arg-optional? arg) 599 ((+ base-len 3 def-len) . < . max-proto-width))]) 600 (top-align 601 make-table-if-necessary 602 "argcontract" 603 (list 604 (append 605 base-list 606 (if show-default? 607 (list flow-spacer (to-flow "=") flow-spacer 608 (make-flow (list arg-val))) 609 null))))))))))] 610 [else null])) 611 args 612 arg-contracts 613 arg-vals) 614 (if result-value 615 (let ([result-block (if (block? result-value) 616 result-value 617 (make-omitable-paragraph (list result-value)))]) 618 (list (list (list (top-align 619 make-table 620 "argcontract" 621 (list (list 622 (to-flow (make-element #f (list spacer "=" spacer))) 623 (make-flow (list result-block))))))))) 624 null))) 625 (define all-args (map prototype-args prototypes)) 626 (define var-list 627 (filter-map (lambda (a) (and (not (arg-special? a)) (arg-id a))) 628 (append* all-args))) 629 (make-box-splice 630 (cons 631 (make-blockquote 632 vertical-inset-style 633 (list 634 (make-table 635 boxed-style 636 (append-map 637 do-one 638 stx-ids prototypes all-args arg-contractss arg-valss result-contracts result-values 639 (let loop ([ps prototypes] [stx-ids stx-ids] [accum null]) 640 (cond [(null? ps) null] 641 [(ormap (lambda (a) (eq? (extract-id (car ps) (car stx-ids)) a)) accum) 642 (cons #f (loop (cdr ps) (cdr stx-ids) accum))] 643 [else (cons #t (loop (cdr ps) 644 (cdr stx-ids) 645 (cons (extract-id (car ps) (car stx-ids)) accum)))])) 646 (for/list ([p (in-list prototypes)] 647 [i (in-naturals)]) 648 (= i 0)))))) 649 (content-thunk)))) 650 651 (define-syntax (defparam stx) 652 (syntax-parse stx 653 [(_ lt:link-target?-kw id arg contract value:value-kw desc ...) 654 #'(defproc* #:kind "parameter" #:link-target? lt.expr 655 ([(id) contract] [(id [arg contract]) void? #:value value.value]) 656 desc ...)])) 657 (define-syntax (defparam* stx) 658 (syntax-parse stx 659 [(_ lt:link-target?-kw id arg in-contract out-contract value:value-kw desc ...) 660 #'(defproc* #:kind "parameter" #:link-target? lt.expr 661 ([(id) out-contract] [(id [arg in-contract]) void? #:value value.value]) 662 desc ...)])) 663 (define-syntax (defboolparam stx) 664 (syntax-parse stx 665 [(_ lt:link-target?-kw id arg value:value-kw desc ...) 666 #'(defproc* #:kind "parameter" #:link-target? lt.expr 667 ([(id) boolean?] [(id [arg any/c]) void? #:value value.value]) 668 desc ...)])) 669 670 (define top-align-styles (make-hash)) 671 (define (top-align make-table style-name cols) 672 (if (null? cols) 673 (make-table style-name null) 674 (let* ([n (length (car cols))] 675 [k (cons style-name n)]) 676 (make-table 677 (hash-ref top-align-styles 678 k 679 (lambda () 680 (define s 681 (make-style style-name 682 (list (make-table-columns (for/list ([i n]) 683 (make-style #f '(top))))))) 684 (hash-set! top-align-styles k s) 685 s)) 686 cols)))) 687 688 ;; ---------------------------------------- 689 690 (begin-for-syntax 691 (define-splicing-syntax-class mutable-kw 692 #:description "#:mutable keyword" 693 (pattern (~seq #:mutable) 694 #:with immutable? #'#f) 695 (pattern (~seq) 696 #:with immutable? #'#t)) 697 698 (define-splicing-syntax-class opacity-kw 699 #:description "#:prefab, #:transparent, or #:inspector keyword" 700 (pattern (~seq #:prefab) 701 #:with opacity #''prefab) 702 (pattern (~seq #:transparent) 703 #:with opacity #''transparent) 704 (pattern (~seq #:inspector #f) 705 #:with opacity #''transparent) 706 (pattern (~seq) 707 #:with opacity #''opaque)) 708 709 (define-splicing-syntax-class constructor-kw 710 #:description "#:constructor-name, #:extra-constructor-name, or #:omit-constructor keyword" 711 (pattern (~seq #:constructor-name id) 712 #:with omit? #'#f 713 #:with given? #'#t 714 #:with extra? #'#f) 715 (pattern (~seq #:extra-constructor-name id) 716 #:with omit? #'#f 717 #:with given? #'#t 718 #:with extra? #'#t) 719 (pattern (~seq #:omit-constructor) 720 #:with omit? #'#t 721 #:with id #'#f 722 #:with given? #'#f 723 #:with extra? #'#f) 724 (pattern (~seq) 725 #:with omit? #'#f 726 #:with id #'#f 727 #:with given? #'#f 728 #:with extra? #'#f))) 729 730 (define-syntax-rule (define-defstruct defstruct default-extra?) 731 (... 732 (define-syntax (defstruct stx) 733 (syntax-parse stx 734 [(_ lt:link-target?-kw name fields 735 m:mutable-kw o:opacity-kw c:constructor-kw 736 desc ...) 737 #`(**defstruct lt.expr name fields 738 m.immutable? o.opacity 739 c.id c.given? c.extra? default-extra? c.omit? 740 desc ...)])))) 741 742 (define-defstruct defstruct #t) 743 (define-defstruct defstruct* #f) 744 745 (define-syntax-rule (**defstruct link? name ([field field-contract] ...) 746 immutable? opacity 747 cname cname-given? extra-cname? default-extra? omit-constructor? 748 desc ...) 749 (with-togetherable-racket-variables 750 () 751 () 752 (*defstruct link? (quote-syntax/loc name) 'name 753 (quote-syntax/loc cname) cname-given? extra-cname? default-extra? omit-constructor? 754 '([field field-contract] ...) 755 (list (lambda () (racketblock0 field-contract)) ...) 756 immutable? opacity 757 (lambda () (list desc ...))))) 758 759 (define (*defstruct link? stx-id name 760 alt-cname-id cname-given? extra-cname? default-extra? omit-constructor? 761 fields field-contracts 762 immutable? opacity 763 content-thunk) 764 (define transparent? (or (eq? opacity 'transparent) 765 (eq? opacity 'prefab))) 766 (define prefab? (eq? opacity 'prefab)) 767 (define max-proto-width (current-display-width)) 768 (define (field-name f) ((if (pair? (car f)) caar car) f)) 769 (define (field-view f) 770 (if (pair? (car f)) (make-shaped-parens (car f) #\[) (car f))) 771 (define cname-id 772 (cond 773 [omit-constructor? #f] 774 [(identifier? alt-cname-id) alt-cname-id] 775 [(not default-extra?) #f] 776 [else (let ([name-id (if (identifier? stx-id) 777 stx-id 778 (car (syntax-e stx-id)))]) 779 (datum->syntax name-id 780 (string->symbol (format "make-~a" (syntax-e name-id))) 781 name-id 782 name-id))])) 783 (define keyword-modifiers? (or (not immutable?) 784 transparent? 785 cname-id)) 786 (define keyword-spacer (hspace 4)) ; 2 would match DrRacket indentation, but 4 looks better with field contracts after 787 (define main-table 788 (make-table 789 boxed-style 790 (append 791 ;; First line in "boxed" table is struct name and fields: 792 (list 793 (list 794 ((add-background-label "struct") 795 (list 796 (let* ([the-name 797 (let ([just-name 798 (let ([name-id (if (pair? name) 799 (make-just-context (car name) 800 (car (syntax-e stx-id))) 801 stx-id)]) 802 (if link? 803 (let () 804 (define (gen defn?) 805 ((if defn? annote-exporting-library values) 806 (to-element #:defn? defn? name-id))) 807 (define content (gen #t)) 808 (define ref-content (gen #f)) 809 (make-target-element* 810 (lambda (s c t) 811 (make-toc-target2-element s c t ref-content)) 812 (if (pair? name) 813 (car (syntax-e stx-id)) 814 stx-id) 815 content 816 (let ([name (if (pair? name) (car name) name)]) 817 (list* (list 'info name) 818 (list 'type 'struct: name) 819 (list 'predicate name '?) 820 (append 821 (if cname-id 822 (list (list 'constructor (syntax-e cname-id))) 823 null) 824 (map (lambda (f) 825 (list 'accessor name '- 826 (field-name f))) 827 fields) 828 (filter-map 829 (lambda (f) 830 (if (or (not immutable?) 831 (and (pair? (car f)) 832 (memq '#:mutable 833 (car f)))) 834 (list 'mutator 'set- name '- 835 (field-name f) '!) 836 #f)) 837 fields)))))) 838 (to-element #:defn? #t name-id)))]) 839 (if (pair? name) 840 (make-element 841 #f 842 (list just-name 843 (hspace 1) 844 (to-element 845 (make-just-context 846 (cadr name) 847 (cadr (syntax-e stx-id)))))) 848 just-name))] 849 [sym-length (lambda (s) 850 (string-length (symbol->string s)))] 851 [short-width 852 (apply + 853 (length fields) ; spaces between field names 854 8 ; "struct" + "(" + ")" 855 (append 856 (map sym-length 857 (append (if (pair? name) name (list name)) 858 (map field-name fields))) 859 (map (lambda (f) 860 (if (pair? (car f)) 861 (+ 3 2 (string-length (keyword->string 862 (cadar f)))) 863 0)) 864 fields)))]) 865 (if (and (short-width . < . max-proto-width) 866 (not keyword-modifiers?)) 867 ;; All on one line: 868 (make-omitable-paragraph 869 (list 870 (to-element 871 `(,(racket struct) 872 ,the-name 873 ,(map field-view fields))))) 874 ;; Multi-line view (leaving out last paren if keywords follow): 875 (let* ([one-right-column? 876 ;; Does the struct name and fields fit on a single line? 877 (or (null? fields) 878 (short-width . < . max-proto-width))] 879 [split-field-line? 880 ;; start fields on the line after "struct"? 881 (and (pair? fields) 882 (max-proto-width . < . (+ 8 883 (if (pair? name) 884 (+ (sym-length (car name)) 885 1 886 (sym-length (cadr name))) 887 (sym-length name)) 888 1 889 (sym-length (field-name (car fields))) 890 1)))]) 891 (make-table 892 #f 893 ;; First four columns: "(struct" <space> <name><space> ( 894 ;; If all fields on the first line, extra columns follow; 895 ;; If only first field on same line, filds are in fourth column 896 ;; If no field is on the first line, no fourth column after all 897 ;; and fields are in the second column 898 (append 899 (list 900 (append 901 (list (to-flow (make-element #f 902 (list 903 (racketparenfont "(") 904 (racket struct)))) 905 flow-spacer) 906 (if one-right-column? 907 ;; struct name and fields on one line: 908 (list (to-flow (list the-name 909 spacer 910 (to-element (map field-view 911 fields)) 912 (if (and immutable? 913 (not transparent?) 914 (not cname-id)) 915 (racketparenfont ")") 916 null)))) 917 (if split-field-line? 918 ;; Field start on line after "struct": 919 (list (to-flow (make-element 'no-break the-name))) 920 ;; First field on the same line as "struct": 921 (list (to-flow (make-element 'no-break the-name)) 922 (to-flow (make-element 923 #f (list spacer (racketparenfont "(")))) 924 (to-flow (make-element 'no-break 925 (let ([f (to-element (field-view (car fields)))]) 926 (if (null? (cdr fields)) 927 (list f (racketparenfont ")")) 928 f))))))))) 929 (if split-field-line? 930 ;; First field, which starts on the next line: 931 (list 932 (list flow-spacer flow-spacer 933 (to-flow (list 934 (racketparenfont "(") 935 (make-element 'no-break 936 (let ([f (to-element (field-view (car fields)))]) 937 (if (null? (cdr fields)) 938 (list f (racketparenfont ")")) 939 f))))))) 940 null) 941 ;; Remaining fields: 942 (if one-right-column? 943 null 944 (let loop ([fields (if (null? fields) 945 fields 946 (cdr fields))]) 947 (if (null? fields) 948 null 949 (cons 950 (let ([fld (car fields)]) 951 (append 952 (list flow-spacer flow-spacer) 953 (if split-field-line? null (list flow-spacer flow-spacer)) 954 (list (to-flow 955 (list 956 (if split-field-line? spacer null) 957 (let ([e (to-element (field-view fld))]) 958 (if (null? (cdr fields)) 959 (list e 960 (racketparenfont 961 (if (and immutable? 962 (not transparent?) 963 (not cname-id)) 964 "))" 965 ")"))) 966 e))))))) 967 (loop (cdr fields))))))))))))))) 968 ;; Next lines at "boxed" level are construct-name keywords: 969 (if cname-id 970 (let ([kw (to-element (if (if cname-given? 971 extra-cname? 972 default-extra?) 973 '#:extra-constructor-name 974 '#:constructor-name))] 975 [nm (to-element cname-id)] 976 [close? (and immutable? 977 (not transparent?))]) 978 (if (max-proto-width . < . (+ (element-width keyword-spacer) 979 1 ; space between kw & name 980 (element-width kw) 981 (element-width nm) 982 (if close? 1 0))) 983 ;; use two lines for #:constructor-name 984 (list (list (to-flow (list keyword-spacer kw))) 985 (list (to-flow 986 (list 987 keyword-spacer 988 (if close? 989 (make-element #f (list nm (racketparenfont ")"))) 990 nm))))) 991 ;; use one line for #:constructor-name 992 (list (list 993 (to-flow (make-element 994 #f 995 (list 996 keyword-spacer 997 kw (hspace 1) nm 998 (if close? 999 (racketparenfont ")") 1000 null)))))))) 1001 null) 1002 ;; Next lines at "boxed" level are prefab/transparent/mutable 1003 (cond 1004 [(and (not immutable?) transparent?) 1005 (list 1006 (list (to-flow (list keyword-spacer (to-element '#:mutable)))) 1007 (list (to-flow (list keyword-spacer 1008 (if prefab? 1009 (to-element '#:prefab) 1010 (to-element '#:transparent)) 1011 (racketparenfont ")")))))] 1012 [(not immutable?) 1013 (list 1014 (list (to-flow (list keyword-spacer 1015 (to-element '#:mutable) 1016 (racketparenfont ")")))))] 1017 [transparent? 1018 (list 1019 (list (to-flow (list keyword-spacer 1020 (if prefab? 1021 (to-element '#:prefab) 1022 (to-element '#:transparent)) 1023 (racketparenfont ")")))))] 1024 [else null]) 1025 ;; Remaining lines at "boxed" level are field contracts: 1026 (map (lambda (v field-contract) 1027 (cond 1028 [(pair? v) 1029 (list 1030 (top-align 1031 make-table-if-necessary 1032 "argcontract" 1033 (list (list (to-flow (hspace 2)) 1034 (to-flow (to-element (field-name v))) 1035 flow-spacer 1036 (to-flow ":") 1037 flow-spacer 1038 (make-flow (list (field-contract)))))))] 1039 [else null])) 1040 fields field-contracts)))) 1041 (make-box-splice 1042 (cons 1043 (make-blockquote 1044 vertical-inset-style 1045 (list main-table)) 1046 (content-thunk)))) 1047 1048 ;; ---------------------------------------- 1049 1050 (define-syntax (defthing stx) 1051 (syntax-parse stx 1052 [(_ kind:kind-kw 1053 lt:link-target?-kw 1054 (~optional (~seq #:id id-expr) 1055 #:defaults ([id-expr #'#f])) 1056 id 1057 result 1058 value:value-kw 1059 desc ...) 1060 #'(with-togetherable-racket-variables 1061 () 1062 () 1063 (let ([id-val id-expr]) 1064 (*defthing kind.kind 1065 lt.expr 1066 (list (or id-val (quote-syntax/loc id))) (list (if (identifier? id-val) (syntax-e id-val) 'id)) #f 1067 (list (racketblock0 result)) 1068 (lambda () (list desc ...)) 1069 (list (result-value value.value)))))])) 1070 1071 (define-syntax (defthing* stx) 1072 (syntax-parse stx 1073 [(_ kind:kind-kw lt:link-target?-kw ([id result value:value-kw] ...) desc ...) 1074 #'(with-togetherable-racket-variables 1075 () 1076 () 1077 (*defthing kind.kind 1078 lt.expr 1079 (list (quote-syntax/loc id) ...) (list 'id ...) #f 1080 (list (racketblock0 result) ...) 1081 (lambda () (list desc ...)) 1082 (list (result-value value.value) ...)))])) 1083 1084 (define (*defthing kind link? stx-ids names form? result-contracts content-thunk 1085 [result-values (map (lambda (x) #f) result-contracts)]) 1086 (define max-proto-width (current-display-width)) 1087 (make-box-splice 1088 (cons 1089 (make-blockquote 1090 vertical-inset-style 1091 (list 1092 (make-table 1093 boxed-style 1094 (append* 1095 (for/list ([stx-id (in-list stx-ids)] 1096 [name (in-list names)] 1097 [result-contract (in-list result-contracts)] 1098 [result-value (in-list result-values)] 1099 [i (in-naturals)]) 1100 (let* ([result-block 1101 (and result-value 1102 (if (block? result-value) 1103 result-value 1104 (make-omitable-paragraph (list result-value))))] 1105 [contract-block 1106 (if (block? result-contract) 1107 result-contract 1108 (make-omitable-paragraph (list result-contract)))] 1109 [name+contract-width (+ (string-length (format "~a" name)) 1110 3 1111 (block-width contract-block))] 1112 [total-width (+ name+contract-width 1113 (if result-block 1114 (+ (block-width result-block) 3) 1115 0))] 1116 [thing-id (let ([target-maker 1117 (and link? 1118 ((if form? id-to-form-target-maker id-to-target-maker) 1119 stx-id #t))]) 1120 (define-values (content ref-content) 1121 (if link? 1122 (definition-site name stx-id form?) 1123 (let ([s (make-just-context name stx-id)]) 1124 (values (to-element #:defn? #t s) 1125 (to-element s))))) 1126 (if target-maker 1127 (target-maker 1128 content 1129 (lambda (tag) 1130 (make-toc-target2-element 1131 #f 1132 (make-index-element 1133 #f 1134 content 1135 tag 1136 (list (datum-intern-literal (symbol->string name))) 1137 (list ref-content) 1138 (with-exporting-libraries 1139 (lambda (libs) (make-thing-index-desc name libs)))) 1140 tag 1141 ref-content))) 1142 content))] 1143 [contract-on-first-line? (name+contract-width . < . max-proto-width)] 1144 [single-line? (and contract-on-first-line? 1145 (total-width . < . max-proto-width) 1146 (not (table? result-value)))]) 1147 (append 1148 (list 1149 (list 1150 ((if (zero? i) (add-background-label (or kind "value")) values) 1151 (top-align 1152 make-table-if-necessary 1153 "argcontract" 1154 (append 1155 (list 1156 (append 1157 (list (list (make-omitable-paragraph 1158 (list thing-id)))) 1159 (if contract-on-first-line? 1160 (list 1161 (to-flow (list spacer ":" spacer)) 1162 (list contract-block)) 1163 null) 1164 (if (and result-block single-line?) 1165 (list 1166 (to-flow (list spacer "=" spacer)) 1167 (list result-block)) 1168 null)))))))) 1169 (if contract-on-first-line? 1170 null 1171 (list (list (top-align 1172 make-table-if-necessary 1173 "argcontract" 1174 (list 1175 (list (to-flow (list spacer ":" spacer)) 1176 (list contract-block))))))) 1177 (if (or single-line? (not result-block)) 1178 null 1179 (list (list (top-align 1180 make-table-if-necessary 1181 "argcontract" 1182 (list (list 1183 (to-flow (list spacer "=" spacer)) 1184 (list result-block)))))))))))))) 1185 (content-thunk)))) 1186 1187 (define (defthing/proc kind id contract descs) 1188 (*defthing kind #t (list id) (list (syntax-e id)) #f (list contract) 1189 (lambda () descs))) 1190 1191 (define (make-target-element* inner-make-target-element stx-id content wrappers) 1192 (if (null? wrappers) 1193 content 1194 (make-target-element* 1195 make-target-element 1196 stx-id 1197 (let* ([name (datum-intern-literal (string-append* (map symbol->string (cdar wrappers))))] 1198 [target-maker 1199 (id-to-target-maker (datum->syntax stx-id (string->symbol name)) 1200 #t)]) 1201 (if target-maker 1202 (target-maker 1203 content 1204 (lambda (tag) 1205 (inner-make-target-element 1206 #f 1207 (make-index-element 1208 #f 1209 content 1210 tag 1211 (list name) 1212 (list (racketidfont (make-element value-link-color 1213 (list name)))) 1214 (with-exporting-libraries 1215 (lambda (libs) 1216 (let ([name (string->symbol name)]) 1217 (if (eq? 'info (caar wrappers)) 1218 (make-struct-index-desc name libs) 1219 (make-procedure-index-desc name libs)))))) 1220 tag))) 1221 content)) 1222 (cdr wrappers)))) 1223