remove the error-prone except-out's from racket/contract

and take the opportunity to move some things around
internally to more reasonable places

racket/collects/racket/contract/base.rkt

@@ -20,37 +20,88 @@
          "private/orc.rkt")
 
 (provide
- (except-out (all-from-out "private/arrow.rkt")
-             making-a-method
-             procedure-accepts-and-more?
-             check-procedure
-             check-procedure/more
-
-             contract-key
-             
-             ;; these two are provided for-syntax
-             ;check-tail-contract
-             ;make-this-parameters
-             
-             -> ->*)
+ base->?
+ ->d
+ base->-rngs/c
+ base->-doms/c
+ unconstrained-domain->
+ the-unsupplied-arg
+ unsupplied-arg?
+ method-contract?
+ matches-arity-exactly?
+ keywords-match
+ bad-number-of-results
+ (for-syntax check-tail-contract
+             make-this-parameters
+             parse-leftover->*)
+ tail-marks-match?
+ values/drop
+ arity-checking-wrapper
+ unspecified-dom
+ blame-add-range-context
+ blame-add-nth-arg-context
+ 
  (rename-out [->2 ->] [->*2 ->*])
  dynamic->*
  predicate/c
+
+ ->i
+ box-immutable/c 
+ box/c
+ hash/c
+ hash/dc
+ vectorof
+ vector/c
+ vector-immutable/c
+ vector-immutableof
+ struct/dc
+ struct/c
+ struct-type-property/c
+ 
+ contract
+ recursive-contract
+ invariant-assertion
+ 
+ flat-murec-contract
+ and/c
+ not/c
+ =/c >=/c <=/c </c >/c between/c
+ integer-in
+ char-in
+ real-in
+ natural-number/c
+ string-len/c
+ false/c
+ printable/c
+ listof list*of non-empty-listof cons/c list/c cons/dc
+ promise/c
+ syntax/c
+ 
+ parameter/c
+ procedure-arity-includes/c
+ 
+ any/c
+ any
+ none/c
+ make-none/c
+ 
+ prompt-tag/c
+ continuation-mark-key/c
+ 
+ channel/c
+ evt/c
+ 
+ flat-contract
+ flat-contract-predicate
+ flat-named-contract
+ 
+ blame-add-car-context
+ blame-add-cdr-context
+ raise-not-cons-blame-error
+ 
+ rename-contract
+ if/c
  
- (all-from-out "private/arr-i.rkt"
-               "private/box.rkt"
-               "private/hash.rkt"
-               "private/vector.rkt"
-               "private/struct-dc.rkt"
-               "private/struct-prop.rkt")
- (except-out (all-from-out "private/base.rkt")
-             current-contract-region
-             (for-syntax lifted-key add-lifted-property))
- (except-out (all-from-out "private/misc.rkt")
-             check-between/c
-             check-unary-between/c
-             random-any/c
-             maybe-warn-about-val-first)
  symbols or/c first-or/c one-of/c
  flat-rec-contract
  provide/contract
@@ -74,7 +125,23 @@
  case->
 
  ;; from here (needs `->`, so can't be deeper)
- failure-result/c)
+ failure-result/c
+
+ contract?
+ chaperone-contract?
+ impersonator-contract?
+ flat-contract?
+ 
+ contract-late-neg-projection
+ contract-name
+ contract-projection
+ contract-val-first-projection
+ get/build-late-neg-projection
+ get/build-val-first-projection
+ 
+ ;; not documented.... (ie unintentional export)
+ n->th)
+
 
 ;; failure-result/c : contract
 ;; Describes the optional failure argument passed to hash-ref, for example.

racket/collects/racket/contract/combinator.rkt

