From 5ed9b65ae573ca1e40134ba8bf7ea257084ef349 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Tue, 13 May 2014 22:34:40 -0500
Subject: [PATCH] add a random generator for struct/c

This is actually done by adding a generator for struct/dc in the case
that there are no dependencies, so it'll also work for such contracts.
---
 .../tests/racket/contract-rand-test.rkt       | 24 ++++++++++++
 .../racket/contract/private/struct-dc.rkt     | 39 ++++++++++++++++---
 2 files changed, 58 insertions(+), 5 deletions(-)

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 29dd27fdc6..224664a9d7 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
@@ -54,6 +54,30 @@
      (or/c (cons/c any/c (cons/c any/c even-length-list/c))
            '())))))
 
+(check-not-exn
+ (λ ()
+   (struct s (a b) #:transparent)
+   (test-contract-generation
+    (struct/dc s [a integer?] [b boolean?]))))
+
+(check-not-exn
+ (λ ()
+   (struct s (a b) #:transparent)
+   (test-contract-generation
+    (struct/c s integer? boolean?))))
+
+(check-not-exn
+ (λ ()
+   (struct node (v l r) #:transparent)
+   (test-contract-generation
+    (flat-rec-contract
+     tree/c
+     (or/c (struct/dc node
+                      [v integer?]
+                      [l tree/c]
+                      [r tree/c])
+           #f)))))
+
 (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/racket/collects/racket/contract/private/struct-dc.rkt b/racket/collects/racket/contract/private/struct-dc.rkt
index 9cbe90192f..9c9f96556b 100644
--- a/racket/collects/racket/contract/private/struct-dc.rkt
+++ b/racket/collects/racket/contract/private/struct-dc.rkt
@@ -195,6 +195,31 @@
                     (and ((flat-contract-predicate (apply (dep-dep-proc subc) args)) val)
                          (loop (cdr subcs) next-args))])])])))))
 
+(define ((struct/dc-generate ctc) fuel)
+  (define constructor (base-struct/dc-constructor ctc))
+  (and constructor
+       (let loop ([subcs (base-struct/dc-subcontracts ctc)]
+                  [gens '()])
+         (cond
+           [(null? subcs)
+            (λ ()
+              (let loop ([gens gens]
+                         [args '()])
+                (cond
+                  [(null? gens) (apply constructor args)]
+                  [else (loop (cdr gens)
+                              (cons ((car gens)) args))])))]
+           [else
+            (define subc (car subcs))
+            (cond
+              [(invariant? subc) #f]
+              [(indep? subc)
+               (define sgen (generate/choose (indep-ctc subc) fuel))
+               (cond
+                 [sgen (loop (cdr subcs) (cons sgen gens))]
+                 [else #f])]
+              [else #f])]))))
+
 (define (struct/dc-first-order ctc)
   (base-struct/dc-pred ctc))
 
@@ -641,7 +666,7 @@
            #:when (invariant? sub))
     sub))
 
-(define-struct base-struct/dc (subcontracts pred struct-name here name-info struct/c?))
+(define-struct base-struct/dc (subcontracts constructor pred struct-name here name-info struct/c?))
 
 (define (struct/dc-exercise stct)
   (λ (fuel)
@@ -662,6 +687,7 @@
      #:first-order struct/dc-first-order
      #:projection struct/dc-proj
      #:stronger struct/dc-stronger?
+     #:generate struct/dc-generate
      #:exercise struct/dc-exercise)))
 
 (define-struct (flat-struct/dc base-struct/dc) ()
@@ -672,6 +698,7 @@
      #:first-order struct/dc-flat-first-order
      #:projection struct/dc-proj
      #:stronger struct/dc-stronger?
+     #:generate struct/dc-generate
      #:exercise struct/dc-exercise)))
 
 (define-struct (impersonator-struct/dc base-struct/dc) ()
@@ -682,9 +709,10 @@
      #:first-order struct/dc-first-order
      #:projection struct/dc-proj
      #:stronger struct/dc-stronger?
+     #:generate struct/dc-generate
      #:exercise struct/dc-exercise)))
 
-(define (build-struct/dc subcontracts pred struct-name here name-info struct/c?)
+(define (build-struct/dc subcontracts constructor pred struct-name here name-info struct/c?)
   (for ([subcontract (in-list subcontracts)])
     (when (and (indep? subcontract)
                (not (mutable? subcontract)))
@@ -709,11 +737,11 @@
   (cond
     [(and (andmap flat-subcontract? subcontracts)
           (not (ormap subcontract-mutable-field? subcontracts)))
-     (make-flat-struct/dc subcontracts pred struct-name here name-info struct/c?)]
+     (make-flat-struct/dc subcontracts constructor pred struct-name here name-info struct/c?)]
     [(ormap impersonator-subcontract? subcontracts)
-     (make-impersonator-struct/dc subcontracts pred struct-name here name-info struct/c?)]
+     (make-impersonator-struct/dc subcontracts constructor pred struct-name here name-info struct/c?)]
     [else
-     (make-struct/dc subcontracts pred struct-name here name-info struct/c?)]))
+     (make-struct/dc subcontracts constructor pred struct-name here name-info struct/c?)]))
    
 
 (define-for-syntax (get-struct-info id stx)
@@ -1190,6 +1218,7 @@
                      (cdr clauses)))])))
   
   #`(build-struct/dc (list #,@structs)
+                     #,(list-ref info 1)
                      #,(list-ref info 2)
                      '#,struct-id
                      (quote-module-name)