From c8bc0c76ad355dab09d1b99842139d082c7f9260 Mon Sep 17 00:00:00 2001 From: Cameron Moy Date: Wed, 24 Feb 2021 10:23:22 -0500 Subject: [PATCH] Improve flat-murec-contract with random generation --- .../tests/racket/contract/equivalent.rkt | 9 +++++ .../tests/racket/contract/first-order.rkt | 7 ++++ .../tests/racket/contract/name.rkt | 1 + .../tests/racket/contract/random-generate.rkt | 21 ++++++++++++ .../tests/racket/contract/stronger.rkt | 9 +++++ .../collects/racket/contract/private/misc.rkt | 34 +------------------ .../collects/racket/contract/private/orc.rkt | 25 +++++++++++++- 7 files changed, 72 insertions(+), 34 deletions(-) diff --git a/pkgs/racket-test/tests/racket/contract/equivalent.rkt b/pkgs/racket-test/tests/racket/contract/equivalent.rkt index 25e6046b3e..20ff1c0c55 100644 --- a/pkgs/racket-test/tests/racket/contract/equivalent.rkt +++ b/pkgs/racket-test/tests/racket/contract/equivalent.rkt @@ -352,6 +352,15 @@ (define x (flat-rec-contract x (first-or/c (cons/c x '()) '()))) (,test #:test-case-name 'flat-rec.2 #t contract-equivalent? x (first-or/c (cons/c x '()) '())))) + (contract-eval + `(let () + (define x (flat-murec-contract ([x (or/c (cons/c x '()) '())]) x)) + (,test #:test-case-name 'flat-murec.1 #t contract-equivalent? x (or/c (cons/c x '()) '())))) + (contract-eval + `(let () + (define x (flat-murec-contract ([x (first-or/c (cons/c x '()) '())]) x)) + (,test #:test-case-name 'flat-murec.2 #t contract-equivalent? x (first-or/c (cons/c x '()) '())))) + (ctest #f contract-equivalent? "x" string?) (ctest #f contract-equivalent? string? "x") diff --git a/pkgs/racket-test/tests/racket/contract/first-order.rkt b/pkgs/racket-test/tests/racket/contract/first-order.rkt index 6d20c1bdfc..3ceb10ff18 100644 --- a/pkgs/racket-test/tests/racket/contract/first-order.rkt +++ b/pkgs/racket-test/tests/racket/contract/first-order.rkt @@ -91,6 +91,13 @@ (ctest #f contract-first-order-passes? (flat-rec-contract the-name) 1) + (ctest #f contract-first-order-passes? + (flat-murec-contract ([one 1]) one) + 0) + (ctest #t contract-first-order-passes? + (flat-murec-contract ([one 1]) one) + 1) + (ctest #t contract-first-order-passes? (couple/c any/c any/c) (make-couple 1 2)) diff --git a/pkgs/racket-test/tests/racket/contract/name.rkt b/pkgs/racket-test/tests/racket/contract/name.rkt index 273462554e..e7adb76c8d 100644 --- a/pkgs/racket-test/tests/racket/contract/name.rkt +++ b/pkgs/racket-test/tests/racket/contract/name.rkt @@ -359,6 +359,7 @@ (test-name '(box/c boolean?) (box/c boolean?)) (test-name '(box/c boolean?) (box/c (flat-contract boolean?))) (test-name 'the-name (flat-rec-contract the-name)) + (test-name 'the-name (flat-murec-contract ([the-name none/c]) the-name)) (test-name '(object-contract) (object-contract)) (test-name '(object-contract (field x integer?)) (object-contract (field x integer?))) diff --git a/pkgs/racket-test/tests/racket/contract/random-generate.rkt b/pkgs/racket-test/tests/racket/contract/random-generate.rkt index e104ce7052..bdea7796cb 100644 --- a/pkgs/racket-test/tests/racket/contract/random-generate.rkt +++ b/pkgs/racket-test/tests/racket/contract/random-generate.rkt @@ -130,6 +130,14 @@ (first-or/c (cons/c any/c (cons/c any/c even-length-list/c)) '()))))) +(check-not-exn + (λ () + (test-contract-generation + (flat-murec-contract + ([even-length-list/c '() (cons/c any/c odd-length-list/c)] + [odd-length-list/c (cons/c any/c even-length-list/c)]) + even-length-list/c)))) + (check-not-exn (λ () (test-contract-generation @@ -196,6 +204,19 @@ [r tree/c]) #f))))) +(check-not-exn + (λ () + (struct node (v l r) #:transparent) + (struct red node () #:transparent) + (struct black node () #:transparent) + (test-contract-generation + (flat-murec-contract + ([red-or-black/c red/c black/c] + [red/c (struct/c red integer? black/c black/c)] + [black/c (struct/c black integer? red-or-black/c red-or-black/c) + null]) + red-or-black/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 (-> any/c (-> any) any)) 0 void))) diff --git a/pkgs/racket-test/tests/racket/contract/stronger.rkt b/pkgs/racket-test/tests/racket/contract/stronger.rkt index 17c9713ca4..c6d3a5256c 100644 --- a/pkgs/racket-test/tests/racket/contract/stronger.rkt +++ b/pkgs/racket-test/tests/racket/contract/stronger.rkt @@ -348,6 +348,15 @@ (define x (flat-rec-contract x (first-or/c (cons/c x '()) '()))) (,test #t trust/not-stronger? x (first-or/c (cons/c x '()) '())))) + (contract-eval + `(let () + (define x (flat-murec-contract ([x (or/c (cons/c x '()) '())]) x)) + (,test #t trust/not-stronger? x (or/c (cons/c x '()) '())))) + (contract-eval + `(let () + (define x (flat-murec-contract ([x (first-or/c (cons/c x '()) '())]) x)) + (,test #t trust/not-stronger? x (first-or/c (cons/c x '()) '())))) + (ctest #t trust/not-stronger? "x" string?) (ctest #f trust/not-stronger? string? "x") diff --git a/racket/collects/racket/contract/private/misc.rkt b/racket/collects/racket/contract/private/misc.rkt index 9f443ebca4..2765dc13ba 100644 --- a/racket/collects/racket/contract/private/misc.rkt +++ b/racket/collects/racket/contract/private/misc.rkt @@ -11,8 +11,7 @@ "generate.rkt" "generate-base.rkt") -(provide flat-murec-contract - not/c +(provide not/c =/c >=/c <=/c /c between/c renamed->-ctc renamed-<-ctc char-in @@ -63,37 +62,6 @@ (struct-out >-ctc) renamed-between/c) -(define-syntax (flat-murec-contract stx) - (syntax-case stx () - [(_ ([name ctc ...] ...) body1 body ...) - (andmap identifier? (syntax->list (syntax (name ...)))) - (with-syntax ([((ctc-id ...) ...) (map generate-temporaries - (syntax->list (syntax ((ctc ...) ...))))] - [(pred-id ...) (generate-temporaries (syntax (name ...)))] - [((pred-arm-id ...) ...) (map generate-temporaries - (syntax->list (syntax ((ctc ...) ...))))]) - (syntax - (let* ([pred-id flat-murec-contract/init] ... - [name (flat-contract (let ([name (λ (x) (pred-id x))]) name))] ...) - (let-values ([(ctc-id ...) (values (coerce-flat-contract 'flat-rec-contract ctc) ...)] ...) - (set! pred-id - (let ([pred-arm-id (flat-contract-predicate ctc-id)] ...) - (λ (x) - (or (pred-arm-id x) ...)))) ... - body1 - body ...))))] - [(_ ([name ctc ...] ...) body1 body ...) - (for-each (λ (name) - (unless (identifier? name) - (raise-syntax-error 'flat-rec-contract - "expected an identifier" stx name))) - (syntax->list (syntax (name ...))))] - [(_ ([name ctc ...] ...)) - (raise-syntax-error 'flat-rec-contract "expected at least one body expression" stx)])) - -(define (flat-murec-contract/init x) (error 'flat-murec-contract "applied too soon")) - - (define false/c #f) (define/final-prop (string-len/c n) diff --git a/racket/collects/racket/contract/private/orc.rkt b/racket/collects/racket/contract/private/orc.rkt index 007fb69d13..ded8f2d837 100644 --- a/racket/collects/racket/contract/private/orc.rkt +++ b/racket/collects/racket/contract/private/orc.rkt @@ -10,7 +10,8 @@ (provide symbols or/c first-or/c one-of/c blame-add-or-context blame-add-ior-context - (rename-out [_flat-rec-contract flat-rec-contract])) + (rename-out [_flat-rec-contract flat-rec-contract] + [_flat-murec-contract flat-murec-contract])) (define/subexpression-pos-prop/name or/c-name or/c (case-lambda @@ -601,5 +602,27 @@ "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 ...) + (andmap identifier? (syntax->list (syntax (name ...)))) + (syntax + (let ([name (flat-rec-contract #f 'name)] ...) + (set-flat-rec-contract-me! + name + (or/c (coerce-flat-contract 'flat-murec-contract ctc) + ...)) ... + body1 + body ...))] + [(_ ([name ctc ...] ...) body1 body ...) + (for-each (λ (name) + (unless (identifier? name) + (raise-syntax-error 'flat-murec-contract + "expected an identifier" stx name))) + (syntax->list (syntax (name ...))))] + [(_ ([name ctc ...] ...)) + (raise-syntax-error 'flat-murec-contract "expected at least one body expression" stx)]))