Improve flat-murec-contract with random generation

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")
 

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))

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?)))

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)))

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")
 

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 >/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)

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)]))