diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/contract-rand-test.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/contract-rand-test.rkt index 1a79d900bf..29dd27fdc6 100644 --- a/pkgs/racket-pkgs/racket-test/tests/racket/contract-rand-test.rkt +++ b/pkgs/racket-pkgs/racket-test/tests/racket/contract-rand-test.rkt @@ -37,6 +37,7 @@ (check-not-exn (λ () (test-contract-generation (=/c 0)))) (check-not-exn (λ () (test-contract-generation (=/c 0.0)))) (check-not-exn (λ () (test-contract-generation (or/c boolean? boolean?)))) +(check-not-exn (λ () (test-contract-generation (cons/c integer? boolean?)))) (check-not-exn (λ () (test-contract-generation any/c))) (check-not-exn (λ () (test-contract-generation (listof boolean?)))) @@ -45,6 +46,14 @@ (check-not-exn (λ () (test-contract-generation (list/c boolean? number?)))) (check-not-exn (λ () ((car (test-contract-generation (list/c (-> number? number?)))) 0))) +(check-not-exn + (λ () + (test-contract-generation + (flat-rec-contract + even-length-list/c + (or/c (cons/c any/c (cons/c any/c even-length-list/c)) + '()))))) + (check-exn exn:fail? (λ () ((test-contract-generation (-> char? integer?)) 0))) (check-not-exn (λ () ((test-contract-generation (-> integer? integer?)) 1))) (check-not-exn (λ () ((test-contract-generation (-> (-> integer? integer?) boolean?)) +))) diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/contract/name.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/contract/name.rkt index 861d24f481..e898a8ea6f 100644 --- a/pkgs/racket-pkgs/racket-test/tests/racket/contract/name.rkt +++ b/pkgs/racket-pkgs/racket-test/tests/racket/contract/name.rkt @@ -121,7 +121,7 @@ (test-name '(unconstrained-domain-> number?) (unconstrained-domain-> number?)) (test-name '(or/c) (or/c)) - (test-name '(or/c '()) (or/c '())) + (test-name 'integer? (or/c integer?)) (test-name '(or/c integer? gt0?) (or/c integer? (let ([gt0? (lambda (x) (> x 0))]) gt0?))) (test-name '(or/c integer? boolean?) (or/c (flat-contract integer?) diff --git a/racket/collects/racket/contract/base.rkt b/racket/collects/racket/contract/base.rkt index 4cf304e802..a43a0ee0d4 100644 --- a/racket/collects/racket/contract/base.rkt +++ b/racket/collects/racket/contract/base.rkt @@ -51,6 +51,7 @@ check-unary-between/c random-any/c) symbols or/c one-of/c + flat-rec-contract provide/contract ;(for-syntax make-provide/contract-transformer) ;; not documented! contract-out diff --git a/racket/collects/racket/contract/private/misc.rkt b/racket/collects/racket/contract/private/misc.rkt index 3525c2b5ce..e78a0138a5 100644 --- a/racket/collects/racket/contract/private/misc.rkt +++ b/racket/collects/racket/contract/private/misc.rkt @@ -10,8 +10,7 @@ "generate.rkt" "generate-base.rkt") -(provide flat-rec-contract - flat-murec-contract +(provide flat-murec-contract and/c not/c =/c >=/c <=/c /c between/c @@ -62,29 +61,6 @@ random-any/c) -(define-syntax (flat-rec-contract stx) - (syntax-case stx () - [(_ name ctc ...) - (identifier? (syntax name)) - (with-syntax ([(ctc-id ...) (generate-temporaries (syntax (ctc ...)))] - [(pred-id ...) (generate-temporaries (syntax (ctc ...)))]) - (syntax - (let* ([pred flat-rec-contract/init] - [name (flat-contract (let ([name (λ (x) (pred x))]) name))]) - (let ([ctc-id (coerce-flat-contract 'flat-rec-contract ctc)] ...) - (set! pred - (let ([pred-id (flat-contract-predicate ctc-id)] ...) - (λ (x) - (or (pred-id x) ...)))) - name))))] - [(_ name ctc ...) - (raise-syntax-error 'flat-rec-contract - "expected first argument to be an identifier" - stx - (syntax name))])) - -(define (flat-rec-contract/init x) (error 'flat-rec-contract "applied too soon")) - (define-syntax (flat-murec-contract stx) (syntax-case stx () [(_ ([name ctc ...] ...) body1 body ...) @@ -563,19 +539,30 @@ #:name ctc-name #:first-order fo-check #:val-first-projection (val-first-ho-check (λ (v a d) v)) - #:projection (ho-check (λ (v a d) v)))] + #:projection (ho-check (λ (v a d) v)) + #:generate (cons/c-generate ctc-car ctc-cdr))] [(and (chaperone-contract? ctc-car) (chaperone-contract? ctc-cdr)) (make-chaperone-contract #:name ctc-name #:first-order fo-check #:val-first-projection (val-first-ho-check (λ (v a d) (cons a d))) - #:projection (ho-check (λ (v a d) (cons a d))))] + #:projection (ho-check (λ (v a d) (cons a d))) + #:generate (cons/c-generate ctc-car ctc-cdr))] [else (make-contract #:name ctc-name #:first-order fo-check #:val-first-projection (val-first-ho-check (λ (v a d) (cons a d))) - #:projection (ho-check (λ (v a d) (cons a d))))])))) + #:projection (ho-check (λ (v a d) (cons a d))) + #:generate (cons/c-generate ctc-car ctc-cdr))])))) + +(define (cons/c-generate ctc-car ctc-cdr) + (λ (fuel) + (define car-gen (generate/choose ctc-car fuel)) + (define cdr-gen (generate/choose ctc-cdr fuel)) + (and car-gen + cdr-gen + (λ () (cons (car-gen) (cdr-gen)))))) (define (raise-not-cons-blame-error blame val #:missing-party [missing-party #f]) (raise-blame-error @@ -946,13 +933,15 @@ (oneof (hash-keys predicate-generator-table))) fuel)) (define (any/c-procedure env fuel) - (procedure-reduce-arity - (λ args - (apply - values - (for/list ([i (in-range (rand-nat))]) - (random-any/c env fuel)))) - (rand-nat))) + (procedure-rename + (procedure-reduce-arity + (λ args + (apply + values + (for/list ([i (in-range (rand-nat))]) + (random-any/c env fuel)))) + (rand-nat)) + 'random-any/c-generated-procedure)) (define-struct any/c () #:property prop:custom-write custom-write-property-proc diff --git a/racket/collects/racket/contract/private/opters.rkt b/racket/collects/racket/contract/private/opters.rkt index 55f66c9572..cef53569e3 100644 --- a/racket/collects/racket/contract/private/opters.rkt +++ b/racket/collects/racket/contract/private/opters.rkt @@ -142,7 +142,10 @@ #:stronger-ribs stronger-ribs #:chaperone chaperone? #:no-negative-blame? no-negative-blame - #:name (or name-from-hos #`(list 'or/c #,@names))))) + #:name (or name-from-hos + (if (= (length names) 1) + (car names) + #`(list 'or/c #,@names)))))) (syntax-case stx (or/c) [(or/c p ...) diff --git a/racket/collects/racket/contract/private/orc.rkt b/racket/collects/racket/contract/private/orc.rkt index 61fd09fe36..46972de90f 100644 --- a/racket/collects/racket/contract/private/orc.rkt +++ b/racket/collects/racket/contract/private/orc.rkt @@ -4,14 +4,17 @@ "guts.rkt" "rand.rkt" "generate.rkt" - "misc.rkt") + "misc.rkt" + (for-syntax racket/base)) (provide symbols or/c one-of/c - blame-add-or-context) + blame-add-or-context + (rename-out [_flat-rec-contract flat-rec-contract])) (define/subexpression-pos-prop or/c (case-lambda [() (make-none/c '(or/c))] + [(x) (coerce-contract 'or/c x)] [raw-args (define args (coerce-contracts 'or/c raw-args)) (define-values (ho-contracts flat-contracts) @@ -431,3 +434,46 @@ (or (char? x) (symbol? x) (boolean? x) (null? x) (keyword? x) (number? x) (void? x)))) + +(define (get-flat-rec-me ctc) + (define ans (flat-rec-contract-me ctc)) + (unless ans (error 'flat-rec-contract "attempted to access the contract too early")) + ans) + +(struct flat-rec-contract ([me #:mutable] name) + #:property prop:custom-write custom-write-property-proc + #:property prop:flat-contract + (build-flat-contract-property + #:name + (λ (ctc) (flat-rec-contract-name ctc)) + #:stronger + (λ (this that) (equal? this that)) + #:first-order + (λ (ctc) + (λ (v) + ((contract-first-order (get-flat-rec-me ctc)) v))) + #:generate + (λ (ctc) + (λ (fuel) + (if (zero? fuel) + #f + (generate/choose (get-flat-rec-me ctc) (- fuel 1))))))) + +(define-syntax (_flat-rec-contract stx) + (syntax-case stx () + [(_ name ctc ...) + (identifier? (syntax name)) + (syntax + (let ([name (flat-rec-contract #f 'name)]) + (set-flat-rec-contract-me! + name + (or/c (coerce-flat-contract 'flat-rec-contract ctc) + ...)) + name))] + [(_ name ctc ...) + (raise-syntax-error 'flat-rec-contract + "expected first argument to be an identifier" + stx + (syntax name))])) +(define (flat-rec-contract/init x) + (error 'flat-rec-contract "applied too soon"))