From 2dc96b365abf3bdb072ad1757b9763d686b3992f Mon Sep 17 00:00:00 2001
From: DarrenN <info@v25media.com>
Date: Mon, 3 Sep 2018 21:09:46 -0400
Subject: [PATCH] Implement hash/c random generate and exercise

---
 .../tests/racket/contract/random-generate.rkt | 30 +++++++++++
 .../collects/racket/contract/private/hash.rkt | 54 ++++++++++++++++++-
 2 files changed, 83 insertions(+), 1 deletion(-)

diff --git a/pkgs/racket-test/tests/racket/contract/random-generate.rkt b/pkgs/racket-test/tests/racket/contract/random-generate.rkt
index 39940cea07..b9533cdf27 100644
--- a/pkgs/racket-test/tests/racket/contract/random-generate.rkt
+++ b/pkgs/racket-test/tests/racket/contract/random-generate.rkt
@@ -92,6 +92,28 @@
 (check-not-exn (λ () (test-contract-generation (*list/c boolean? number? char?))))
 (check-not-exn (λ () (test-contract-generation (-> (*list/c boolean? number? char?) any))))
 
+(check-not-exn (λ () (test-contract-generation (hash/c boolean? boolean?))))
+(check-not-exn (λ () (test-contract-generation (hash/c char? integer?))))
+(check-not-exn (λ () (test-contract-generation (hash/c string? integer?))))
+(check-not-exn (λ () (test-contract-generation (hash/c string? (-> number? boolean?)))))
+(check-not-exn (λ () (test-contract-generation (hash/c string? (hash/c integer? string?)))))
+(check-not-exn (λ () (test-contract-generation (hash/c (hash/c string? integer?) (hash/c integer? string?)))))
+
+(define hash/c-list
+  (for/list ([i (in-range 100)])
+    (contract-random-generate
+     (hash/c integer? integer?))))
+
+;; hash/c should periodically generate empty hashes
+(check-pred
+ (λ (v) (not (empty? v)))
+ (filter hash-empty? hash/c-list))
+
+;; hash/c should periodically generate hashes with multiple elements
+(check-pred
+ (λ (v) (not (empty? v)))
+ (filter (λ (h) (> (length (hash-values h)) 1)) hash/c-list))
+
 (check-not-exn
  (λ ()
    (test-contract-generation
@@ -493,6 +515,14 @@
            'pos
            'neg))
 
+(check-exercise
+ 10
+ pos-exn?
+ (contract (hash/c symbol? (-> integer? boolean?))
+           (make-hash (list (cons 'lam (λ (n) (+ n 1)))))
+           'pos
+           'neg))
+
 ;; a test for contract-random-generate/choose
 (let ()
   (struct make-gen-choose/c ()
diff --git a/racket/collects/racket/contract/private/hash.rkt b/racket/collects/racket/contract/private/hash.rkt
index b5223962a2..c5770b2afa 100644
--- a/racket/collects/racket/contract/private/hash.rkt
+++ b/racket/collects/racket/contract/private/hash.rkt
@@ -4,7 +4,10 @@
          syntax/location
          "guts.rkt"
          "blame.rkt"
-         "prop.rkt")
+         "prop.rkt"
+         "rand.rkt"
+         "generate.rkt"
+         "generate-base.rkt")
 
 (provide (rename-out [wrap-hash/c hash/c])
          hash/dc)
@@ -188,6 +191,51 @@
           (contract-struct-equivalent? this-rng that-rng))]
     [else #f]))
 
+;; Will periodically generate empty hashes and hashes with multiple elements
+(define (hash/c-generate ctc)
+  (define this-dom (base-hash/c-dom ctc))
+  (define this-rng (base-hash/c-rng ctc))
+  (define this-immutable (base-hash/c-immutable ctc))
+  (λ (fuel)
+    (define rnd (random fuel)) ;; used to return empty hashes from time to time
+    (define gen-key (contract-random-generate/choose this-dom fuel))
+    (define gen-val (contract-random-generate/choose this-rng fuel))
+    (λ ()
+      (cond [(or (zero? rnd) (not gen-key) (not gen-val))
+             (if this-immutable
+                 (hash)
+                 (make-hash))]
+            [else
+             (let ([pair-list
+                    (let loop ([so-far (list (cons (gen-key) (gen-val)))])
+                      (rand-choice
+                       [1/5 so-far]
+                       [else
+                        (loop
+                         (cons (cons (gen-key) (gen-val)) so-far))]))])
+               (if this-immutable
+                   (make-immutable-hash pair-list)
+                   (make-hash pair-list)))]))))
+
+(define (hash/c-exercise ctc)
+  (define env (contract-random-generate-get-current-environment))
+  (define dom (base-hash/c-dom ctc))
+  (define rng (base-hash/c-rng ctc))
+  (λ (fuel)
+    ;; passing (list dom rng) to multi-exercise will produce
+    ;; a function that exercises values of form (list/c dom rng)
+    ;; and a list of newly available contracts.
+    (define-values (exercise-list-dom-rng available-ctcs)
+      ((multi-exercise (list dom rng)) fuel))
+    (values
+     (λ (h)
+       ;; iterate over key-value pairs, exercise and stash
+       (for ([(k v) (in-hash h)])
+         (exercise-list-dom-rng (list k v))
+         (contract-random-generate-stash env dom k)
+         (contract-random-generate-stash env dom v)))
+     (cons dom (cons rng available-ctcs)))))
+
 (define-struct (flat-hash/c base-hash/c) ()
   #:omit-define-syntaxes
   #:property prop:custom-write custom-write-property-proc
@@ -195,6 +243,8 @@
   (build-flat-contract-property
    #:name hash/c-name
    #:first-order hash/c-first-order
+   #:generate hash/c-generate
+   #:exercise hash/c-exercise
    #:stronger hash/c-stronger
    #:equivalent hash/c-equivalent
    #:late-neg-projection
@@ -311,6 +361,8 @@
   (build-chaperone-contract-property
    #:name hash/c-name
    #:first-order hash/c-first-order
+   #:generate hash/c-generate
+   #:exercise hash/c-exercise
    #:stronger hash/c-stronger
    #:equivalent hash/c-equivalent
    #:late-neg-projection (ho-projection chaperone-hash)))