From 67ac06e6edbcb2f5b93b1b60065d0d87cc2edfbc Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Thu, 17 Aug 2017 13:26:06 -0500
Subject: [PATCH] fix some issues surrounding the #:list-contract? argument to
 various contract combinator utilities

closes #1756
---
 .../tests/racket/contract/make-contract.rkt   | 42 +++++++++++++++++++
 .../collects/racket/contract/combinator.rkt   |  8 ++--
 .../collects/racket/contract/private/prop.rkt | 14 ++++++-
 3 files changed, 59 insertions(+), 5 deletions(-)

diff --git a/pkgs/racket-test/tests/racket/contract/make-contract.rkt b/pkgs/racket-test/tests/racket/contract/make-contract.rkt
index 638c1813f3..38101e5a08 100644
--- a/pkgs/racket-test/tests/racket/contract/make-contract.rkt
+++ b/pkgs/racket-test/tests/racket/contract/make-contract.rkt
@@ -44,6 +44,20 @@
  'make-contract-4
  '((contract proj:add1->sub1 sqrt 'pos 'neg) 'dummy))
 
+(test/spec-passed/result
+ 'make-contract-5
+ '(list-contract?
+   (make-contract #:late-neg-projection (λ (b) (λ (v) (λ (neg-party) v)))))
+ #f)
+
+  (test/spec-passed/result
+   'make-contract-6
+   '(list-contract?
+     (make-contract #:late-neg-projection
+                    (λ (b) (λ (v) (λ (neg-party) v)))
+                    #:list-contract? "a true value"))
+   #t)
+
 (ctest #t contract? proj:add1->sub1)
 (ctest #f flat-contract? proj:add1->sub1)
 (ctest #f chaperone-contract? proj:add1->sub1)
@@ -204,6 +218,34 @@
         (make-blame (srcloc #f #f #f #f #f) 5 (λ () 'the-name) 'pos 'neg #t))
        5)))
 
+  (test/spec-passed/result
+   'build-chaperone-contract-property2
+   '(let ()
+      (struct odd-length-list-of-integers ()
+        #:property prop:chaperone-contract
+        (build-chaperone-contract-property
+         #:val-first-projection (λ (me)
+                                  (λ (blame)
+                                    (λ (val)
+                                      (λ (neg-party)
+                                        (cond
+                                          [(and (list? val)
+                                                (odd? (length val))
+                                                (andmap integer? val))
+                                           val]
+                                          [else
+                                           (raise-blame-error
+                                            blame
+                                            val
+                                            "bad")])))))
+         #:list-contract? (λ (c) #t)
+         #:name (λ (x) 'the-name)
+         ;; make a very aproximate first-order check
+         #:first-order (λ (c) (λ (x) #t))
+         #:stronger (λ (x y) #f)))
+      (list-contract? (odd-length-list-of-integers)))
+   #t)
+
   (contract-eval
    '(define prop:late-neg-proj:bad-prime-box-list/c
       (let* ([prime? (λ (n)
diff --git a/racket/collects/racket/contract/combinator.rkt b/racket/collects/racket/contract/combinator.rkt
index 71e24cd4c6..de43909add 100644
--- a/racket/collects/racket/contract/combinator.rkt
+++ b/racket/collects/racket/contract/combinator.rkt
@@ -151,7 +151,8 @@
              #:projection [get-projection #f]
              #:stronger [stronger #f]
              #:generate [generate #f]
-             #:exercise [exercise #f])
+             #:exercise [exercise #f]
+             #:list-contract? [is-list-contract? (λ (c) #f)])
       (:build-chaperone-contract-property
        #:name get-name
        #:first-order get-first-order
@@ -163,7 +164,8 @@
        (maybe-add-wrapper add-prop-chaperone-check get-projection)
        #:stronger stronger
        #:generate generate
-       #:exercise exercise))
+       #:exercise exercise
+       #:list-contract? is-list-contract?))
     build-chaperone-contract-property))
 
 (define (add-prop-late-neg-chaperone-check get-late-neg)
@@ -239,7 +241,7 @@
                     #:projection [projection #f]
                     #:stronger [stronger #f]
                     #:generate [generate (λ (ctc) (λ (fuel) #f))]
-                    #:list-contract? [is-list-contract #f])
+                    #:list-contract? [is-list-contract (λ (c) #f)])
            (:build-flat-contract-property
             #:name name
             #:first-order first-order
diff --git a/racket/collects/racket/contract/private/prop.rkt b/racket/collects/racket/contract/private/prop.rkt
index a3c9dbbbe3..923d1c5f04 100644
--- a/racket/collects/racket/contract/private/prop.rkt
+++ b/racket/collects/racket/contract/private/prop.rkt
@@ -300,6 +300,16 @@
        proc-name
        (build-context))))
 
+  (unless (and (procedure? list-contract?)
+               (procedure-arity-includes? list-contract? 1))
+    (error proc-name
+           (string-append
+            "contract violation\n"
+            "  expected: (procedure-arity-includes/c 1)\n"
+            "  given: ~e\n"
+            "  in the #:list-contract? argument")
+           list-contract?))
+
   (mk (or get-name (λ (c) default-name))
       (or get-first-order get-any?)
       get-projection
@@ -453,7 +463,7 @@
          #:stronger [stronger #f]
          #:generate [generate (λ (ctc) (λ (fuel) #f))]
          #:exercise [exercise (λ (ctc) (λ (fuel) (values void '())))]
-         #:list-contract? [list-contract? (λ (ctc) #f)])
+         #:list-contract? [list-contract? #f])
 
   (unless (or first-order
               projection
@@ -486,7 +496,7 @@
         [else late-neg-projection])
       (or stronger as-strong?)
       generate exercise
-      list-contract?))
+      (and list-contract? #t)))
 
 (define (late-neg-first-order-projection name p?)
   (λ (b)