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