@@ -1,32 +1,112 @@
 #lang racket/base
 (require "private/prop.rkt"
-         (prefix-in : "private/prop.rkt")
+         (prefix-in : (only-in "private/prop.rkt"
+                               build-chaperone-contract-property
+                               build-flat-contract-property
+                               make-chaperone-contract
+                               make-flat-contract))
          "private/guts.rkt"
          "private/blame.rkt")
 
 (provide 
- (except-out (all-from-out "private/prop.rkt")
-             contract-struct-name  
-             contract-struct-first-order
-             contract-struct-projection
-             contract-struct-val-first-projection
-             contract-struct-stronger?
-             contract-struct?
-             chaperone-contract-struct?
-             flat-contract-struct?
-             make-chaperone-contract
-             make-flat-contract
-             build-chaperone-contract-property
-             build-flat-contract-property)
+ prop:contract
+ contract-struct-late-neg-projection
+ contract-struct-generate
+ contract-struct-exercise
+ contract-struct-list-contract?
  
- (except-out (all-from-out "private/guts.rkt")
-             check-flat-contract
-             check-flat-named-contract
-             make-predicate-contract
-             has-contract?
-             value-contract)
+ prop:flat-contract
+ prop:chaperone-contract
+ 
+ contract-property?
+ build-contract-property
+ 
+ chaperone-contract-property?
+ 
+ flat-contract-property?
+ 
+ make-contract
+ 
+ prop:opt-chaperone-contract
+ prop:opt-chaperone-contract?
+ prop:opt-chaperone-contract-get-test
+ 
+ prop:orc-contract
+ prop:orc-contract?
+ prop:orc-contract-get-subcontracts
+ 
+ prop:recursive-contract
+ prop:recursive-contract?
+ prop:recursive-contract-unroll
+ 
+ prop:arrow-contract 
+ prop:arrow-contract?
+ prop:arrow-contract-get-info
+ (struct-out arrow-contract-info)
+ 
+ coerce-contract
+ coerce-contracts
+ coerce-flat-contract
+ coerce-flat-contracts
+ coerce-chaperone-contract
+ coerce-chaperone-contracts
+ coerce-contract/f
+ 
+ build-compound-type-name
+ 
+ contract-stronger?
+ list-contract?
+ 
+ contract-first-order
+ contract-first-order-passes?
+ 
+ prop:contracted prop:blame
+ impersonator-prop:contracted impersonator-prop:blame
+ has-blame? value-blame
+ 
+ ;; helpers for adding properties that check syntax uses
+ define/final-prop
+ define/subexpression-pos-prop
+ define/subexpression-pos-prop/name
+ 
+ eq-contract?
+ eq-contract-val
+ equal-contract?
+ equal-contract-val
+ char-in/c
+ 
+ contract-continuation-mark-key
+ with-contract-continuation-mark
+ 
+ (struct-out wrapped-extra-arg-arrow)
+ contract-custom-write-property-proc
+ (rename-out [contract-custom-write-property-proc custom-write-property-proc])
+ 
+ set-some-basic-contracts!
+ 
+ blame?
+ blame-source
+ blame-positive
+ blame-negative
+ blame-contract
+ blame-value
+ blame-original?
+ blame-swapped?
+ blame-swap
+ blame-replace-negative ;; used for indy blame
+ blame-update ;; used for option contract transfers
+ blame-add-context
+ blame-add-unknown-context
+ blame-context
+ 
+ blame-add-missing-party
+ blame-missing-party?
+ 
+ raise-blame-error
+ current-blame-format
+ (struct-out exn:fail:contract:blame)
+ blame-fmt->-string
  
- (except-out (all-from-out "private/blame.rkt") make-blame)
  (rename-out [-make-chaperone-contract make-chaperone-contract]
              [-make-flat-contract make-flat-contract]
              [-build-chaperone-contract-property build-chaperone-contract-property]
@@ -199,4 +279,3 @@
          (λ (x)
            (x-acceptor x)
            x))))
-

racket/collects/racket/contract/parametric.rkt

@@ -1,6 +1,4 @@
 #lang racket/base
 (require "private/exists.rkt"
          "private/parametric.rkt")
