manual-class.rkt (21986B)
1 #lang scheme/base 2 (require "../decode.rkt" 3 "../struct.rkt" 4 "../scheme.rkt" 5 "../search.rkt" 6 "../basic.rkt" 7 "../manual-struct.rkt" 8 "qsloc.rkt" 9 scheme/serialize 10 scheme/stxparam 11 "manual-utils.rkt" 12 "manual-style.rkt" 13 "manual-scheme.rkt" 14 "manual-bind.rkt" 15 "manual-method.rkt" 16 "manual-proc.rkt" 17 "manual-vars.rkt" 18 "manual-class-struct.rkt" 19 scheme/list 20 (for-syntax scheme/base) 21 (for-label scheme/base 22 scheme/class)) 23 24 (provide defclass 25 defclass/title 26 definterface 27 definterface/title 28 defmixin 29 defmixin/title 30 defconstructor 31 defconstructor/make 32 defconstructor*/make 33 defconstructor/auto-super 34 defmethod 35 defmethod* 36 methspec 37 methimpl 38 this-obj 39 method xmethod (rename-out [method ::])) 40 41 (define-syntax-parameter current-class #f) 42 43 (define-struct decl (name super app-mixins intfs ranges mk-head body)) 44 (define-struct constructor (def)) 45 (define-struct meth (names mode def)) 46 (define-struct spec (def)) 47 (define-struct impl (def)) 48 49 (define (id-info id) 50 (let ([b (identifier-label-binding id)]) 51 (if b 52 (list (caddr b) 53 (list-ref b 3) 54 (list-ref b 4) 55 (list-ref b 5) 56 (list-ref b 6)) 57 (error 'scribble "no class/interface/mixin information for identifier: ~e" 58 id)))) 59 60 (define (make-inherited-table r d ri decl) 61 (define start 62 (let ([key (find-scheme-tag d ri (decl-name decl) #f)]) 63 (if key (list (cons key (lookup-cls/intf d ri key))) null))) 64 (define supers 65 (if (null? start) 66 null 67 (cdr 68 (let loop ([supers start][accum null]) 69 (cond 70 [(null? supers) (reverse accum)] 71 [(assoc (caar supers) accum) 72 (loop (cdr supers) accum)] 73 [else 74 (let ([super (car supers)]) 75 (loop (append (filter-map 76 (lambda (i) 77 (let ([key (find-scheme-tag d ri i #f)]) 78 (and key 79 (cons key (lookup-cls/intf d ri key))))) 80 (append 81 (reverse (cls/intf-intfs (cdr super))) 82 (if (cls/intf-super (cdr super)) 83 (list (cls/intf-super (cdr super))) 84 null) 85 (reverse (cls/intf-app-mixins (cdr super))))) 86 (cdr supers)) 87 (cons super accum)))]))))) 88 (define ht 89 (let ([ht (make-hasheq)]) 90 (for* ([i (decl-body decl)] 91 #:when (meth? i) 92 [name (meth-names i)]) 93 (hash-set! ht name #t)) 94 ht)) 95 (define inh 96 (append-map 97 (lambda (super) 98 (let ([inh (filter-map 99 (lambda (k) 100 (if (hash-ref ht k #f) 101 #f 102 (begin (hash-set! ht k #t) 103 (cons (datum-intern-literal (symbol->string k)) 104 (**method k (car super)))))) 105 (cls/intf-methods (cdr super)))]) 106 (if (null? inh) 107 null 108 (cons (make-element #f (list (make-element "inheritedlbl" '("from ")) 109 (cls/intf-name-element (cdr super)))) 110 (map cdr (sort inh string<? #:key car)))))) 111 supers)) 112 (if (null? inh) 113 (make-auxiliary-table "inherited" null) 114 (make-auxiliary-table 115 "inherited" 116 (map (lambda (i) (list (to-flow i))) 117 (cons (make-element "inheritedlbl" '("Inherited methods:")) inh))))) 118 119 (define (make-decl-collect decl link?) 120 (if link? 121 (make-part-collect-decl 122 ((id-to-target-maker (decl-name decl) #f) 123 (list "ignored") 124 (lambda (tag) 125 (make-collect-element 126 #f null 127 (lambda (ci) 128 (collect-put! 129 ci 130 `(cls/intf ,(cadr tag)) 131 (make-cls/intf 132 (make-element 133 symbol-color 134 (list (make-link-element 135 value-link-color 136 (list (datum-intern-literal 137 (symbol->string (syntax-e (decl-name decl))))) 138 tag))) 139 (map id-info (decl-app-mixins decl)) 140 (and (decl-super decl) 141 (not (free-label-identifier=? (quote-syntax object%) 142 (decl-super decl))) 143 (id-info (decl-super decl))) 144 (map id-info (decl-intfs decl)) 145 (append-map (lambda (m) 146 (let loop ([l (meth-names m)]) 147 (cond [(null? l) null] 148 [(memq (car l) (cdr l)) (loop (cdr l))] 149 [else (cons (car l) (loop (cdr l)))]))) 150 (filter meth? (decl-body decl)))))))))) 151 null)) 152 153 (define (build-body decl body) 154 `(,@(map (lambda (i) 155 (cond [(constructor? i) ((constructor-def i))] 156 [(meth? i) ((meth-def i))] 157 [else i])) 158 body) 159 ,(make-delayed-block (lambda (r d ri) (make-inherited-table r d ri decl))))) 160 161 (define (*include-class/title decl link?) 162 (make-splice 163 (list* (title #:style 'hidden (to-element (decl-name decl))) 164 (make-decl-collect decl link?) 165 (build-body decl (append ((decl-mk-head decl) #t) 166 (decl-body decl)))))) 167 168 (define (*include-class decl link?) 169 (make-splice 170 (cons 171 (make-decl-collect decl link?) 172 (append 173 ((decl-mk-head decl) #f) 174 (let-values ([(pre post) 175 (let loop ([l (decl-body decl)][accum null]) 176 (cond 177 [(null? l) (values (reverse accum) null)] 178 [(or (constructor? (car l)) (meth? (car l))) 179 (values (reverse accum) l)] 180 [else (loop (cdr l) (cons (car l) accum))]))]) 181 (append 182 (flow-paragraphs (decode-flow pre)) 183 (list 184 (make-blockquote 185 "leftindent" 186 (flow-paragraphs 187 (decode-flow (build-body decl post))))))))))) 188 189 (define (*class-doc kind stx-id super intfs ranges whole-page? make-index-desc link?) 190 (make-table 191 boxed-style 192 (append 193 (list 194 (list 195 ((add-background-label (symbol->string kind)) 196 (make-flow 197 (list 198 (make-omitable-paragraph 199 (list (if link? 200 (let ([target-maker (id-to-target-maker stx-id #t)] 201 [content (annote-exporting-library 202 (to-element #:defn? #t stx-id))] 203 [ref-content (to-element stx-id)]) 204 (if target-maker 205 (target-maker 206 content 207 (lambda (tag) 208 ((if whole-page? 209 make-page-target-element 210 (lambda (s c t) 211 (make-toc-target2-element s c t ref-content))) 212 #f 213 (list 214 (make-index-element 215 #f content tag 216 (list (datum-intern-literal 217 (symbol->string (syntax-e stx-id)))) 218 (list ref-content) 219 (with-exporting-libraries 220 (lambda (libs) 221 (make-index-desc (syntax-e stx-id) libs))))) 222 tag))) 223 content)) 224 (to-element stx-id)) 225 spacer ":" spacer 226 (case kind 227 [(class) (racket class?)] 228 [(interface) (racket interface?)] 229 [(mixin) (racketblockelem (class? . -> . class?))])))))))) 230 (if super 231 (list 232 (list (make-flow 233 (list (t (hspace 2) "superclass:" spacer (to-element super)))))) 234 null) 235 (let ([show-intfs 236 (lambda (intfs range?) 237 (if (null? intfs) 238 null 239 (list 240 (list 241 (make-flow 242 (list 243 (make-table 244 #f 245 (cons 246 (list (make-flow 247 (list (make-omitable-paragraph 248 (list (hspace 2) 249 (case kind 250 [(interface) "implements:"] 251 [(class) "extends:"] 252 [(mixin) 253 (if range? 254 "result implements:" 255 "argument extends/implements:")]) 256 spacer)))) 257 (to-flow (to-element (car intfs)))) 258 (map (lambda (i) 259 (list flow-spacer (to-flow (to-element i)))) 260 (cdr intfs))))))))))]) 261 (append (show-intfs intfs #f) (show-intfs ranges #t)))))) 262 263 (define-syntax extract-super 264 (syntax-rules () 265 [(_ (mixin base)) (extract-super base)] 266 [(_ super) (quote-syntax/loc super)])) 267 268 (define-syntax extract-app-mixins 269 (syntax-rules () 270 [(_ (mixin base)) (cons (quote-syntax/loc mixin) (extract-app-mixins base))] 271 [(_ super) null])) 272 273 (define (flatten-splices l) 274 (let loop ([l l]) 275 (cond [(null? l) null] 276 [(splice? (car l)) (append (splice-run (car l)) (loop (cdr l)))] 277 [else (cons (car l) (loop (cdr l)))]))) 278 279 (define-syntax-rule (*defclass *include-class link-target? name super (intf ...) body ...) 280 (let ([link? link-target?]) 281 (*include-class 282 (syntax-parameterize ([current-class (quote-syntax name)]) 283 (make-decl (quote-syntax/loc name) 284 (extract-super super) 285 (extract-app-mixins super) 286 (list (quote-syntax/loc intf) ...) 287 null 288 (lambda (whole-page?) 289 (list (*class-doc 'class 290 (quote-syntax/loc name) 291 (quote-syntax/loc super) 292 (list (quote-syntax intf) ...) 293 null 294 whole-page? 295 make-class-index-desc 296 link?))) 297 (flatten-splices (list body ...)))) 298 link?))) 299 300 (define-syntax defclass 301 (syntax-rules () 302 [(_ #:link-target? link-target? name super (intf ...) body ...) 303 (*defclass *include-class link-target? name super (intf ...) body ...)] 304 [(_ name super (intf ...) body ...) 305 (defclass #:link-target? #t name super (intf ...) body ...)])) 306 307 (define-syntax defclass/title 308 (syntax-rules () 309 [(_ #:link-target? link-target? name super (intf ...) body ...) 310 (*defclass *include-class/title link-target? name super (intf ...) body ...)] 311 [(_ name super (intf ...) body ...) 312 (defclass/title #:link-target? #t name super (intf ...) body ...)])) 313 314 (define-syntax-rule (*definterface *include-class name (intf ...) body ...) 315 (let ([link? #t]) 316 (*include-class 317 (syntax-parameterize ([current-class (quote-syntax name)]) 318 (make-decl (quote-syntax/loc name) 319 #f 320 null 321 (list (quote-syntax/loc intf) ...) 322 null 323 (lambda (whole-page?) 324 (list 325 (*class-doc 'interface 326 (quote-syntax/loc name) 327 #f 328 (list (quote-syntax intf) ...) 329 null 330 whole-page? 331 make-interface-index-desc 332 link?))) 333 (list body ...))) 334 link?))) 335 336 (define-syntax-rule (definterface name (intf ...) body ...) 337 (*definterface *include-class name (intf ...) body ...)) 338 339 (define-syntax-rule (definterface/title name (intf ...) body ...) 340 (*definterface *include-class/title name (intf ...) body ...)) 341 342 (define-syntax-rule (*defmixin *include-class name (domain ...) (range ...) 343 body ...) 344 (let ([link? #t]) 345 (*include-class 346 (syntax-parameterize ([current-class (quote-syntax name)]) 347 (make-decl (quote-syntax/loc name) 348 #f 349 null 350 (list (quote-syntax/loc domain) ...) 351 (list (quote-syntax/loc range) ...) 352 (lambda (whole-page?) 353 (list 354 (*class-doc 'mixin 355 (quote-syntax/loc name) 356 #f 357 (list (quote-syntax domain) ...) 358 (list (quote-syntax range) ...) 359 whole-page? 360 make-mixin-index-desc 361 link?))) 362 (list body ...))) 363 link?))) 364 365 (define-syntax-rule (defmixin name (domain ...) (range ...) body ...) 366 (*defmixin *include-class name (domain ...) (range ...) body ...)) 367 368 (define-syntax-rule (defmixin/title name (domain ...) (range ...) body ...) 369 (*defmixin *include-class/title name (domain ...) (range ...) body ...)) 370 371 (define-syntax (defconstructor*/* stx) 372 (syntax-case stx () 373 [(_ mode ((arg ...) ...) desc ...) 374 (let ([n (syntax-parameter-value #'current-class)]) 375 (with-syntax ([name n] 376 [result 377 (datum->syntax 378 #f 379 (list 380 (datum->syntax #'is-a?/c 'is-a?/c (list 'src 1 1 2 1)) 381 (datum->syntax n (syntax-e n) (list 'src 1 3 4 1))) 382 (list 'src 1 0 1 5))] 383 [(((kw ...) ...) ...) 384 (map (lambda (ids) 385 (map (lambda (arg) 386 (if (and (pair? (syntax-e arg)) 387 (eq? (syntax-e #'mode) 'new)) 388 (list (string->keyword 389 (symbol->string 390 (syntax-e 391 (car (syntax-e arg)))))) 392 null)) 393 (syntax->list ids))) 394 (syntax->list #'((arg ...) ...)))]) 395 #'(make-constructor (lambda () 396 (defproc* #:mode mode #:within name 397 [[(make [kw ... . arg] ...) result] ...] 398 desc ...)))))])) 399 400 (define-syntax (defconstructor stx) 401 (syntax-case stx () 402 [(_ ([id . arg-rest] ...) desc ...) 403 #'(defconstructor*/* new (([id . arg-rest] ...)) desc ...)])) 404 405 (define-syntax (defconstructor/make stx) 406 (syntax-case stx () 407 [(_ ([id . arg-rest] ...) desc ...) 408 #'(defconstructor*/* make (([id . arg-rest] ...)) desc ...)])) 409 410 (define-syntax (defconstructor*/make stx) 411 (syntax-case stx () 412 [(_ (([id . arg-rest] ...) ...) desc ...) 413 #'(defconstructor*/* make (([id . arg-rest] ...) ...) desc ...)])) 414 415 (define-syntax (defconstructor/auto-super stx) 416 (syntax-case stx () 417 [(_ ([id . arg-rest] ...) desc ...) 418 #'(defconstructor*/* new (([id . arg-rest] ... _...superclass-args...)) 419 desc ...)])) 420 421 (define-syntax (defmethod* stx) 422 (syntax-case stx () 423 [(_ #:mode mode #:link-target? link-target? ([(name arg ...) result-type] ...) desc ...) 424 (with-syntax ([cname (syntax-parameter-value #'current-class)] 425 [name1 (car (syntax->list #'(name ...)))]) 426 (with-syntax ([(extra ...) 427 (let ([finality 428 (lambda (prefix) 429 (case (syntax-e #'mode) 430 [(override-final public-final extend-final) 431 #`(#,prefix "This method is final, so it cannot be overridden.")] 432 [(augment-final) 433 #`(#,prefix "This method is final, so it cannot be augmented.")] 434 [else null]))]) 435 (case (syntax-e #'mode) 436 [(pubment) 437 #'((t "Refine this method with " 438 (racket augment) "."))] 439 [(override 440 override-final 441 extend 442 extend-final 443 augment 444 augment-final) 445 #`((t #,(case (syntax-e #'mode) 446 [(override override-final) "Overrides "] 447 [(extend extend-final) "Extends "] 448 [(augment augment-final) "Augments "]) 449 (*xmethod/super (quote-syntax/loc cname) 'name1) 450 "." 451 #,@(finality " ")))] 452 [(public public-final) #`((t #,@(finality "")))] 453 [else (raise-syntax-error #f "unrecognized mode" #'mode)]))]) 454 #'(make-meth '(name ...) 455 'mode 456 (lambda () 457 (defproc* #:link-target? link-target? #:mode send #:within cname 458 ([(name arg ...) result-type] ...) 459 (make-splice 460 (append-map (lambda (f) 461 (cond [(impl? f) ((impl-def f))] 462 [(spec? f) ((spec-def f))] 463 [else (list f)])) 464 (list extra ... desc ...))))))))] 465 [(_ #:mode mode ([(name arg ...) result-type] ...) desc ...) 466 #'(defmethod* #:mode mode #:link-target? #t ([(name arg ...) result-type] ...) desc ...)] 467 [(_ #:link-target? link-target? ([(name arg ...) result-type] ...) desc ...) 468 #'(defmethod* #:mode public #:link-target? link-target? ([(name arg ...) result-type] ...) desc ...)] 469 [(_ ([(name arg ...) result-type] ...) desc ...) 470 #'(defmethod* #:mode public ([(name arg ...) result-type] ...) desc ...)])) 471 472 (define-syntax defmethod 473 (syntax-rules () 474 [(_ #:mode mode #:link-target? link-target? (name arg ...) result-type desc ...) 475 (defmethod* #:mode mode #:link-target? link-target? ([(name arg ...) result-type]) desc ...)] 476 [(_ #:mode mode (name arg ...) result-type desc ...) 477 (defmethod #:mode mode #:link-target? #t (name arg ...) result-type desc ...)] 478 [(_ #:link-target? link-target? (name arg ...) result-type desc ...) 479 (defmethod #:mode public #:link-target? link-target? (name arg ...) result-type desc ...)] 480 [(_ (name arg ...) result-type desc ...) 481 (defmethod #:mode public #:link-target? #t (name arg ...) result-type desc ...)])) 482 483 (define-syntax-rule (methimpl body ...) 484 (make-impl (lambda () (list (italic "Default implementation:") " " body ...)))) 485 486 (define-syntax-rule (methspec body ...) 487 (make-spec (lambda () (list (italic "Specification:") " " body ...)))) 488 489 (define (*this-obj cname) 490 (name-this-object cname)) 491 492 (define-syntax (this-obj stx) 493 (syntax-case stx () 494 [(_) 495 (with-syntax ([cname (syntax-parameter-value #'current-class)]) 496 #'(*this-obj 'cname))])) 497 498 (define (*xmethod/super cname name) 499 (let ([get 500 (lambda (d ri key) 501 (if key 502 (let ([v (lookup-cls/intf d ri key)]) 503 (if v 504 (append (cls/intf-app-mixins v) 505 (cons (cls/intf-super v) 506 (cls/intf-intfs v))) 507 null)) 508 null))]) 509 (make-delayed-element 510 (lambda (r d ri) 511 (let loop ([search (get d ri (find-scheme-tag d ri cname #f))]) 512 (cond 513 [(null? search) 514 (list (make-element #f '("<method not found>")))] 515 [(not (car search)) 516 (loop (cdr search))] 517 [else 518 (let* ([a-key (find-scheme-tag d ri (car search) #f)] 519 [v (and a-key (lookup-cls/intf d ri a-key))]) 520 (if v 521 (if (member name (cls/intf-methods v)) 522 (list 523 (make-element #f 524 (list (**method name a-key) 525 " in " 526 (cls/intf-name-element v)))) 527 (loop (append (cdr search) 528 (get d ri (find-scheme-tag d ri (car search) 529 #f))))) 530 (loop (cdr search))))]))) 531 (lambda () (format "~a in ~a" (syntax-e cname) name)) 532 (lambda () (format "~a in ~a" (syntax-e cname) name))))) 533 534 (define (lookup-cls/intf d ri tag) 535 (let ([v (resolve-get d ri `(cls/intf ,(cadr tag)))]) 536 (or v (make-cls/intf "unknown" null #f null null))))