1#lang racket/base 2(require "class-internal.rkt" 3 "class-c-old.rkt" 4 "class-wrapped.rkt" 5 "../contract/base.rkt" 6 "../contract/combinator.rkt" 7 (for-syntax racket/base 8 syntax/name 9 syntax/stx)) 10 11(provide class/c2) 12 13(define-syntax (class/c2 stx) 14 (define-values (opaque? args) 15 (syntax-case stx () 16 [(_ #:opaque args ...) 17 (values #t (syntax->list #'(args ...)))] 18 [(_ args ...) 19 (let () 20 (define stx-args (syntax->list #'(args ...))) 21 (when (and (pair? stx-args) (keyword? (syntax-e (car stx-args)))) 22 (raise-syntax-error #f "unrecognized keyword" stx (car stx-args))) 23 (values #f stx-args))])) 24 (define-values (bindings pfs) (parse-class/c-specs args #f)) 25 (with-syntax ([methods #`(list #,@(reverse (hash-ref pfs 'methods null)))] 26 [method-ctcs #`(list #,@(reverse (hash-ref pfs 'method-contracts null)))] 27 [fields #`(list #,@(reverse (hash-ref pfs 'fields null)))] 28 [field-ctcs #`(list #,@(reverse (hash-ref pfs 'field-contracts null)))] 29 [(i ...) (reverse (hash-ref pfs 'inits null))] 30 [(i-c ...) (reverse (hash-ref pfs 'init-contracts null))] 31 [inherits #`(list #,@(reverse (hash-ref pfs 'inherits null)))] 32 [inherit-ctcs #`(list #,@(reverse (hash-ref pfs 'inherit-contracts null)))] 33 [inherit-fields #`(list #,@(reverse (hash-ref pfs 'inherit-fields null)))] 34 [inherit-field-ctcs #`(list #,@(reverse (hash-ref pfs 'inherit-field-contracts 35 null)))] 36 [supers #`(list #,@(reverse (hash-ref pfs 'supers null)))] 37 [super-ctcs #`(list #,@(reverse (hash-ref pfs 'super-contracts null)))] 38 [inners #`(list #,@(reverse (hash-ref pfs 'inners null)))] 39 [inner-ctcs #`(list #,@(reverse (hash-ref pfs 'inner-contracts null)))] 40 [overrides #`(list #,@(reverse (hash-ref pfs 'overrides null)))] 41 [override-ctcs #`(list #,@(reverse (hash-ref pfs 'override-contracts null)))] 42 [augments #`(list #,@(reverse (hash-ref pfs 'augments null)))] 43 [augment-ctcs #`(list #,@(reverse (hash-ref pfs 'augment-contracts null)))] 44 [augrides #`(list #,@(reverse (hash-ref pfs 'augrides null)))] 45 [augride-ctcs #`(list #,@(reverse (hash-ref pfs 'augride-contracts null)))] 46 [absents #`(list #,@(reverse (hash-ref pfs 'absents null)))] 47 [absent-fields #`(list #,@(reverse (hash-ref pfs 'absent-fields null)))]) 48 (with-syntax ([name 49 ;; same as syntax-local-infer-name, except doesn't 50 ;; make a name up from the src loc; in that case, 51 ;; we just use the big ole (class/c ...)-based name 52 (or (let loop ([prop (syntax-property stx 'inferred-name)]) 53 (cond 54 [(symbol? prop) prop] 55 [(pair? prop) (or (loop (car prop)) 56 (loop (cdr prop)))] 57 [else #f])) 58 (syntax-local-name))] 59 [bindings bindings] 60 [opaque? opaque?]) 61 (syntax/loc stx 62 (let bindings 63 (make-an-ext-class/c-contract 64 'opaque? 65 methods method-ctcs 66 fields field-ctcs 67 (list i ...) 68 (list i-c ...) 69 absents 70 absent-fields 71 'name 72 (build-internal-class/c 73 inherits inherit-ctcs 74 inherit-fields inherit-field-ctcs 75 supers super-ctcs 76 inners inner-ctcs 77 overrides override-ctcs 78 augments augment-ctcs 79 augrides augride-ctcs))))))) 80 81(define (class/c2-proj this) 82 (λ (blame) 83 (λ (cls) 84 (let/ec k 85 (define (maybe-err neg-accepter) 86 (if (blame-original? blame) 87 (neg-accepter #f) 88 (k neg-accepter))) 89 (cond 90 [(impersonator-prop:has-wrapped-class-neg-party? cls) 91 (define wrapper-neg-party (impersonator-prop:get-wrapped-class-neg-party cls)) 92 (define the-info (impersonator-prop:get-wrapped-class-info cls)) 93 (define neg-acceptors (wrapped-class-info-neg-acceptors-ht the-info)) 94 (define mth->idx (class-method-ht cls)) 95 (define new-mths (make-vector (vector-length (class-methods cls)) #f)) 96 (for ([(mth neg-acceptor) (in-hash neg-acceptors)]) 97 (define mth-idx (hash-ref mth->idx mth)) 98 (vector-set! new-mths mth-idx (neg-acceptor wrapper-neg-party))) 99 (define fixed-neg-init-projs 100 (for/list ([proj-pair (wrapped-class-info-init-proj-pairs the-info)]) 101 (cons (list-ref proj-pair 0) 102 (for/list ([func (in-list (cdr proj-pair))]) 103 (λ (val) (λ (neg-party) 104 ((func val) wrapper-neg-party))))))) 105 (build-neg-acceptor-proc this maybe-err blame 106 cls 107 new-mths 108 fixed-neg-init-projs 109 (wrapped-class-info-pos-field-projs the-info) 110 (wrapped-class-info-neg-field-projs the-info))] 111 [(class-struct-predicate? cls) 112 (define mtd-vec (class-methods cls)) 113 (cond 114 [(for/or ([x (in-vector mtd-vec)]) 115 (pair? x)) 116 ;; if we find what appears to be an interface contract 117 ;; in the given class, then we fall back to the old-style 118 ;; class/c contracts by making up a class/c record and 119 ;; handing it off to old-style class/c projection. 120 (define mth-lst 121 (for/list ([(mth ctc) 122 (in-hash (ext-class/c-contract-table-of-meths-to-ctcs this))]) 123 (cons mth 124 (if (just-check-existence? ctc) 125 any/c 126 ctc)))) 127 128 (define fields 129 (for/list ([(fld ctc) (in-hash (ext-class/c-contract-table-of-flds-to-ctcs this))]) 130 fld)) 131 (define field-ctcs 132 (for/list ([(fld ctc) (in-hash (ext-class/c-contract-table-of-flds-to-ctcs this))]) 133 (if (just-check-existence? ctc) 134 #f 135 ctc))) 136 137 (define ctc 138 (make-class/c 139 ;; methods 140 (map car mth-lst) 141 (map cdr mth-lst) 142 143 fields field-ctcs 144 145 ;; inits 146 (map (λ (x) (list-ref x 0)) (ext-class/c-contract-init-ctc-pairs this)) 147 (map (λ (x) 148 (define ctc (list-ref x 1)) 149 (if (just-check-existence? ctc) 150 any/c 151 ctc)) 152 (ext-class/c-contract-init-ctc-pairs this)) 153 154 (ext-class/c-contract-absent-methods this) 155 (ext-class/c-contract-absent-fields this) 156 157 (ext-class/c-contract-internal-ctc this) 158 (ext-class/c-contract-opaque? this) 159 (ext-class/c-contract-name this))) 160 (λ (neg-party) 161 (((class/c-late-neg-proj ctc) blame) cls neg-party))] 162 [else 163 (build-neg-acceptor-proc this maybe-err blame cls #f '() 164 (make-hasheq) (make-hasheq))])] 165 [else 166 (maybe-err 167 (λ (neg-party) 168 (raise-blame-error 169 blame #:missing-party neg-party cls 170 '(expected: "a class"))))]))))) 171 172(define (build-neg-acceptor-proc this maybe-err blame cls old-mths-vec old-init-pairs 173 old-pos-fld-ht old-neg-fld-ht) 174 (define mth->idx (class-method-ht cls)) 175 (define mtd-vec (class-methods cls)) 176 177 (define internal-late-neg-proj 178 (internal-class/c-late-neg-proj (ext-class/c-contract-internal-ctc this))) 179 180 ;; The #f may survive if the method is just-check-existence or 181 ;; if the contract doesn't mention the method (and it isn't opaque) 182 (define neg-extra-arg-vec (make-vector (vector-length mtd-vec) #f)) 183 (define neg-acceptors-ht (make-hash)) 184 185 (define pos-field-projs (hash-copy old-pos-fld-ht)) 186 (define neg-field-projs (hash-copy old-neg-fld-ht)) 187 188 (for ([(mth-name proj) (in-hash (ext-class/c-contract-table-of-meths-to-projs this))]) 189 (define mth-idx (hash-ref mth->idx mth-name #f)) 190 (unless mth-idx 191 (maybe-err 192 (λ (neg-party) 193 (raise-blame-error 194 blame #:missing-party neg-party cls 195 '(expected: "a class with a public method named ~a") 196 mth-name)))) 197 198 (unless (just-check-existence? proj) 199 (define w/blame (proj (blame-add-method-context blame mth-name))) 200 (define m-mth (if old-mths-vec 201 (or (vector-ref old-mths-vec mth-idx) 202 (vector-ref mtd-vec mth-idx)) 203 (vector-ref mtd-vec mth-idx))) 204 (define projd-mth (w/blame m-mth)) 205 (hash-set! neg-acceptors-ht mth-name projd-mth) 206 (define neg-extra-arg 207 ;; the way extra args worked changed so we cannot use it here anymore 208 ;; keep an inefficient wrapper (but maybe this whole approach should 209 ;; go away) 210 (make-keyword-procedure 211 (λ (kwds kwd-args neg-party . args) 212 (keyword-apply (projd-mth neg-party) kwds kwd-args args)) 213 (λ (neg-party . args) 214 (apply (projd-mth neg-party) args)))) 215 (vector-set! neg-extra-arg-vec mth-idx neg-extra-arg))) 216 217 (define absent-methods (ext-class/c-contract-absent-methods this)) 218 (for ([(mth-name mth-idx) (in-hash mth->idx)]) 219 (when (member mth-name absent-methods) 220 (maybe-err 221 (λ (neg-party) 222 (raise-blame-error 223 blame #:missing-party neg-party cls 224 '(expected: "a class that does not have the method ~a") 225 mth-name)))) 226 227 (when (ext-class/c-contract-opaque? this) 228 (unless (hash-ref (ext-class/c-contract-table-of-meths-to-projs this) mth-name #f) 229 (maybe-err 230 (λ (neg-party) 231 (define mth-names 232 (for/list ([(mth proj) (in-hash (ext-class/c-contract-table-of-meths-to-projs this))]) 233 (format " ~a" mth))) 234 (raise-blame-error 235 blame #:missing-party neg-party cls 236 '(expected: "~a" given: "a class that has a method: ~a") 237 (cond 238 [(null? mth-names) "a class with no methods"] 239 [(null? (cdr mth-names)) 240 (format "a class with only one method:~a" (car mth-names))] 241 [else 242 (format "a class with only the methods:~a" 243 (apply string-append mth-names))]) 244 mth-name)))))) 245 246 (for ([(fld proj) (in-hash (ext-class/c-contract-table-of-flds-to-projs this))]) 247 (define field-ht (class-field-ht cls)) 248 (define fi (hash-ref field-ht fld #f)) 249 (unless fi 250 (maybe-err 251 (λ (neg-party) 252 (raise-blame-error 253 blame #:missing-party neg-party cls 254 '(expected: "a class with a public field named ~a") 255 fld)))) 256 257 (unless (just-check-existence? proj) 258 (define (update-ht field-projs field-info-internal-ref/set! swap?) 259 (define prior (hash-ref field-projs fld (λ () (field-info-internal-ref/set! fi)))) 260 (define w-blame (proj (blame-add-field-context blame proj #:swap? swap?))) 261 (hash-set! field-projs fld (cons w-blame prior))) 262 (update-ht pos-field-projs field-info-internal-ref #f) 263 (update-ht neg-field-projs field-info-internal-set! #t))) 264 265 (define absent-fields (ext-class/c-contract-absent-fields this)) 266 (unless (null? absent-fields) 267 (for ([(fld proj) (in-hash (class-field-ht cls))]) 268 (when (member fld absent-fields) 269 (maybe-err 270 (λ (neg-party) 271 (raise-blame-error 272 blame #:missing-party neg-party cls 273 '(expected: "a class that does not have the field ~a") 274 fld)))))) 275 276 (when (ext-class/c-contract-opaque? this) 277 (define allowed-flds (ext-class/c-contract-table-of-flds-to-projs this)) 278 (for ([(fld proj) (in-hash (class-field-ht cls))]) 279 (unless (hash-ref allowed-flds fld #f) 280 (maybe-err 281 (λ (neg-party) 282 (define fld-names 283 (for/list ([(fld proj) (in-hash allowed-flds)]) 284 (format " ~a" fld))) 285 (raise-blame-error 286 blame #:missing-party neg-party cls 287 '(expected: "~a" given: "a class that has the field: ~a") 288 (cond 289 [(null? fld-names) "a class with no fields"] 290 [(null? (cdr fld-names)) 291 (format "a class with only one field:~a" (car fld-names))] 292 [else 293 (format "a class with only the fields:~a" 294 (apply string-append fld-names))]) 295 fld)))))) 296 297 (define new-init-projs 298 (for/list ([ctc-pair (in-list (ext-class/c-contract-init-ctc-pairs this))]) 299 (define ctc (list-ref ctc-pair 1)) 300 (if (just-check-existence? ctc) 301 (list (car ctc-pair) 302 (λ (x) (λ (y) x))) 303 (list (car ctc-pair) 304 ((get/build-val-first-projection ctc) 305 (blame-add-init-context blame (car ctc-pair))))))) 306 (define merged-init-pairs (merge-init-pairs old-init-pairs new-init-projs)) 307 (define the-info (wrapped-class-info blame neg-extra-arg-vec neg-acceptors-ht 308 pos-field-projs neg-field-projs 309 merged-init-pairs)) 310 (define class+one-property 311 (chaperone-struct cls 312 set-class-orig-cls! (λ (a b) b) 313 impersonator-prop:wrapped-class-info 314 the-info)) 315 316 (λ (neg-party) 317 ;; run this for the side-effect of 318 ;; checking that first-order tests on 319 ;; methods (arity, etc) all pass 320 (for ([(mth-name neg-party-acceptor) (in-hash neg-acceptors-ht)]) 321 (neg-party-acceptor neg-party)) 322 323 ;; XXX: we have to not do this; 324 ;; (instead we should use just the-info) 325 ;; the internal projection should run 326 ;; on the class only when it is 327 ;; time to instantiate it; not here 328 (define class+one-property/adjusted 329 (chaperone-struct ((internal-late-neg-proj blame) cls neg-party) 330 set-class-orig-cls! (λ (a b) b) 331 impersonator-prop:wrapped-class-info 332 the-info)) 333 334 (chaperone-struct class+one-property/adjusted 335 set-class-orig-cls! (λ (a b) b) 336 impersonator-prop:wrapped-class-neg-party 337 neg-party))) 338 339(define (merge-init-pairs old-init-pairs new-init-pairs) 340 (cond 341 [(null? old-init-pairs) new-init-pairs] 342 [else 343 (define (leq? x y) (string<? (symbol->string (car x)) (symbol->string (car y)))) 344 (define (same? x y) (eq? (car x) (car y))) 345 (let loop ([olds (sort old-init-pairs leq?)] 346 [news (sort new-init-pairs leq?)]) 347 (cond 348 [(null? olds) news] 349 [(null? news) olds] 350 [else 351 (define old (car olds)) 352 (define new (car news)) 353 (cond 354 [(same? old new) 355 (cons (cons (car old) (append (cdr old) (cdr new))) 356 (loop (cdr olds) (cdr news)))] 357 [(leq? old new) 358 (cons old (loop (cdr olds) news))] 359 [else 360 (cons new (loop olds (cdr news)))])]))])) 361 362(define (make-an-ext-class/c-contract opaque? 363 mth-names mth-ctcs 364 fld-names fld-ctcs 365 init-names init-ctcs 366 absent-methods absent-fields 367 ctc-name internal-ctc) 368 (define (build-a-ctc-table names ctcs) 369 (make-hash (for/list ([raw-ctc (in-list ctcs)] 370 [name (in-list names)]) 371 (define ctc (if (just-check-existence? raw-ctc) 372 raw-ctc 373 (coerce-contract 'class/c raw-ctc))) 374 (cons name ctc)))) 375 (define (build-a-proj-table hash names) 376 (make-hash 377 (for/list ([name (in-list names)]) 378 (define ctc (hash-ref hash name)) 379 (cond 380 [(just-check-existence? ctc) 381 (cons name ctc)] 382 [else 383 (define proj (get/build-val-first-projection ctc)) 384 (cons name proj)])))) 385 (define mth-ctc-hash (build-a-ctc-table mth-names mth-ctcs)) 386 (define fld-ctc-hash (build-a-ctc-table fld-names fld-ctcs)) 387 (define mth-proj-hash (build-a-proj-table mth-ctc-hash mth-names)) 388 (define fld-proj-hash (build-a-proj-table fld-ctc-hash fld-names)) 389 (ext-class/c-contract 390 opaque? 391 mth-ctc-hash mth-proj-hash 392 fld-ctc-hash fld-proj-hash 393 (for/list ([name (in-list init-names)] 394 [ctc (in-list init-ctcs)]) 395 (list name 396 (if (just-check-existence? ctc) 397 ctc 398 (coerce-contract 'class/c ctc)))) 399 absent-methods absent-fields 400 ctc-name 401 internal-ctc)) 402 403(define (class/c-first-order-passes? ctc cls) 404 (cond 405 [(class-struct-predicate? cls) 406 (define mth->idx (class-method-ht cls)) 407 (define mtd-vec (class-methods cls)) 408 (for/and ([(name ctc) (in-hash (ext-class/c-contract-table-of-meths-to-ctcs ctc))]) 409 (define mth-idx (hash-ref mth->idx name #f)) 410 (cond 411 [mth-idx 412 (define mth-record (vector-ref mtd-vec mth-idx)) 413 (contract-first-order-passes? 414 ctc 415 (if (pair? mth-record) 416 (car mth-record) 417 mth-record))] 418 [else #f]))] 419 [else #f])) 420 421(struct ext-class/c-contract (opaque? 422 table-of-meths-to-ctcs 423 table-of-meths-to-projs 424 table-of-flds-to-ctcs 425 table-of-flds-to-projs 426 init-ctc-pairs 427 absent-methods absent-fields 428 name 429 internal-ctc) 430 #:property prop:contract 431 (build-contract-property 432 #:projection 433 (λ (c) (λ (blame) (λ (v) ((((class/c2-proj c) blame) v) #f)))) 434 #:val-first-projection class/c2-proj 435 #:first-order 436 (λ (ctc) 437 (λ (cls) 438 (class/c-first-order-passes? ctc cls))) 439 #:name 440 (λ (c) 441 (cond 442 [(ext-class/c-contract-name c) => values] 443 [else 444 (define field-names 445 (for/list ([(fld ctc) (in-hash (ext-class/c-contract-table-of-flds-to-ctcs c))]) 446 (if (just-check-existence? ctc) 447 fld 448 `(,fld ,(contract-name ctc))))) 449 (define init-fields '()) 450 (define init-names 451 (filter 452 values 453 (for/list ([pr (in-list (ext-class/c-contract-init-ctc-pairs c))]) 454 (define name (list-ref pr 0)) 455 (define ctc (list-ref pr 1)) 456 (cond 457 [(just-check-existence? ctc) 458 name] 459 [else 460 (define c-name (contract-name ctc)) 461 (define clause `[,name ,c-name]) 462 (define fld-ctc (hash-ref (ext-class/c-contract-table-of-flds-to-ctcs c) name #f)) 463 (cond 464 [(and fld-ctc (equal? c-name (contract-name fld-ctc))) 465 (set! init-fields (cons clause init-fields)) 466 #f] 467 [else clause])])))) 468 (set! field-names (filter (λ (x) (or (not (pair? x)) 469 (not (member (car x) (map car init-fields))))) 470 field-names)) 471 472 (define meth-names 473 (for/list ([(name ctc) (in-hash (ext-class/c-contract-table-of-meths-to-ctcs c))]) 474 (if (just-check-existence? ctc) 475 name 476 `[,name ,(contract-name ctc)]))) 477 478 (define absents 479 (let ([ams (ext-class/c-contract-absent-methods c)] 480 [afs (ext-class/c-contract-absent-fields c)]) 481 (cond 482 [(and (null? ams) (null? afs)) '()] 483 [(null? afs) (list `(absent ,@ams))] 484 [else (list `(absent ,@ams (field ,@afs)))]))) 485 486 `(class/c ,@(if (null? init-names) 487 (list) 488 (list `(init ,@init-names))) 489 ,@(if (null? field-names) 490 (list) 491 (list `(field ,@field-names))) 492 ,@(if (null? init-fields) 493 (list) 494 (list `(init-field ,@init-fields))) 495 ,@meth-names 496 ,@absents 497 ,@(class/c-internal-name-clauses (ext-class/c-contract-internal-ctc c)))])))) 498