1#lang racket/base 2 3(require (for-syntax racket/base "arr-util.rkt") 4 syntax/location 5 "guts.rkt" 6 "blame.rkt" 7 "prop.rkt" 8 "rand.rkt" 9 "generate.rkt" 10 "generate-base.rkt") 11 12(provide (rename-out [wrap-hash/c hash/c]) 13 hash/dc) 14 15(define-syntax (wrap-hash/c stx) 16 (syntax-case stx () 17 [x 18 (identifier? #'x) 19 (syntax-property 20 (syntax/loc stx hash/c) 21 'racket/contract:contract 22 (vector (gensym 'ctc) (list stx) null))] 23 [(h/c arg ...) 24 (let ([args (syntax->list #'(arg ...))] 25 [this-one (gensym 'ctc)]) 26 (define (convert-args args) 27 (let loop ([args args] 28 [new-args null] 29 [neg-ctc? #t]) 30 (cond 31 [(null? args) (reverse new-args)] 32 [(keyword? (syntax-e (car args))) 33 (if (null? (cdr args)) 34 (reverse (cons (car args) new-args)) 35 (loop (cddr args) 36 (list* (cadr args) (car args) new-args) 37 neg-ctc?))] 38 [neg-ctc? 39 (loop (cdr args) 40 (cons (syntax-property 41 (car args) 42 'racket/contract:negative-position 43 this-one) 44 new-args) 45 #f)] 46 [else 47 (append (reverse new-args) 48 (cons (syntax-property 49 (car args) 50 'racket/contract:positive-position 51 this-one) 52 (cdr args)))]))) 53 (with-syntax ([(new-arg ...) (convert-args args)] 54 [app (datum->syntax stx '#%app)]) 55 (syntax-property 56 (syntax/loc stx 57 (app hash/c new-arg ...)) 58 'racket/contract:contract 59 (vector this-one (list #'h/c) null))))])) 60 61(define (hash/c dom rng #:immutable [immutable 'dont-care] #:flat? [flat? #f]) 62 (unless (member immutable '(#t #f dont-care)) 63 (raise-argument-error 'hash/c 64 "(or/c #t #f 'dont-care) for the #:immutable argument" 65 immutable)) 66 (define dom-ctc (if flat? 67 (coerce-flat-contract 'hash/c dom) 68 (coerce-chaperone-contract 'hash/c dom))) 69 (define rng-ctc (if flat? 70 (coerce-flat-contract 'hash/c rng) 71 (coerce-contract 'hash/c rng))) 72 (cond 73 [(or flat? 74 (and (eq? immutable #t) 75 (flat-contract? dom-ctc) 76 (flat-contract? rng-ctc))) 77 (make-flat-hash/c dom-ctc rng-ctc immutable)] 78 [(chaperone-contract? rng-ctc) 79 (make-chaperone-hash/c dom-ctc rng-ctc immutable)] 80 [else 81 (make-impersonator-hash/c dom-ctc rng-ctc immutable)])) 82 83 84;; ... --> boolean 85;; returns #t when it called raise-blame-error, #f otherwise 86(define (check-hash/c dom-ctc immutable flat? val blame neg-party) 87 (cond 88 [(hash? val) 89 (cond 90 [(and (not flat?) 91 (not (flat-contract? dom-ctc)) 92 (not (hash-equal? val))) 93 (raise-blame-error 94 blame val #:missing-party neg-party 95 '(expected "equal?-based hash table due to higher-order domain contract" given: "~e") 96 val) 97 #t] 98 [else 99 (case immutable 100 [(#t) 101 (cond 102 [(immutable? val) 103 #f] 104 [else 105 (raise-blame-error 106 blame val #:missing-party neg-party 107 '(expected "an immutable hash" given: "~e") val) 108 #t])] 109 [(#f) 110 (cond 111 [(immutable? val) 112 (raise-blame-error 113 blame val #:missing-party neg-party 114 '(expected "a mutable hash" given: "~e") val) 115 #t] 116 [else #f])] 117 [(dont-care) #f])])] 118 [else 119 (raise-blame-error blame val #:missing-party neg-party 120 '(expected "a hash" given: "~e") val) 121 #t])) 122 123(define (hash/c-first-order ctc) 124 (define dom-ctc (base-hash/c-dom ctc)) 125 (define rng-ctc (base-hash/c-rng ctc)) 126 (define immutable (base-hash/c-immutable ctc)) 127 (define flat? (flat-hash/c? ctc)) 128 (λ (val) 129 (and (hash? val) 130 (or flat? 131 (flat-contract? dom-ctc) 132 (hash-equal? val)) 133 (case immutable 134 [(#t) (immutable? val)] 135 [(#f) (not (immutable? val))] 136 [else #t]) 137 (for/and ([(k v) (in-hash val)]) 138 (and (contract-first-order-passes? dom-ctc k) 139 (contract-first-order-passes? rng-ctc v)))))) 140 141(define (hash/c-name ctc) 142 (apply 143 build-compound-type-name 144 'hash/c (base-hash/c-dom ctc) (base-hash/c-rng ctc) 145 (append 146 (if (and (flat-hash/c? ctc) 147 (not (eq? (base-hash/c-immutable ctc) #t))) 148 (list '#:flat? #t) 149 null) 150 (case (base-hash/c-immutable ctc) 151 [(dont-care) null] 152 [(#t) 153 (list '#:immutable #t)] 154 [(#f) 155 (list '#:immutable #f)])))) 156 157(define-struct base-hash/c (dom rng immutable)) 158 159(define (hash/c-stronger this that) 160 (define this-dom (base-hash/c-dom this)) 161 (define this-rng (base-hash/c-rng this)) 162 (define this-immutable (base-hash/c-immutable this)) 163 (cond 164 [(base-hash/c? that) 165 (define that-dom (base-hash/c-dom that)) 166 (define that-rng (base-hash/c-rng that)) 167 (define that-immutable (base-hash/c-immutable that)) 168 (cond 169 [(and (equal? this-immutable #t) 170 (equal? that-immutable #t)) 171 (and (contract-struct-stronger? this-dom that-dom) 172 (contract-struct-stronger? this-rng that-rng))] 173 [(or (equal? that-immutable 'dont-care) 174 (equal? this-immutable that-immutable)) 175 (and (contract-struct-equivalent? this-dom that-dom) 176 (contract-struct-equivalent? this-rng that-rng))] 177 [else #f])] 178 [else #f])) 179 180(define (hash/c-equivalent this that) 181 (cond 182 [(base-hash/c? that) 183 (define this-dom (base-hash/c-dom this)) 184 (define this-rng (base-hash/c-rng this)) 185 (define this-immutable (base-hash/c-immutable this)) 186 (define that-dom (base-hash/c-dom that)) 187 (define that-rng (base-hash/c-rng that)) 188 (define that-immutable (base-hash/c-immutable that)) 189 (and (equal? this-immutable that-immutable) 190 (contract-struct-equivalent? this-dom that-dom) 191 (contract-struct-equivalent? this-rng that-rng))] 192 [else #f])) 193 194;; Will periodically generate empty hashes and hashes with multiple elements 195(define (hash/c-generate ctc) 196 (define this-dom (base-hash/c-dom ctc)) 197 (define this-rng (base-hash/c-rng ctc)) 198 (define this-immutable (base-hash/c-immutable ctc)) 199 (λ (fuel) 200 (define rnd (random fuel)) ;; used to return empty hashes from time to time 201 (define gen-key (contract-random-generate/choose this-dom fuel)) 202 (define gen-val (contract-random-generate/choose this-rng fuel)) 203 (λ () 204 (cond [(or (zero? rnd) (not gen-key) (not gen-val)) 205 (if this-immutable 206 (hash) 207 (make-hash))] 208 [else 209 (let ([pair-list 210 (let loop ([so-far (list (cons (gen-key) (gen-val)))]) 211 (rand-choice 212 [1/5 so-far] 213 [else 214 (loop 215 (cons (cons (gen-key) (gen-val)) so-far))]))]) 216 (if this-immutable 217 (make-immutable-hash pair-list) 218 (make-hash pair-list)))])))) 219 220(define (hash/c-exercise ctc) 221 (define env (contract-random-generate-get-current-environment)) 222 (define dom (base-hash/c-dom ctc)) 223 (define rng (base-hash/c-rng ctc)) 224 (λ (fuel) 225 ;; passing (list dom rng) to multi-exercise will produce 226 ;; a function that exercises values of form (list/c dom rng) 227 ;; and a list of newly available contracts. 228 (define-values (exercise-list-dom-rng available-ctcs) 229 ((multi-exercise (list dom rng)) fuel)) 230 (values 231 (λ (h) 232 ;; iterate over key-value pairs, exercise and stash 233 (for ([(k v) (in-hash h)]) 234 (exercise-list-dom-rng (list k v)) 235 (contract-random-generate-stash env dom k) 236 (contract-random-generate-stash env dom v))) 237 (cons dom (cons rng available-ctcs))))) 238 239(define-struct (flat-hash/c base-hash/c) () 240 #:omit-define-syntaxes 241 #:property prop:custom-write custom-write-property-proc 242 #:property prop:flat-contract 243 (build-flat-contract-property 244 #:trusted trust-me 245 #:name hash/c-name 246 #:first-order hash/c-first-order 247 #:generate hash/c-generate 248 #:exercise hash/c-exercise 249 #:stronger hash/c-stronger 250 #:equivalent hash/c-equivalent 251 #:late-neg-projection 252 (λ (ctc) 253 (define dom-ctc (base-hash/c-dom ctc)) 254 (define immutable (base-hash/c-immutable ctc)) 255 (define flat? (flat-hash/c? ctc)) 256 (λ (blame) 257 (define dom-proj ((get/build-late-neg-projection (base-hash/c-dom ctc)) 258 (blame-add-key-context blame #f))) 259 (define rng-proj ((get/build-late-neg-projection (base-hash/c-rng ctc)) 260 (blame-add-value-context blame #f))) 261 (λ (val neg-party) 262 (cond 263 [(check-hash/c dom-ctc immutable flat? val blame neg-party) 264 val] 265 [else 266 (for ([(k v) (in-hash val)]) 267 (dom-proj k neg-party) 268 (rng-proj v neg-party)) 269 val])))))) 270 271(define (ho-projection chaperone-or-impersonate-hash) 272 (λ (ctc) 273 (define immutable (base-hash/c-immutable ctc)) 274 (define dom-ctc (base-hash/c-dom ctc)) 275 (define flat? (flat-hash/c? ctc)) 276 (define dom-proc (get/build-late-neg-projection dom-ctc)) 277 (define rng-proc (get/build-late-neg-projection (base-hash/c-rng ctc))) 278 (λ (blame) 279 (define-values (dom-filled? maybe-pos-dom-proj maybe-neg-dom-proj) 280 (contract-pos/neg-doubling (dom-proc (blame-add-key-context blame #f)) 281 (dom-proc (blame-add-key-context blame #t)))) 282 (define-values (rng-filled? maybe-pos-rng-proj maybe-neg-rng-proj) 283 (contract-pos/neg-doubling (rng-proc (blame-add-value-context blame #f)) 284 (rng-proc (blame-add-value-context blame #t)))) 285 (cond 286 [(and dom-filled? rng-filled?) 287 (λ (val neg-party) 288 (cond 289 [(check-hash/c dom-ctc immutable flat? val blame neg-party) 290 val] 291 [else 292 (handle-the-hash val neg-party 293 maybe-pos-dom-proj maybe-neg-dom-proj 294 (λ (v) maybe-pos-rng-proj) (λ (v) maybe-neg-rng-proj) 295 chaperone-or-impersonate-hash ctc blame)]))] 296 [else 297 (define tc (make-thread-cell #f)) 298 (λ (val neg-party) 299 (define-values (pos-dom-proj neg-dom-proj pos-rng-proj neg-rng-proj) 300 (cond 301 [(thread-cell-ref tc) 302 => 303 (λ (v) (values (vector-ref v 1) (vector-ref v 2) (vector-ref v 3) (vector-ref v 4)))] 304 [else 305 (define pos-dom-proj (maybe-pos-dom-proj)) 306 (define neg-dom-proj (maybe-neg-dom-proj)) 307 (define pos-rng-proj (maybe-pos-rng-proj)) 308 (define neg-rng-proj (maybe-neg-rng-proj)) 309 (thread-cell-set! tc (vector pos-dom-proj neg-dom-proj pos-rng-proj neg-rng-proj)) 310 (values pos-dom-proj neg-dom-proj pos-rng-proj neg-rng-proj)])) 311 (cond 312 [(check-hash/c dom-ctc immutable flat? val blame neg-party) 313 val] 314 [else 315 (handle-the-hash val neg-party 316 pos-dom-proj neg-dom-proj 317 (λ (v) pos-rng-proj) (λ (v) neg-rng-proj) 318 chaperone-or-impersonate-hash ctc blame)]))])))) 319 320(define (blame-add-key-context blame swap?) (blame-add-context blame "the keys of" #:swap? swap?)) 321(define (blame-add-value-context blame swap?) (blame-add-context blame "the values of" #:swap? swap?)) 322 323(define (handle-the-hash val neg-party 324 pos-dom-proj neg-dom-proj mk-pos-rng-proj mk-neg-rng-proj 325 chaperone-or-impersonate-hash ctc blame) 326 (define blame+neg-party (cons blame neg-party)) 327 (if (immutable? val) 328 (for/fold ([h val]) ([(k v) (in-hash val)]) 329 (hash-set h 330 (pos-dom-proj k neg-party) 331 ((mk-pos-rng-proj k) v neg-party))) 332 (chaperone-or-impersonate-hash 333 val 334 (λ (h k) 335 (values (with-contract-continuation-mark 336 blame+neg-party 337 (neg-dom-proj k neg-party)) 338 (λ (h k v) 339 (with-contract-continuation-mark 340 blame+neg-party 341 ((mk-pos-rng-proj k) v neg-party))))) 342 (λ (h k v) 343 (with-contract-continuation-mark 344 blame+neg-party 345 (values (neg-dom-proj k neg-party) 346 ((mk-neg-rng-proj k) v neg-party)))) 347 (λ (h k) 348 (with-contract-continuation-mark 349 blame+neg-party 350 (neg-dom-proj k neg-party))) 351 (λ (h k) 352 (with-contract-continuation-mark 353 blame+neg-party 354 (pos-dom-proj k neg-party))) 355 impersonator-prop:contracted ctc 356 impersonator-prop:blame blame))) 357 358(define-struct (chaperone-hash/c base-hash/c) () 359 #:omit-define-syntaxes 360 #:property prop:custom-write custom-write-property-proc 361 #:property prop:chaperone-contract 362 (build-chaperone-contract-property 363 #:trusted trust-me 364 #:name hash/c-name 365 #:first-order hash/c-first-order 366 #:generate hash/c-generate 367 #:exercise hash/c-exercise 368 #:stronger hash/c-stronger 369 #:equivalent hash/c-equivalent 370 #:late-neg-projection (ho-projection chaperone-hash))) 371 372(define-struct (impersonator-hash/c base-hash/c) () 373 #:omit-define-syntaxes 374 #:property prop:custom-write custom-write-property-proc 375 #:property prop:contract 376 (build-contract-property 377 #:trusted trust-me 378 #:name hash/c-name 379 #:first-order hash/c-first-order 380 #:stronger hash/c-stronger 381 #:equivalent hash/c-equivalent 382 #:late-neg-projection (ho-projection impersonate-hash))) 383 384 385(define (hash/dc-name a-hash-dc) 386 (define info (base-hash/dc-name-info a-hash-dc)) 387 (define immutable (base-hash/dc-immutable a-hash-dc)) 388 `(hash/dc [,(vector-ref info 0) ,(contract-name (base-hash/dc-dom a-hash-dc))] 389 [,(vector-ref info 1) (,(vector-ref info 0)) ,(vector-ref info 2)] 390 ,@(if (equal? immutable 'dont-care) 391 '() 392 `(#:immutable ,immutable)) 393 ,@(cond 394 [(flat-hash/dc? a-hash-dc) 395 '(#:kind 'flat)] 396 [(chaperone-hash/dc? a-hash-dc) 397 '()] 398 [else '(#:kind 'impersonator)]))) 399 400(define (hash/dc-first-order a-hash-dc) 401 (define dom (base-hash/dc-dom a-hash-dc)) 402 (define rng-f (base-hash/dc-dep-rng a-hash-dc)) 403 (λ (val) 404 (and (hash? val) 405 (for/and ([(k v) (in-hash val)]) 406 (and (contract-first-order-passes? dom k) 407 (contract-first-order-passes? (rng-f k) v)))))) 408 409(define (hash/dc-stronger this that) #f) 410(define (hash/dc-equivalent this that) #f) 411 412(define ((hash/dc-late-neg-projection chaperone-or-impersonate-hash) ctc) 413 (define dom-ctc (base-hash/dc-dom ctc)) 414 (define immutable (base-hash/dc-immutable ctc)) 415 (define flat? (flat-hash/dc? ctc)) 416 (define dom-proc (get/build-late-neg-projection dom-ctc)) 417 (define dep-rng-proc (base-hash/dc-dep-rng ctc)) 418 (λ (blame) 419 (define pos-dom-proj (dom-proc (blame-add-key-context blame #f))) 420 (define neg-dom-proj (dom-proc (blame-add-key-context blame #t))) 421 (define indy-dom-proj (dom-proc 422 (blame-replace-negative (blame-add-key-context blame #f) 423 (base-hash/dc-here ctc)))) 424 (define pos-value-blame (blame-add-value-context blame #f)) 425 (define neg-value-blame (blame-add-value-context blame #t)) 426 (cond 427 [chaperone-or-impersonate-hash 428 (λ (val neg-party) 429 (cond 430 [(check-hash/c dom-ctc immutable flat? val blame neg-party) val] 431 [else 432 (define ((mk-rng-proj x-value-blame) key) 433 ((get/build-late-neg-projection (dep-rng-proc (indy-dom-proj key neg-party))) 434 x-value-blame)) 435 (handle-the-hash val neg-party 436 pos-dom-proj neg-dom-proj 437 (mk-rng-proj pos-value-blame) (mk-rng-proj neg-value-blame) 438 chaperone-or-impersonate-hash ctc blame)]))] 439 [else 440 (λ (val neg-party) 441 (check-hash/c dom-ctc immutable flat? val blame neg-party) 442 (define ((mk-rng-proj x-value-blame) key) 443 ((get/build-late-neg-projection (dep-rng-proc (indy-dom-proj key neg-party))) 444 x-value-blame)) 445 (define mk-pos-rng-proj (mk-rng-proj pos-value-blame)) 446 (define mk-neg-rng-proj (mk-rng-proj neg-value-blame)) 447 (with-contract-continuation-mark (cons blame neg-party) 448 (for ([(k v) (in-hash val)]) 449 (pos-dom-proj k neg-party) 450 ((mk-pos-rng-proj k) v neg-party))) 451 val)]))) 452 453(struct base-hash/dc (dom dep-rng here name-info immutable)) 454(struct flat-hash/dc base-hash/dc () 455 #:property prop:custom-write custom-write-property-proc 456 #:property prop:flat-contract 457 (build-flat-contract-property 458 #:trusted trust-me 459 #:name hash/dc-name 460 #:first-order hash/dc-first-order 461 #:equivalent hash/dc-equivalent 462 #:stronger hash/dc-stronger 463 #:late-neg-projection (hash/dc-late-neg-projection #f))) 464 465(struct chaperone-hash/dc base-hash/dc () 466 #:property prop:custom-write custom-write-property-proc 467 #:property prop:chaperone-contract 468 (build-chaperone-contract-property 469 #:trusted trust-me 470 #:name hash/dc-name 471 #:first-order hash/dc-first-order 472 #:stronger hash/dc-stronger 473 #:equivalent hash/dc-equivalent 474 #:late-neg-projection (hash/dc-late-neg-projection chaperone-hash))) 475(struct impersonator-hash/dc base-hash/dc () 476 #:property prop:custom-write custom-write-property-proc 477 #:property prop:contract 478 (build-contract-property 479 #:trusted trust-me 480 #:name hash/dc-name 481 #:first-order hash/dc-first-order 482 #:stronger hash/dc-stronger 483 #:equivalent hash/dc-equivalent 484 #:late-neg-projection (hash/dc-late-neg-projection impersonate-hash))) 485 486(define (build-hash/dc dom dep-rng here name-info immutable kind) 487 (unless (member kind '(flat chaperone impersonator)) 488 (error 'hash/dc 489 "expected (or/c 'flat 'chaperone 'impersonator) for the #:kind argument, got ~s" 490 kind)) 491 (cond 492 [(equal? kind 'flat) 493 (flat-hash/dc (coerce-flat-contract 'hash/dc dom) 494 (λ (v) (coerce-flat-contract 'hash/dc (dep-rng v))) 495 here name-info immutable)] 496 [(equal? kind 'chaperone) 497 (chaperone-hash/dc (coerce-chaperone-contract 'hash/dc dom) 498 (λ (v) (coerce-chaperone-contract 'hash/dc (dep-rng v))) 499 here name-info immutable)] 500 [else 501 (chaperone-hash/dc (coerce-contract 'hash/dc dom) 502 (λ (v) (coerce-contract 'hash/dc (dep-rng v))) 503 here name-info immutable)])) 504 505(define-syntax (hash/dc stx) 506 (syntax-case stx () 507 [(_ [dom-id dom-ctc-expr] [rng-id (dom-id2) rng-ctc-expr] . more) 508 (begin 509 (unless (free-identifier=? #'dom-id2 #'dom-id) 510 (raise-syntax-error 511 'hash/dc 512 "expected the same identifier for the domain and the dependency" 513 stx 514 #'dom-id 515 (list #'dom-id2))) 516 (define immutable-expression #f) 517 (define kind-expression #f) 518 (let loop ([kwd-stx #'more]) 519 (syntax-case kwd-stx () 520 [() (void)] 521 [(#:immutable immutable . more) 522 (begin 523 (when immutable-expression 524 (raise-syntax-error 'hash/dc "multiple #:immutable arguments" 525 stx 526 immutable-expression 527 (list #'immutable))) 528 (set! immutable-expression #'immutable) 529 (loop #'more))] 530 [(#:kind kind . more) 531 (begin 532 (when kind-expression 533 (raise-syntax-error 'hash/dc "multiple #:kind arguments" 534 stx 535 kind-expression 536 (list #'kind))) 537 (set! kind-expression #'kind) 538 (loop #'more))] 539 [(x . y) 540 (raise-syntax-error 'hash/dc 541 "expected either the keyword #:kind or #:immutable" 542 stx 543 #'x)])) 544 #`(build-hash/dc dom-ctc-expr 545 (λ (dom-id2) rng-ctc-expr) 546 (quote-module-name) 547 '#(dom-id rng-id #,(compute-quoted-src-expression #'rng-ctc-expr)) 548 #,(or immutable-expression #''dont-care) 549 #,(or kind-expression #''chaperone)))])) 550