-(provide (all-from-out "private/parametric.rkt")
-         (except-out (all-from-out "private/exists.rkt")
-                     ∀∃?))
+(provide new-∃/c new-∀/c parametric->/c)

racket/collects/racket/contract/private/guts.rkt

@@ -48,12 +48,27 @@
          equal-contract-val
          char-in/c
 
+         contract?
+         chaperone-contract?
+         impersonator-contract?
+         flat-contract?
+         
          contract-continuation-mark-key
          with-contract-continuation-mark
          
          (struct-out wrapped-extra-arg-arrow)
          contract-custom-write-property-proc
          (rename-out [contract-custom-write-property-proc custom-write-property-proc])
+
+         contract-projection
+         contract-val-first-projection  ;; might return #f (if none)
+         contract-late-neg-projection   ;; might return #f (if none)
+         get/build-val-first-projection ;; builds one if necc., using contract-projection
+         get/build-late-neg-projection
+         warn-about-val-first?
+
+         contract-name
+         maybe-warn-about-val-first
          
          set-some-basic-contracts!)
 
@@ -80,6 +95,27 @@
         (print (contract-struct-name stct) port 1)
         (write-suffix)])]))
 
+(define (contract? x) (and (coerce-contract/f x) #t))
+
+(define (flat-contract? x) 
+  (let ([c (coerce-contract/f x)])
+    (and c
+         (flat-contract-struct? c))))
+
+(define (chaperone-contract? x)
+  (let ([c (coerce-contract/f x)])
+    (and c
+         (or (chaperone-contract-struct? c)
+             (and (prop:opt-chaperone-contract? c)
+                  ((prop:opt-chaperone-contract-get-test c) c))))))
+
+(define (impersonator-contract? x)
+  (let ([c (coerce-contract/f x)])
+    (and c
+         (not (flat-contract-struct? c))
+         (not (chaperone-contract-struct? c)))))
+
+
 (define (has-contract? v)
   (or (has-prop:contracted? v)
       (has-impersonator-prop:contracted? v)))
@@ -600,6 +636,100 @@
   (make-predicate-contract name pred generate #f))
 
 
+
+(define (contract-name ctc)
+  (contract-struct-name
+   (coerce-contract 'contract-name ctc)))
+
+(define (contract-projection ctc)
+  (get/build-projection
+   (coerce-contract 'contract-projection ctc)))
+(define (contract-val-first-projection ctc)
+  (get/build-val-first-projection
+   (coerce-contract 'contract-projection ctc)))
+(define (contract-late-neg-projection ctc)
+  (get/build-late-neg-projection
+   (coerce-contract 'contract-projection ctc)))
+
+(define-logger racket/contract)
+
+(define (get/build-late-neg-projection ctc)
+  (cond
+    [(contract-struct-late-neg-projection ctc) => values]
+    [else
+     (log-racket/contract-warning "no late-neg-projection for ~s" ctc)
+     (cond
+       [(contract-struct-projection ctc)
+        =>
+        (λ (projection)
+          (projection->late-neg-projection projection))]
+       [(contract-struct-val-first-projection ctc)
+        =>
+        (λ (val-first-projection)
+          (val-first-projection->late-neg-projection val-first-projection))]
+       [else
+        (first-order->late-neg-projection (contract-struct-first-order ctc)
+                                          (contract-struct-name ctc))])]))
+
+(define (projection->late-neg-projection proj)
+  (λ (b)
+    (λ (x neg-party)
+      ((proj (blame-add-missing-party b neg-party)) x))))
+(define (val-first-projection->late-neg-projection vf-proj)
+  (λ (b)
+    (define vf-val-accepter (vf-proj b))
+    (λ (x neg-party)
+      ((vf-val-accepter x) neg-party))))
+(define (first-order->late-neg-projection p? name)
+  (λ (b)
+    (λ (x neg-party)
+      (if (p? x)
+          x
+          (raise-blame-error
+           b x #:missing-party neg-party
+           '(expected: "~a" given: "~e")
+           name
+           x)))))
+
+(define warn-about-val-first? (make-parameter #t))
+(define (maybe-warn-about-val-first ctc)
+  (when (warn-about-val-first?)
+    (log-racket/contract-warning
+     "building val-first-projection of contract ~s for~a"
+     ctc
+     (build-context))))
+
+(define (get/build-val-first-projection ctc)
+  (cond
+    [(contract-struct-val-first-projection ctc) => values]
+    [else
+     (maybe-warn-about-val-first ctc)
+     (late-neg-projection->val-first-projection
+      (get/build-late-neg-projection ctc))]))
+(define (late-neg-projection->val-first-projection lnp)
+  (λ (b)
+    (define val+neg-party-accepter (lnp b))
+    (λ (x)
+      (λ (neg-party)
+        (val+neg-party-accepter x neg-party)))))
+
+(define (get/build-projection ctc)
+  (cond
+    [(contract-struct-projection ctc) => values]
+    [else
+     (log-racket/contract-warning
+      "building projection of contract ~s for~a"
+      ctc
+      (build-context))
+     (late-neg-projection->projection
+      (get/build-late-neg-projection ctc))]))
+(define (late-neg-projection->projection lnp)
+  (λ (b)
+    (define val+np-acceptor (lnp b))
+    (λ (x)
+      (val+np-acceptor x #f))))
+
+
 ;; Key used by the continuation mark that holds blame information for the current contract.
 ;; That information is consumed by the contract profiler.
 (define contract-continuation-mark-key
@@ -612,3 +742,4 @@
     ;; (unless (or (pair? payload) (not (blame-missing-party? payload)))
     ;;   (error "internal error: missing blame party" payload))
     (with-continuation-mark contract-continuation-mark-key payload code)))
+

racket/collects/racket/contract/private/legacy.rkt

@@ -1,6 +1,6 @@
 #lang racket/base
 
-(require "blame.rkt" "prop.rkt" "misc.rkt" syntax/srcloc)
+(require "blame.rkt" "prop.rkt" "guts.rkt" syntax/srcloc)
 
 (provide make-proj-contract
          raise-contract-error

racket/collects/racket/contract/private/misc.rkt

@@ -43,22 +43,10 @@
          channel/c
          evt/c
 
-         chaperone-contract?
-         impersonator-contract?
-         flat-contract?
-         contract?
-         
          flat-contract
          flat-contract-predicate
          flat-named-contract
          
-         contract-projection
-         contract-val-first-projection  ;; might return #f (if none)
-         contract-late-neg-projection   ;; might return #f (if none)
-         get/build-val-first-projection ;; builds one if necc., using contract-projection
-         get/build-late-neg-projection
-         warn-about-val-first?
-         contract-name
          n->th
          
          blame-add-car-context
@@ -68,9 +56,7 @@
          random-any/c
 
          rename-contract
-         if/c
-
-         maybe-warn-about-val-first)
+         if/c)
 
 (define-syntax (flat-murec-contract stx)
   (syntax-case stx  ()
@@ -1804,116 +1790,6 @@
   (contract-struct-first-order
    (coerce-flat-contract 'flat-contract-predicate x)))
 
-(define (flat-contract? x) 
-  (let ([c (coerce-contract/f x)])
-    (and c
-         (flat-contract-struct? c))))
-
-(define (chaperone-contract? x)
-  (let ([c (coerce-contract/f x)])
-    (and c
-         (or (chaperone-contract-struct? c)
-             (and (prop:opt-chaperone-contract? c)
-                  ((prop:opt-chaperone-contract-get-test c) c))))))
-
-(define (impersonator-contract? x)
-  (let ([c (coerce-contract/f x)])
-    (and c
-         (not (flat-contract-struct? c))
-         (not (chaperone-contract-struct? c)))))
-
-(define (contract-name ctc)
-  (contract-struct-name
-   (coerce-contract 'contract-name ctc)))
-
-(define (contract? x) (and (coerce-contract/f x) #t))
-(define (contract-projection ctc)
-  (get/build-projection
-   (coerce-contract 'contract-projection ctc)))
-(define (contract-val-first-projection ctc)
-  (get/build-val-first-projection
-   (coerce-contract 'contract-projection ctc)))
-(define (contract-late-neg-projection ctc)
-  (get/build-late-neg-projection
-   (coerce-contract 'contract-projection ctc)))
-
-(define-logger racket/contract)
-(define (get/build-late-neg-projection ctc)
-  (cond
-    [(contract-struct-late-neg-projection ctc) => values]
-    [else
-     (log-racket/contract-warning "no late-neg-projection for ~s" ctc)
-     (cond
-       [(contract-struct-projection ctc)
-        =>
-        (λ (projection)
-          (projection->late-neg-projection projection))]
-       [(contract-struct-val-first-projection ctc)
-        =>
-        (λ (val-first-projection)
-          (val-first-projection->late-neg-projection val-first-projection))]
-       [else
-        (first-order->late-neg-projection (contract-struct-first-order ctc)
-                                          (contract-struct-name ctc))])]))
-
-(define (projection->late-neg-projection proj)
-  (λ (b)
-    (λ (x neg-party)
-      ((proj (blame-add-missing-party b neg-party)) x))))
-(define (val-first-projection->late-neg-projection vf-proj)
-  (λ (b)
-    (define vf-val-accepter (vf-proj b))
-    (λ (x neg-party)
-      ((vf-val-accepter x) neg-party))))
-(define (first-order->late-neg-projection p? name)
-  (λ (b)
-    (λ (x neg-party)
-      (if (p? x)
-          x
-          (raise-blame-error
-           b x #:missing-party neg-party
-           '(expected: "~a" given: "~e")
-           name
-           x)))))
-
-(define warn-about-val-first? (make-parameter #t))
-(define (maybe-warn-about-val-first ctc)
-  (when (warn-about-val-first?)
-    (log-racket/contract-warning
-     "building val-first-projection of contract ~s for~a"
-     ctc
-     (build-context))))
-
-(define (get/build-val-first-projection ctc)
-  (cond
-    [(contract-struct-val-first-projection ctc) => values]
-    [else
-     (maybe-warn-about-val-first ctc)
-     (late-neg-projection->val-first-projection
-      (get/build-late-neg-projection ctc))]))
-(define (late-neg-projection->val-first-projection lnp)
-  (λ (b)
-    (define val+neg-party-accepter (lnp b))
-    (λ (x)
-      (λ (neg-party)
-        (val+neg-party-accepter x neg-party)))))
-
-(define (get/build-projection ctc)
-  (cond
-    [(contract-struct-projection ctc) => values]
-    [else
-     (log-racket/contract-warning
-      "building projection of contract ~s for~a"
-      ctc
-      (build-context))
-     (late-neg-projection->projection
-      (get/build-late-neg-projection ctc))]))
-(define (late-neg-projection->projection lnp)
-  (λ (b)
-    (define val+np-acceptor (lnp b))
-    (λ (x)
-      (val+np-acceptor x #f))))
-
 (define (flat-contract predicate) (coerce-flat-contract 'flat-contract predicate))
 (define (flat-named-contract name pre-contract [generate #f])
   (cond

racket/collects/racket/contract/private/prop.rkt

@@ -510,4 +510,4 @@
 ;;     raises a blame error if val doesn't satisfy the first-order checks for the function
 ;; accepts-arglist : (-> (listof keyword?)[sorted by keyword<?] exact-nonnegative-integer? boolean?)
 (struct arrow-contract-info (chaperone-procedure check-first-order accepts-arglist)
-  #:transparent)
+  #:transparent)