1#lang racket/base 2 3(require "helpers.rkt" 4 "blame.rkt" 5 "prop.rkt" 6 "rand.rkt" 7 "generate-base.rkt" 8 "collapsible-common.rkt" 9 (submod "collapsible-common.rkt" properties) 10 "../../private/math-predicates.rkt" 11 racket/pretty 12 racket/list 13 (for-syntax racket/base 14 "helpers.rkt")) 15 16(provide coerce-contract 17 coerce-contracts 18 coerce-flat-contract 19 coerce-flat-contracts 20 coerce-chaperone-contract 21 coerce-chaperone-contracts 22 coerce-contract/f 23 24 build-compound-type-name 25 26 contract-stronger? 27 contract-equivalent? 28 list-contract? 29 30 contract-first-order 31 contract-first-order-passes? 32 33 prop:contracted prop:blame 34 impersonator-prop:contracted 35 impersonator-prop:blame 36 37 has-contract? value-contract 38 has-blame? value-blame 39 40 ;; for opters 41 check-flat-contract 42 check-flat-named-contract 43 44 ;; helpers for adding properties that check syntax uses 45 define/final-prop 46 define/subexpression-pos-prop 47 define/subexpression-pos-prop/name 48 49 make-predicate-contract 50 51 eq-contract? 52 eq-contract-val 53 equal-contract? 54 equal-contract-val 55 char-in/c 56 57 contract? 58 chaperone-contract? 59 impersonator-contract? 60 flat-contract? 61 62 contract-continuation-mark-key 63 with-contract-continuation-mark 64 collapsible-contract-continuation-mark-key 65 with-collapsible-contract-continuation-mark 66 67 contract-custom-write-property-proc 68 (rename-out [contract-custom-write-property-proc custom-write-property-proc]) 69 70 contract-projection 71 contract-val-first-projection ;; might return #f (if none) 72 contract-late-neg-projection ;; might return #f (if none) 73 get/build-val-first-projection ;; builds one if necc., using contract-projection 74 get/build-late-neg-projection 75 get/build-collapsible-late-neg-projection 76 warn-about-val-first? 77 78 contract-name 79 maybe-warn-about-val-first 80 81 set-some-basic-list-contracts! 82 set-some-basic-misc-contracts! 83 set-some-basic-integer-in-contracts! 84 85 contract-first-order-okay-to-give-up? 86 contract-first-order-try-less-hard 87 contract-first-order-only-try-so-hard 88 89 raise-predicate-blame-error-failure 90 91 n->th 92 nth-argument-of 93 nth-element-of 94 nth-case-of 95 96 false/c-contract 97 true/c-contract 98 99 contract-pos/neg-doubling 100 contract-pos/neg-doubling.2) 101 102(define (contract-custom-write-property-proc stct port mode) 103 (define (write-prefix) 104 (write-string "#<" port) 105 (cond 106 [(flat-contract-struct? stct) (write-string "flat-" port)] 107 [(chaperone-contract-struct? stct) (write-string "chaperone-" port)]) 108 (write-string "contract: " port)) 109 (define (write-suffix) 110 (write-string ">" port)) 111 (cond 112 [(boolean? mode) 113 (write-prefix) 114 (write-string (format "~.s" (contract-struct-name stct)) port) 115 (write-suffix)] 116 [else 117 (cond 118 [(zero? mode) 119 (print (contract-struct-name stct) port 1)] 120 [else 121 (write-prefix) 122 (print (contract-struct-name stct) port 1) 123 (write-suffix)])])) 124 125(define (contract? x) 126 (or (simple-flat-contract? x) 127 (and (coerce-contract/f x) #t))) 128 129(define (flat-contract? x) 130 (or (simple-flat-contract? x) 131 (let ([c (coerce-contract/f x)]) 132 (and c 133 (flat-contract-struct? c))))) 134 135(define (chaperone-contract? x) 136 (or (simple-flat-contract? x) 137 (let ([c (coerce-contract/f x)]) 138 (and c 139 (chaperone-contract-struct? c))))) 140 141(define (simple-flat-contract? x) 142 (or (and (procedure? x) (procedure-arity-includes? x 1)) 143 (null? x) 144 (boolean? x) 145 (symbol? x) 146 (keyword? x) 147 (char? x) 148 (bytes? x) 149 (string? x) 150 (number? x) 151 (regexp? x) 152 (byte-regexp? x))) 153 154(define (impersonator-contract? x) 155 (let ([c (coerce-contract/f x)]) 156 (and c 157 (not (flat-contract-struct? c)) 158 (not (chaperone-contract-struct? c))))) 159 160 161(define (has-contract? v) 162 (or (has-prop:contracted? v) 163 (has-impersonator-prop:contracted? v) 164 ;; TODO: I think this is the right check, but I'm not positive 165 (has-impersonator-prop:collapsible? v))) 166 167(define (value-contract v) 168 (cond 169 [(has-prop:contracted? v) 170 (get-prop:contracted v)] 171 [(has-impersonator-prop:contracted? v) 172 (get-impersonator-prop:contracted v)] 173 [(get-impersonator-prop:collapsible v #f) 174 => 175 (λ (p) 176 (collapsible-ho/c-latest-ctc (collapsible-property-c-c p)))] 177 [else #f])) 178 179(define (has-blame? v) 180 (or (has-prop:blame? v) 181 (has-impersonator-prop:blame? v) 182 ;; TODO: I think this check is ok, but I'm not sure ... 183 (has-impersonator-prop:collapsible? v))) 184 185(define (value-blame v) 186 (define bv 187 (cond 188 [(has-prop:blame? v) 189 (get-prop:blame v)] 190 [(has-impersonator-prop:blame? v) 191 (get-impersonator-prop:blame v)] 192 [(get-impersonator-prop:collapsible v #f) 193 => 194 (λ (p) 195 (define c-c (collapsible-property-c-c p)) 196 (cons 197 (collapsible-ho/c-latest-blame c-c) 198 (or (collapsible-ho/c-missing-party c-c) (collapsible-property-neg-party p))))] 199 [else #f])) 200 (cond 201 [(and (pair? bv) (blame? (car bv))) 202 (blame-add-missing-party (car bv) (cdr bv))] 203 [(blame? bv) bv] 204 [else #f])) 205 206(define-values (prop:contracted has-prop:contracted? get-prop:contracted) 207 (let-values ([(prop pred get) 208 (make-struct-type-property 209 'prop:contracted 210 (lambda (v si) 211 (if (number? v) 212 (let ([ref (cadddr si)]) 213 (lambda (s) (ref s v))) 214 (lambda (s) v))))]) 215 (values prop pred (λ (v) ((get v) v))))) 216 217(define-values (prop:blame has-prop:blame? get-prop:blame) 218 (let-values ([(prop pred get) 219 (make-struct-type-property 220 'prop:blame 221 (lambda (v si) 222 (if (number? v) 223 (let ([ref (cadddr si)]) 224 (lambda (s) (ref s v))) 225 (lambda (s) v))))]) 226 (values prop pred (λ (v) ((get v) v))))) 227 228(define-values (impersonator-prop:contracted 229 has-impersonator-prop:contracted? 230 get-impersonator-prop:contracted) 231 (make-impersonator-property 'impersonator-prop:contracted)) 232 233(define-values (impersonator-prop:blame 234 has-impersonator-prop:blame? 235 get-impersonator-prop:blame) 236 (make-impersonator-property 'impersonator-prop:blame)) 237 238(define (contract-first-order c) 239 (contract-struct-first-order 240 (coerce-contract 'contract-first-order c))) 241 242(define (contract-first-order-passes? c v) 243 ((contract-struct-first-order 244 (coerce-contract 'contract-first-order-passes? c)) 245 v)) 246 247(define (list-contract? raw-c) 248 (define c (coerce-contract/f raw-c)) 249 (and c (contract-struct-list-contract? c))) 250 251;; contract-stronger? : contract contract -> boolean 252;; indicates if one contract is stronger (ie, likes fewer values) than another 253;; this is not a total order. 254(define (contract-stronger? a b) 255 (contract-struct-stronger? (coerce-contract 'contract-stronger? a) 256 (coerce-contract 'contract-stronger? b))) 257 258(define (contract-equivalent? a b) 259 (contract-struct-equivalent? (coerce-contract 'contract-equivalent? a) 260 (coerce-contract 'contract-equivalent? b))) 261 262;; coerce-flat-contract : symbol any/c -> contract 263(define (coerce-flat-contract name x) 264 (define ctc (coerce-contract/f x)) 265 (unless (flat-contract-struct? ctc) 266 (raise-argument-error name "flat-contract?" x)) 267 ctc) 268 269;; coerce-flat-contacts : symbol (listof any/c) -> (listof flat-contract) 270;; like coerce-contracts, but insists on flat-contracts 271(define (coerce-flat-contracts name xs) 272 (for/list ([x (in-list xs)] 273 [i (in-naturals)]) 274 (define ctc (coerce-contract/f x)) 275 (unless (flat-contract-struct? ctc) 276 (raise-argument-error name 277 "flat-contract?" 278 i 279 xs)) 280 ctc)) 281 282;; coerce-chaperone-contract : symbol any/c -> contract 283(define (coerce-chaperone-contract name x) 284 (define ctc (coerce-contract/f x)) 285 (unless (chaperone-contract-struct? ctc) 286 (raise-argument-error 287 name 288 "chaperone-contract?" 289 x)) 290 ctc) 291 292;; coerce-chaperone-contacts : symbol (listof any/c) -> (listof flat-contract) 293;; like coerce-contracts, but insists on chaperone-contracts 294(define (coerce-chaperone-contracts name xs) 295 (for/list ([x (in-list xs)] 296 [i (in-naturals)]) 297 (define ctc (coerce-contract/f x)) 298 (unless (chaperone-contract-struct? ctc) 299 (apply raise-argument-error 300 name 301 "chaperone-contract?" 302 i 303 xs)) 304 ctc)) 305 306;; coerce-contract : symbol any/c -> contract 307(define (coerce-contract name x) 308 (or (coerce-contract/f x) 309 (raise-argument-error name 310 "contract?" 311 x))) 312 313;; coerce-contracts : symbol (listof any) -> (listof contract) 314;; turns all of the arguments in 'xs' into contracts 315;; the error messages assume that the function named by 'name' 316;; got 'xs' as it argument directly 317(define (coerce-contracts name xs) 318 (for/list ([x (in-list xs)] 319 [i (in-naturals)]) 320 (define ctc (coerce-contract/f x)) 321 (unless ctc 322 (apply raise-argument-error 323 name 324 "contract?" 325 i 326 xs)) 327 ctc)) 328 329(define-values (name-default name-default?) 330 (let () 331 (struct name-default ()) 332 (values (name-default) name-default?))) 333 334;; these definitions work around a cyclic 335;; dependency. When we coerce a value to a contract, 336;; we want to use (listof any/c) for list?, but 337;; the files are not set up for that, so we just 338;; bang it in here and use it only after it's been banged in. 339;; ditto for: (cons/c any/c any/c), (list/c), and (between/c -inf.0 +inf.0) 340;; the selectors and predicate for `between/c-s` are used 341;; to get contract-stronger right for numeric constants 342(define listof-any #f) 343(define consc-anyany #f) 344(define list/c-empty #f) 345(define (set-some-basic-list-contracts! l p mt) 346 (set! listof-any l) 347 (set! consc-anyany p) 348 (set! list/c-empty mt)) 349(define between/c-inf+inf-as-real? #f) 350(define renamed-between/c #f) 351(define between/c-s? #f) 352(define between/c-s-low #f) 353(define between/c-s-high #f) 354(define (set-some-basic-misc-contracts! b r-b b/c-s? b/c-s-l b/c-s-h) 355 (set! between/c-inf+inf-as-real? b) 356 (set! renamed-between/c r-b) 357 (set! between/c-s? b/c-s?) 358 (set! between/c-s-low b/c-s-l) 359 (set! between/c-s-high b/c-s-h)) 360(define integer-in-ff #f) 361(define integer-in-0f #f) 362(define integer-in-1f #f) 363(define renamed-integer-in #f) 364(define (set-some-basic-integer-in-contracts! r-ii ff 0f 1f) 365 (set! renamed-integer-in r-ii) 366 (set! integer-in-ff ff) 367 (set! integer-in-0f 0f) 368 (set! integer-in-1f 1f)) 369 370;; coerce-contract/f : any -> (or/c #f contract?) 371;; returns #f if the argument could not be coerced to a contract 372(define (coerce-contract/f x [name name-default]) 373 (cond 374 [(coerce-simple-value name x) => values] 375 [(name-default? name) (and (contract-struct? x) x)] 376 [(predicate-contract? x) 377 (struct-copy predicate-contract x [name name])] 378 [(eq-contract? x) (make-eq-contract (eq-contract-val x) name)] 379 [(equal-contract? x) (make-eq-contract (equal-contract-val x) name)] 380 [(=-contract? x) (make-=-contract (=-contract-val x) name)] 381 [(regexp/c? x) (make-regexp/c (regexp/c-reg x) name)] 382 [else #f])) 383 384 385(define (coerce-simple-value name x) 386 (cond 387 [(contract-struct? x) #f] ;; this has to come first, since some of these are procedure?. 388 [(and (procedure? x) (procedure-arity-includes? x 1)) 389 (cond 390 [(chaperone-of? x null?) list/c-empty] 391 [(chaperone-of? x empty?) list/c-empty] 392 [(chaperone-of? x list?) 393 (unless listof-any 394 (error 'coerce-contract/f::listof-any "too soon!")) 395 listof-any] 396 [(chaperone-of? x boolean?) boolean?/c] 397 [(or (chaperone-of? x pair?) 398 (chaperone-of? x cons?)) 399 (unless consc-anyany 400 (error 'coerce-contract/f::consc-anyany "too soon!")) 401 consc-anyany] 402 [(chaperone-of? x real?) 403 (unless between/c-inf+inf-as-real? 404 (error 'coerce-contract/f::between/c-inf+inf "too soon!")) 405 (if (name-default? name) 406 between/c-inf+inf-as-real? 407 (renamed-between/c -inf.0 +inf.0 name))] 408 [(chaperone-of? x exact-positive-integer?) 409 (if (name-default? name) integer-in-1f (renamed-integer-in 1 #f name))] 410 [(chaperone-of? x exact-nonnegative-integer?) 411 (if (name-default? name) integer-in-0f (renamed-integer-in 0 #f name))] 412 [(chaperone-of? x natural?) 413 (if (name-default? name) integer-in-0f (renamed-integer-in 0 #f name))] 414 [(chaperone-of? x exact-integer?) 415 (if (name-default? name) integer-in-ff (renamed-integer-in #f #f name))] 416 [else 417 (make-predicate-contract (if (name-default? name) 418 (or (object-name x) '???) 419 name) 420 x 421 #f 422 (or (struct-predicate-procedure? x) 423 (memq x the-known-good-contracts)))])] 424 [(null? x) 425 (unless list/c-empty 426 (error 'coerce-contract/f::list/c-empty "too soon!")) 427 list/c-empty] 428 [(not x) false/c-contract] 429 [(equal? x #t) true/c-contract] 430 [(or (symbol? x) (boolean? x) (keyword? x)) 431 (make-eq-contract x 432 (if (name-default? name) 433 (if (or (null? x) 434 (symbol? x)) 435 `',x 436 x) 437 name))] 438 [(char? x) (make-char-in/c x x)] 439 [(or (bytes? x) (string? x) (and (real? x) (nan? x))) 440 (make-equal-contract x (if (name-default? name) x name))] 441 [(number? x) 442 (make-=-contract x (if (name-default? name) x name))] 443 [(or (regexp? x) (byte-regexp? x)) (make-regexp/c x (if (name-default? name) x name))] 444 [else #f])) 445 446(define the-known-good-contracts 447 (let-syntax ([m (λ (x) #`(list #,@(known-good-contracts)))]) 448 (m))) 449 450(define-syntax (define/final-prop stx) 451 (syntax-case stx () 452 [(_ header bodies ...) 453 (with-syntax ([ctc 454 (syntax-case #'header () 455 [id 456 (identifier? #'id) 457 #'id] 458 [(id1 . rest) 459 (identifier? #'id1) 460 #'id1] 461 [_ 462 (raise-syntax-error #f 463 "malformed header position" 464 stx 465 #'header)])]) 466 (with-syntax ([ctc/proc (string->symbol (format "~a/proc" (syntax-e #'ctc)))]) 467 #'(begin 468 (define ctc/proc 469 (let () 470 (define header bodies ...) 471 ctc)) 472 (define-syntax (ctc stx) 473 (syntax-case stx () 474 [x 475 (identifier? #'x) 476 (syntax-property 477 #'ctc/proc 478 'racket/contract:contract 479 (vector (gensym 'ctc) 480 (list stx) 481 '()))] 482 [(_ margs (... ...)) 483 (with-syntax ([app (datum->syntax stx '#%app)]) 484 (syntax-property 485 #'(app ctc/proc margs (... ...)) 486 'racket/contract:contract 487 (vector (gensym 'ctc) 488 (list (car (syntax-e stx))) 489 '())))])))))])) 490 491(define-syntax (define/subexpression-pos-prop/name stx) 492 (syntax-case stx () 493 [(_ ctc/proc header bodies ...) 494 (with-syntax ([ctc (if (identifier? #'header) 495 #'header 496 (car (syntax-e #'header)))]) 497 #'(begin 498 (define ctc/proc 499 (let () 500 (define header bodies ...) 501 ctc)) 502 (define-syntax (ctc stx) 503 (syntax-case stx () 504 [x 505 (identifier? #'x) 506 (syntax-property 507 #'ctc/proc 508 'racket/contract:contract 509 (vector (gensym 'ctc) 510 (list stx) 511 '()))] 512 [(_ margs (... ...)) 513 (let ([this-one (gensym 'ctc)]) 514 (with-syntax ([(margs (... ...)) 515 (map (λ (x) (syntax-property x 516 'racket/contract:positive-position 517 this-one)) 518 (syntax->list #'(margs (... ...))))] 519 [app (datum->syntax stx '#%app)]) 520 (syntax-property 521 (syntax/loc stx (app ctc/proc margs (... ...))) 522 'racket/contract:contract 523 (vector this-one 524 (list (car (syntax-e stx))) 525 '()))))]))))])) 526 527(define-syntax (define/subexpression-pos-prop stx) 528 (syntax-case stx () 529 [(_ header bodies ...) 530 (with-syntax ([ctc (if (identifier? #'header) 531 #'header 532 (car (syntax-e #'header)))]) 533 (with-syntax ([ctc/proc (string->symbol (format "~a/proc" (syntax-e #'ctc)))]) 534 #'(define/subexpression-pos-prop/name ctc/proc header bodies ...)))])) 535 536;; build-compound-type-name : (union contract symbol) ... -> (-> sexp) 537(define (build-compound-type-name . fs) 538 (for/list ([sub (in-list fs)]) 539 (if (contract-struct? sub) (contract-struct-name sub) sub))) 540 541 542; 543; 544; ; ;;; 545; ;;; 546; ;;;;; ;;;;; ;;; ;;; ;; ;;; ;;; ;;; 547; ;;;;;;;;;;;; ;;;;; ;;;;;;;;;;; ;;; ;;;;; 548; ;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;; 549; ;;;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; 550; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;; 551; ;;; ;;; ;;;; ;;;;; ;;; ;;; ;;; ;;; ;;;;; 552; ;;;;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; 553; 554; 555; 556; 557; 558; ; ; 559; ;;; ;;; 560; ;;; ;;; ;;; ;; ;;;; ;;; ;;;;;;; ;;; ;;;; ;;;; 561; ;;;;; ;;;;; ;;;;;;; ;;;; ;;;;;;;;;;;; ;;;;; ;;;; ;;; ;; 562; ;;; ;; ;;; ;;; ;;; ;;; ;;; ;;; ;; ;;; ;;; ;; ;;; ;;; 563; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;;;; ;;; ;;; ;;;; 564; ;;; ;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;; ;;; ;;; 565; ;;;;; ;;;;; ;;; ;;; ;;;; ;;; ;;; ;;; ;;;;; ;;;; ;; ;;; 566; ;;; ;;; ;;; ;;; ;;; ;;; ;;;;;; ;;; ;;; ;;;; 567; 568; 569; 570; 571 572(define-struct eq-contract (val name) 573 #:property prop:custom-write contract-custom-write-property-proc 574 #:property prop:flat-contract 575 (build-flat-contract-property 576 #:trusted trust-me 577 #:first-order (λ (ctc) (λ (x) (eq? (eq-contract-val ctc) x))) 578 #:name (λ (ctc) (eq-contract-name ctc)) 579 #:generate 580 (λ (ctc) 581 (define v (eq-contract-val ctc)) 582 (λ (fuel) (λ () v))) 583 #:stronger 584 (λ (this that) 585 (define this-val (eq-contract-val this)) 586 (or (and (eq-contract? that) 587 (eq? this-val (eq-contract-val that))) 588 (and (predicate-contract? that) 589 (predicate-contract-sane? that) 590 ((predicate-contract-pred that) this-val)))) 591 #:equivalent 592 (λ (this that) 593 (define this-val (eq-contract-val this)) 594 (and (eq-contract? that) 595 (eq? this-val (eq-contract-val that)))) 596 #:list-contract? (λ (c) (null? (eq-contract-val c))))) 597 598(define false/c-contract (make-eq-contract #f #f)) 599(define true/c-contract (make-eq-contract #t #t)) 600 601(define-struct equal-contract (val name) 602 #:property prop:custom-write contract-custom-write-property-proc 603 #:property prop:flat-contract 604 (build-flat-contract-property 605 #:trusted trust-me 606 #:first-order (λ (ctc) (λ (x) (equal? (equal-contract-val ctc) x))) 607 #:name (λ (ctc) (equal-contract-name ctc)) 608 #:stronger 609 (λ (this that) 610 (define this-val (equal-contract-val this)) 611 (or (and (equal-contract? that) 612 (equal? this-val (equal-contract-val that))) 613 (and (predicate-contract? that) 614 (predicate-contract-sane? that) 615 ((predicate-contract-pred that) this-val)))) 616 #:equivalent 617 (λ (this that) 618 (define this-val (equal-contract-val this)) 619 (and (equal-contract? that) 620 (equal? this-val (equal-contract-val that)))) 621 #:generate 622 (λ (ctc) 623 (define v (equal-contract-val ctc)) 624 (λ (fuel) (λ () v))))) 625 626(define-struct =-contract (val name) 627 #:property prop:custom-write contract-custom-write-property-proc 628 #:property prop:flat-contract 629 (build-flat-contract-property 630 #:trusted trust-me 631 #:first-order (λ (ctc) (λ (x) (and (number? x) (= (=-contract-val ctc) x)))) 632 #:name (λ (ctc) (=-contract-name ctc)) 633 #:stronger 634 (λ (this that) 635 (define this-val (=-contract-val this)) 636 (or (and (=-contract? that) 637 (= this-val (=-contract-val that))) 638 (and (between/c-s? that) 639 (<= (between/c-s-low that) this-val (between/c-s-high that))) 640 (and (predicate-contract? that) 641 (predicate-contract-sane? that) 642 ((predicate-contract-pred that) this-val)))) 643 #:equivalent 644 (λ (this that) 645 (define this-val (=-contract-val this)) 646 (or (and (=-contract? that) 647 (= this-val (=-contract-val that))) 648 (and (between/c-s? that) 649 (= (between/c-s-low that) this-val (between/c-s-high that))))) 650 #:generate 651 (λ (ctc) 652 (define v (=-contract-val ctc)) 653 (λ (fuel) 654 (cond 655 [(zero? v) 656 ;; zero has a whole bunch of different numbers that 657 ;; it could be, so just pick one of them at random 658 (λ () (oneof all-zeros))] 659 [else 660 (λ () 661 (case (random 10) 662 [(0) 663 ;; try the inexact/exact variant (if there is one) 664 (cond 665 [(exact? v) 666 (define iv (exact->inexact v)) 667 (if (= iv v) iv v)] 668 [(and (inexact? v) (not (infinite? v)) (not (nan? v))) 669 (define ev (inexact->exact v)) 670 (if (= ev v) ev v)] 671 [else v])] 672 [(1) 673 ;; try to add an inexact imaginary part 674 (define c (+ v 0+0.0i)) 675 (if (= c v) c v)] 676 [else 677 ;; otherwise, just stick with the original number (80% of the time) 678 v]))]))))) 679 680(define-struct char-in/c (low high) 681 #:property prop:custom-write contract-custom-write-property-proc 682 #:property prop:flat-contract 683 (build-flat-contract-property 684 #:trusted trust-me 685 #:first-order 686 (λ (ctc) 687 (define low (char-in/c-low ctc)) 688 (define high (char-in/c-high ctc)) 689 (λ (x) 690 (and (char? x) 691 (char<=? low x high)))) 692 #:name (λ (ctc) 693 (define low (char-in/c-low ctc)) 694 (define high (char-in/c-high ctc)) 695 (if (equal? low high) 696 low 697 `(char-in ,low ,high))) 698 #:stronger 699 (λ (this that) 700 (cond 701 [(char-in/c? that) 702 (define this-low (char-in/c-low this)) 703 (define this-high (char-in/c-high this)) 704 (define that-low (char-in/c-low that)) 705 (define that-high (char-in/c-high that)) 706 (and (char<=? that-low this-low) 707 (char<=? this-high that-high))] 708 [else #f])) 709 #:equivalent 710 (λ (this that) 711 (cond 712 [(char-in/c? that) 713 (define this-low (char-in/c-low this)) 714 (define this-high (char-in/c-high this)) 715 (define that-low (char-in/c-low that)) 716 (define that-high (char-in/c-high that)) 717 (and (char=? that-low this-low) 718 (char=? this-high that-high))] 719 [else #f])) 720 #:generate 721 (λ (ctc) 722 (define low (char->integer (char-in/c-low ctc))) 723 (define high (char->integer (char-in/c-high ctc))) 724 (define delta (+ (- high low) 1)) 725 (λ (fuel) 726 (and (>= delta 1) 727 (λ () 728 (integer->char (+ low (random delta))))))))) 729 730(define (regexp/c-equivalent this that) 731 (and (regexp/c? that) 732 (equal? (regexp/c-reg this) (regexp/c-reg that)))) 733 734(define-struct regexp/c (reg name) 735 #:property prop:custom-write contract-custom-write-property-proc 736 #:property prop:flat-contract 737 (build-flat-contract-property 738 #:trusted trust-me 739 #:first-order 740 (λ (ctc) 741 (define reg (regexp/c-reg ctc)) 742 (λ (x) 743 (and (or (string? x) (bytes? x)) 744 (regexp-match? reg x)))) 745 #:name (λ (ctc) (regexp/c-reg ctc)) 746 #:stronger regexp/c-equivalent 747 #:equivalent regexp/c-equivalent)) 748 749(define (predicate-contract-equivalent this that) 750 (and (predicate-contract? that) 751 (procedure-closure-contents-eq? (predicate-contract-pred this) 752 (predicate-contract-pred that)))) 753 754;; sane? : boolean -- indicates if we know that the predicate is well behaved 755;; (for now, basically amounts to trusting primitive procedures) 756(define-struct predicate-contract (name pred generate sane?) 757 #:property prop:custom-write contract-custom-write-property-proc 758 #:property prop:flat-contract 759 (build-flat-contract-property 760 #:trusted trust-me 761 #:stronger predicate-contract-equivalent 762 #:equivalent predicate-contract-equivalent 763 #:name (λ (ctc) (predicate-contract-name ctc)) 764 #:first-order (λ (ctc) (predicate-contract-pred ctc)) 765 #:late-neg-projection 766 (λ (ctc) 767 (define p? (predicate-contract-pred ctc)) 768 (define name (predicate-contract-name ctc)) 769 (λ (blame) 770 (procedure-specialize 771 (λ (v neg-party) 772 (if (p? v) 773 v 774 (raise-predicate-blame-error-failure blame v neg-party name)))))) 775 #:generate (λ (ctc) 776 (let ([generate (predicate-contract-generate ctc)]) 777 (cond 778 [generate generate] 779 [else 780 (define built-in-generator 781 (find-generate (predicate-contract-pred ctc) 782 (predicate-contract-name ctc))) 783 (λ (fuel) 784 (and built-in-generator 785 (λ () (built-in-generator fuel))))]))) 786 #:list-contract? (λ (ctc) (or (equal? (predicate-contract-pred ctc) null?) 787 (equal? (predicate-contract-pred ctc) empty?))))) 788 789(define (raise-predicate-blame-error-failure blame v neg-party predicate-name) 790 (raise-blame-error blame v #:missing-party neg-party 791 '(expected: "~s" given: "~e") 792 predicate-name 793 v)) 794 795(define (check-flat-named-contract predicate) (coerce-flat-contract 'flat-named-contract predicate)) 796(define (check-flat-contract predicate) (coerce-flat-contract 'flat-contract predicate)) 797(define (build-flat-contract name pred [generate #f]) 798 (make-predicate-contract name pred generate #f)) 799 800(define boolean?/c (make-predicate-contract 'boolean? boolean? #f #t)) 801 802(define (contract-name ctc) 803 (contract-struct-name 804 (coerce-contract 'contract-name ctc))) 805 806(define (contract-projection ctc) 807 (get/build-projection 808 (coerce-contract 'contract-projection ctc))) 809(define (contract-val-first-projection ctc) 810 (get/build-val-first-projection 811 (coerce-contract 'contract-projection ctc))) 812(define (contract-late-neg-projection ctc) 813 (get/build-late-neg-projection 814 (coerce-contract 'contract-projection ctc))) 815 816(define-logger racket/contract) 817 818(define (get/build-collapsible-late-neg-projection ctc) 819 (cond 820 [(contract-struct-collapsible-late-neg-projection ctc) => values] 821 [else 822 (define lnp (get/build-late-neg-projection ctc)) 823 (λ (blame) 824 (define proj (lnp blame)) 825 (values proj 826 (build-collapsible-leaf proj ctc blame)))])) 827 828(define (get/build-late-neg-projection ctc) 829 (cond 830 [(contract-struct-late-neg-projection ctc) => values] 831 [else 832 (log-racket/contract-info "no late-neg-projection for ~s" ctc) 833 (cond 834 [(contract-struct-collapsible-late-neg-projection ctc) => 835 (lambda (f) 836 (lambda (blame) 837 (define-values (proj _) (f blame)) 838 proj))] 839 [(contract-struct-projection ctc) 840 => 841 (λ (projection) 842 (projection->late-neg-projection projection))] 843 [(contract-struct-val-first-projection ctc) 844 => 845 (λ (val-first-projection) 846 (val-first-projection->late-neg-projection val-first-projection))] 847 [else 848 (first-order->late-neg-projection (contract-struct-first-order ctc) 849 (contract-struct-name ctc))])])) 850 851(define (projection->late-neg-projection proj) 852 (λ (b) 853 (λ (x neg-party) 854 ((proj (blame-add-missing-party b neg-party)) x)))) 855(define (val-first-projection->late-neg-projection vf-proj) 856 (λ (b) 857 (define vf-val-accepter (vf-proj b)) 858 (λ (x neg-party) 859 ((vf-val-accepter x) neg-party)))) 860(define (first-order->late-neg-projection p? name) 861 (λ (b) 862 (λ (x neg-party) 863 (if (p? x) 864 x 865 (raise-blame-error 866 b x #:missing-party neg-party 867 '(expected: "~a" given: "~e") 868 name 869 x))))) 870 871(define warn-about-val-first? (make-parameter #t)) 872(define (maybe-warn-about-val-first ctc) 873 (when (warn-about-val-first?) 874 (log-racket/contract-info 875 "building val-first-projection of contract ~s for~a" 876 ctc 877 (build-context)))) 878 879(define (get/build-val-first-projection ctc) 880 (cond 881 [(contract-struct-val-first-projection ctc) => values] 882 [else 883 (maybe-warn-about-val-first ctc) 884 (late-neg-projection->val-first-projection 885 (get/build-late-neg-projection ctc))])) 886(define (late-neg-projection->val-first-projection lnp) 887 (λ (b) 888 (define val+neg-party-accepter (lnp b)) 889 (λ (x) 890 (λ (neg-party) 891 (val+neg-party-accepter x neg-party))))) 892 893(define (get/build-projection ctc) 894 (cond 895 [(contract-struct-projection ctc) => values] 896 [else 897 (log-racket/contract-warning 898 "building projection of contract ~s for~a" 899 ctc 900 (build-context)) 901 (late-neg-projection->projection 902 (get/build-late-neg-projection ctc))])) 903(define (late-neg-projection->projection lnp) 904 (λ (b) 905 (define val+np-acceptor (lnp b)) 906 (λ (x) 907 (val+np-acceptor x #f)))) 908 909 910(define contract-first-order-okay-to-give-up-key (gensym 'contract-first-order-okay-to-give-up-key)) 911(define (contract-first-order-okay-to-give-up?) 912 (zero? (continuation-mark-set-first #f 913 contract-first-order-okay-to-give-up-key 914 1))) 915(define-syntax-rule 916 (contract-first-order-try-less-hard e) 917 (contract-first-order-try-less-hard/proc (λ () e))) 918(define (contract-first-order-try-less-hard/proc th) 919 (define cv (continuation-mark-set-first #f contract-first-order-okay-to-give-up-key)) 920 (if cv 921 (with-continuation-mark contract-first-order-okay-to-give-up-key (if (= cv 0) 0 (- cv 1)) 922 (th)) 923 (th))) 924(define-syntax-rule 925 (contract-first-order-only-try-so-hard n e) 926 (with-continuation-mark contract-first-order-okay-to-give-up-key n e)) 927 928;; Key used by the continuation mark that holds blame information for the current contract. 929;; That information is consumed by the contract profiler. 930(define contract-continuation-mark-key 931 (make-continuation-mark-key 'contract)) 932 933;; Instrumentation strategy: 934;; - add instrumentation at entry points to the contract system: 935;; - `contract` (`apply-contract`, really) 936;; - `contract-out` (`do-partial-app`, really) 937;; - all others go through one of the above 938;; that instrumentation picks up "top-level" flat contracts (i.e., not part of 939;; some higher-order contract) and the "eager" parts of higher-order contracts 940;; - add instrumentation inside chaperones/impersonators created by projections 941;; that instrumentation picks up the deferred work of higher-order contracts 942;; - add instrumentation to `plus-one-arity-functions` 943;; those perform checking, but don't rely on chaperones 944;; they exist for -> and ->*, and are partially implemented for ->i 945;; TODO once they're fully implemented for ->i, will need to instrument them 946(define-syntax-rule (with-contract-continuation-mark payload code ...) 947 (begin 948 ;; ;; When debugging a missing blame party error, turn this on, then run 949 ;; ;; the contract test suite. It should find the problematic combinator. 950 ;; (unless (or (pair? payload) (not (blame-missing-party? payload))) 951 ;; (error "internal error: missing blame party" payload)) 952 (with-continuation-mark contract-continuation-mark-key payload 953 (let () code ...)))) 954 955(define collapsible-contract-continuation-mark-key 956 (make-continuation-mark-key 'collapsible-contract)) 957 958(define-syntax-rule (with-collapsible-contract-continuation-mark code ...) 959 (with-continuation-mark collapsible-contract-continuation-mark-key #t 960 (let () code ...))) 961 962(define (n->th n) 963 (string-append 964 (number->string n) 965 (case (remainder n 100) 966 [(11 12 13) "th"] 967 [else 968 (case (modulo n 10) 969 [(1) "st"] 970 [(2) "nd"] 971 [(3) "rd"] 972 [else "th"])]))) 973 974(define (nth-element-of/alloc n) 975 (format "the ~a element of" (n->th n))) 976(define (nth-argument-of/alloc n) 977 (format "the ~a argument of" (n->th n))) 978(define (nth-case-of/alloc n) 979 (format "the ~a case of" (n->th n))) 980 981(define-syntax (define-precompute/simple stx) 982 (syntax-case stx () 983 [(_ fn fn/alloc lower-bound-stx upper-bound-stx) 984 (let () 985 (define lower-bound (syntax-e #'lower-bound-stx)) 986 (define upper-bound (syntax-e #'upper-bound-stx)) 987 (define (n->id n) 988 (string->symbol (format "precomputed-~a" n))) 989 #`(begin 990 #,@(for/list ([i (in-range lower-bound (+ upper-bound 1))]) 991 #`(define #,(n->id i) (fn/alloc #,i))) 992 (define (fn n) 993 (case n 994 #,@(for/list ([i (in-range lower-bound (+ upper-bound 1))]) 995 #`[(#,i) #,(n->id i)]) 996 [else (fn/alloc n)]))))])) 997 998(define-precompute/simple nth-element-of nth-element-of/alloc 0 10) 999(define-precompute/simple nth-argument-of nth-argument-of/alloc 1 7) 1000(define-precompute/simple nth-case-of nth-case-of/alloc 1 2) 1001 1002(define-syntax-rule 1003 (contract-pos/neg-doubling e1 e2) 1004 (contract-pos/neg-doubling/proc (λ () e1) (λ () e2))) 1005(define-syntax-rule 1006 (contract-pos/neg-doubling.2 e1 e2) 1007 (contract-pos/neg-doubling.2/proc (λ () e1) (λ () e2))) 1008(define doubling-cm-key (gensym 'racket/contract-doubling-mark)) 1009(define (contract-pos/neg-doubling/proc t1 t2) 1010 (define depth 1011 (or (continuation-mark-set-first (current-continuation-marks) 1012 doubling-cm-key) 1013 0)) 1014 (cond 1015 [(> depth 5) 1016 (values #f t1 t2)] 1017 [else 1018 (with-continuation-mark doubling-cm-key (+ depth 1) 1019 (values #t (t1) (t2)))])) 1020(define (contract-pos/neg-doubling.2/proc t1 t2) 1021 (define depth 1022 (or (continuation-mark-set-first (current-continuation-marks) 1023 doubling-cm-key) 1024 0)) 1025 (cond 1026 [(> depth 5) 1027 (values #f t1 #f t2 #f)] 1028 [else 1029 (with-continuation-mark doubling-cm-key (+ depth 1) 1030 (let () 1031 (define-values (t11 t12) (t1)) 1032 (define-values (t21 t22) (t2)) 1033 (values #t t11 t12 t21 t22)))])) 1034