add cons/dc

pkgs/racket-doc/scribblings/reference/contracts.scrbl

@@ -436,12 +436,46 @@ match @racket[car-c] and @racket[cdr-c], respectively. Beware that
 when this contract is applied to a value, the result is not
 necessarily @racket[eq?] to the input.
 
-If the @racket[cdr-c] contract is a @racket[list-contract?], then 
+If the @racket[cdr-c] contract is a @racket[list-contract?], then
 @racket[cons/c] returns a @racket[list-contract?].
 
+@examples[#:eval (contract-eval)
+                 (define/contract a-pair-of-numbers
+                   (cons/c number? number?)
+                   (cons 1 2))
+                                
+                 (define/contract not-a-pair-of-numbers
+                   (cons/c number? number?)
+                   (cons #f #t))]
+
 @history[#:changed "6.0.1.13" @list{Added the @racket[list-contract?] propagating behavior.}]
 }
 
+@defform*[[(cons/dc [car-id contract-expr] [cdr-id (car-id) contract-expr] cons/dc-option)
+           (cons/dc [car-id (cdr-id) contract-expr] [cdr-id contract-expr] cons/dc-option)]
+          #:grammar ([cons/dc-option (code:line)
+                                     #:flat
+                                     #:chaperone
+                                     #:impersonator])]{
+
+Produces a contract that recognizes pairs whose first and second elements
+match the expressions after @racket[car-id] and @racket[cdr-id], respectively.
+
+In the first case, the contract on the @racket[cdr-id] portion of the contract
+may depend on the value in the @racket[car-id] portion of the pair and in
+the second case, the reverse is true.
+
+@examples[#:eval (contract-eval)
+                 (define/contract an-ordered-pair-of-reals
+                   (cons/dc [hd real?] [tl (hd) (>=/c hd)])
+                   (cons 1 2))
+                                
+                 (define/contract not-an-ordered-pair-of-reals
+                   (cons/dc [hd real?] [tl (hd) (>=/c hd)])
+                   (cons 2 1))]
+
+@history[#:added "6.1.1.6"]
+}
 
 @defproc[(list/c [c contract?] ...) list-contract?]{
 

pkgs/racket-test/tests/racket/contract/list.rkt

@@ -63,4 +63,89 @@
    '(contract (list*of integer?) (list 1 2) 'pos 'neg))
   (test/pos-blame 
    'imlistof5
-   '(contract (list*of integer?) (cons #f #t) 'pos 'neg)))
+   '(contract (list*of integer?) (cons #f #t) 'pos 'neg))
+  
+  (test/pos-blame
+   'cons/dc1
+   '(contract (cons/dc [hd integer?] [tl (hd) integer?])
+              1
+              'pos
+              'neg))
+  
+  (test/spec-passed
+   'cons/dc2
+   '(contract (cons/dc [hd integer?] [tl (hd) integer?])
+              (cons 1 0)
+              'pos
+              'neg))
+  
+  (test/pos-blame
+   'cons/dc3
+   '(contract (cons/dc [hd integer?] [tl (hd) integer?])
+              (cons #f 0)
+              'pos
+              'neg))
+  
+  (test/pos-blame
+   'cons/dc4
+   '(contract (cons/dc [hd integer?] [tl (hd) integer?])
+              (cons 0 #f)
+              'pos
+              'neg))
+  
+  (test/pos-blame
+   'cons/dc5
+   '(contract (cons/dc [hd integer?] [tl (hd) (<=/c hd)])
+              (cons 0 2)
+              'pos
+              'neg))
+  
+  (test/pos-blame
+   'cons/dc6
+   '(contract (cons/dc [hd (tl) integer?] [tl integer?])
+              1
+              'pos
+              'neg))
+  
+  (test/spec-passed
+   'cons/dc7
+   '(contract (cons/dc [hd (tl) integer?] [tl integer?])
+              (cons 1 0)
+              'pos
+              'neg))
+  
+  (test/pos-blame
+   'cons/dc8
+   '(contract (cons/dc [hd (tl) integer?] [tl integer?])
+              (cons #f 0)
+              'pos
+              'neg))
+  
+  (test/pos-blame
+   'cons/dc9
+   '(contract (cons/dc [hd (tl) integer?] [tl integer?])
+              (cons 0 #f)
+              'pos
+              'neg))
+  
+  (test/pos-blame
+   'cons/dc10
+   '(contract (cons/dc [hd (tl) (<=/c tl)] [tl integer?])
+              (cons 2 0)
+              'pos
+              'neg))
+  
+  (test/spec-passed/result
+   'cons/dc11
+   '(chaperone-contract? (cons/dc [hd integer?] [tl (hd) integer?]))
+   #t)
+  (test/spec-passed/result
+   'cons/dc12
+   '(flat-contract? (cons/dc [hd integer?] [tl (hd) integer?] #:flat))
+   #t)
+  (test/spec-passed/result
+   'cons/dc13
+   '(contract? (cons/dc [hd integer?] [tl (hd) integer?] #:impersonator))
+   #t)
+  
+  )

pkgs/racket-test/tests/racket/contract/name.rkt

@@ -378,6 +378,9 @@
                       (augride [q (->m (<=/c 4) integer?)])))
   (test-name '(class/c (field n)) (class/c (field n)))
 
+  (test-name '(cons/dc [hd integer?] [tl (hd) (if (positive? hd) integer? boolean?)])
+             (cons/dc [hd integer?] [tl (hd) (if (positive? hd) integer? boolean?)]))
+  
   (test-name '(struct/dc s
                          [a integer?]
                          [b symbol?]

racket/collects/racket/contract/private/arr-i-parse.rkt

@@ -261,39 +261,6 @@ code does the parsing and validation of the syntax.
                   (list fst)
                   (cons fst (loop (cdr vars)))))])))
 
-(define (compute-quoted-src-expression stx)
-  (define max-depth 4)
-  (define max-width 5)
-  (let loop ([stx stx]
-             [depth max-depth])
-    (cond
-      [(zero? depth) '...]
-      [else
-       (define lst (syntax->list stx))
-       (cond
-         [lst 
-          (if (<= (length lst) max-width)
-              (for/list ([ele (in-list lst)])
-                (loop ele (- depth 1)))
-              (append (for/list ([ele (in-list lst)]
-                                 [i (in-range (- max-width 1))])
-                        (loop ele (+ depth 1)))
-                      '(...)))]
-         [else
-          (define ele (syntax-e stx))
-          (cond
-            [(or (symbol? ele)
-                 (boolean? ele)
-                 (char? ele)
-                 (number? ele))
-             ele]
-            [(string? ele)
-             (if (< (string-length ele) max-width)
-                 ele
-                 '...)]
-            [else
-             '...])])])))
-
 (define (parse-doms stx optional? doms)
   (let loop ([doms doms])
     (syntax-case doms ()
@@ -599,7 +566,6 @@ code does the parsing and validation of the syntax.
 (provide
  parse-->i
  ->i-valid-app-shapes
- compute-quoted-src-expression
  (struct-out istx)
  (struct-out arg/res)
  (struct-out arg)

racket/collects/racket/contract/private/arr-util.rkt

@@ -3,7 +3,41 @@
 (require "application-arity-checking.rkt")
 (provide split-doms
          sort-keywords
-         valid-app-shapes-from-man/opts)
+         valid-app-shapes-from-man/opts
+         compute-quoted-src-expression)
+
+(define (compute-quoted-src-expression stx)
+  (define max-depth 4)
+  (define max-width 5)
+  (let loop ([stx stx]
+             [depth max-depth])
+    (cond
+      [(zero? depth) '...]
+      [else
+       (define lst (syntax->list stx))
+       (cond
+         [lst
+          (if (<= (length lst) max-width)
+              (for/list ([ele (in-list lst)])
+                (loop ele (- depth 1)))
+              (append (for/list ([ele (in-list lst)]
+                                 [i (in-range (- max-width 1))])
+                        (loop ele (+ depth 1)))
+                      '(...)))]
+         [else
+          (define ele (syntax-e stx))
+          (cond
+            [(or (symbol? ele)
+                 (boolean? ele)
+                 (char? ele)
+                 (number? ele))
+             ele]
+            [(string? ele)
+             (if (< (string-length ele) max-width)
+                 ele
+                 '...)]
+            [else
+             '...])])])))
 
 ;; split-doms : syntax identifier syntax -> syntax
 ;; given a sequence of keywords interpersed with other
@@ -62,11 +96,6 @@
       [(null? pairs) null]
       [else (insert (car pairs) (loop (cdr pairs)))])))
 
-
-
-
- 
-
 (define (valid-app-shapes-from-man/opts min-arg-length num-of-opts rest? man-kwds opt-kwds)
   (define opt+man-dom-lengths
     (for/list ([i (in-range (+ num-of-opts 1))])

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

@@ -1,7 +1,9 @@
 #lang racket/base
 
-(require (for-syntax racket/base)
+(require (for-syntax racket/base
+                     "arr-util.rkt")
          racket/promise
+         syntax/location
          (only-in "../../private/promise.rkt" prop:force promise-forcer)
          "prop.rkt"
          "blame.rkt"
@@ -20,7 +22,7 @@
          string-len/c
          false/c
          printable/c
-         listof list*of non-empty-listof cons/c list/c
+         listof list*of non-empty-listof cons/c list/c cons/dc
          promise/c
          syntax/c
          
@@ -858,7 +860,7 @@
       (λ (neg-party)
         (unless (pair? v)
           (raise-not-cons-blame-error blame #:missing-party neg-party v))
-        (combine v 
+        (combine v
                  ((car-p (car v)) neg-party)
                  ((cdr-p (cdr v)) neg-party))))))
 
@@ -892,7 +894,7 @@
     [else
      (build-compound-type-name 'cons/c ctc-car ctc-cdr)]))
 
-(define (cons/c-stronger? this that) 
+(define (cons/c-stronger? this that)
   (define this-hd (the-cons/c-hd-ctc this))
   (define this-tl (the-cons/c-tl-ctc this))
   (cond
@@ -972,6 +974,149 @@
     [else
      (impersonator-cons/c ctc-car ctc-cdr)]))
 
+(define (cons/dc-val-first-projection ctc)
+  (define undep-proj (get/build-val-first-projection (the-cons/dc-undep ctc)))
+  (define dep-proc (the-cons/dc-dep ctc))
+  (define forwards? (the-cons/dc-forwards? ctc))
+  (λ (blame)
+    (define car-blame (blame-add-car-context blame))
+    (define cdr-blame (blame-add-cdr-context blame))
+    (define undep-proj+blame (undep-proj (if forwards? car-blame cdr-blame)))
+    (define undep-proj+indy-blame
+      (undep-proj (blame-replace-negative
+                   (if forwards? cdr-blame car-blame)
+                   (the-cons/dc-here ctc))))
+    (λ (val)
+      (cond
+        [(pair? val)
+         (λ (neg-party)
+           (define-values (orig-undep orig-dep)
+             (if forwards?
+                 (values (car val) (cdr val))
+                 (values (cdr val) (car val))))
+           (define new-undep ((undep-proj+blame orig-undep) neg-party))
+           (define new-dep-ctc (coerce-contract
+                                'cons/dc
+                                (dep-proc ((undep-proj+indy-blame orig-undep) neg-party))))
+           (define new-dep ((((get/build-val-first-projection new-dep-ctc)
+                              (if forwards? cdr-blame car-blame))
+                             orig-dep)
+                            neg-party))
+           (if forwards?
+               (cons new-undep new-dep)
+               (cons new-dep new-undep)))]
+        [else
+         (λ (neg-party)
+           (raise-not-cons-blame-error blame val #:missing-party neg-party))]))))
+
+(define (cons/dc-name ctc)
+  (define info (the-cons/dc-name-info ctc))
+  (if (the-cons/dc-forwards? ctc)
+      `(cons/dc [,(vector-ref info 0) ,(contract-name (the-cons/dc-undep ctc))]
+                [,(vector-ref info 1) (,(vector-ref info 0))
+                                      ,(vector-ref info 2)])
+      `(cons/dc [,(vector-ref info 0) (,(vector-ref info 1))
+                                      ,(vector-ref info 2)]
+                [,(vector-ref info 1) ,(contract-name (the-cons/dc-undep ctc))])))
+(define (cons/dc-first-order ctc)
+  (λ (val)
+    (and (pair? val)
+         (contract-first-order-passes?
+          (the-cons/dc-undep ctc)
+          (if (the-cons/dc-forwards? ctc) (car val) (cdr val))))))
+
+(define (cons/dc-stronger? this that) #f)
+
+(struct the-cons/dc (forwards? undep dep here name-info))
+
+(struct flat-cons/dc the-cons/dc ()
+  #:property prop:custom-write custom-write-property-proc
+  #:property prop:flat-contract
+  (build-flat-contract-property
+   #:val-first-projection cons/dc-val-first-projection
+   #:name cons/dc-name
+   #:first-order cons/dc-first-order
+   #:stronger cons/dc-stronger?))
+
+(struct chaperone-cons/dc the-cons/dc ()
+  #:property prop:custom-write custom-write-property-proc
+  #:property prop:chaperone-contract
+  (build-chaperone-contract-property
+   #:val-first-projection cons/dc-val-first-projection
+   #:name cons/dc-name
+   #:first-order cons/dc-first-order
+   #:stronger cons/dc-stronger?))
+
+(struct impersonator-cons/dc the-cons/dc ()
+  #:property prop:custom-write custom-write-property-proc
+  #:property prop:contract
+  (build-contract-property
+   #:val-first-projection cons/dc-val-first-projection
+   #:name cons/dc-name
+   #:first-order cons/dc-first-order
+   #:stronger cons/dc-stronger?))
+
+(define-syntax (cons/dc stx)
+  (define (kwds->constructor stx)
+    (syntax-case stx ()
+      [() #'chaperone-cons/dc]
+      [(#:chaperone) #'chaperone-cons/dc]
+      [(#:flat) #'flat-cons/dc]
+      [(#:impersonator) #'impersonator-cons/dc]
+      [(x . y) (raise-syntax-error
+                'cons/dc
+                "expected a keyword, either #:chaperone, #:flat, or #:impersonator"
+                stx
+                #'x)]))
+  (define this-one (gensym 'ctc))
+  (syntax-property
+   (syntax-case stx ()
+     [(_ [hd e1] [tl (hd2) e2] . kwds)
+      (begin
+        (unless (free-identifier=? #'hd2 #'hd)
+          (raise-syntax-error 'cons/dc
+                              "expected matching identifiers"
+                              stx
+                              #'hd
+                              (list #'hd2)))
+        #`(#,(kwds->constructor #'kwds)
+           #t
+           (coerce-contract 'cons/dc #,(syntax-property
+                                        #'e1
+                                        'racket/contract:positive-position
+                                        this-one))
+           (λ (hd2) #,(syntax-property
+                       #'e2
+                       'racket/contract:positive-position
+                       this-one))
+           (quote-module-name)
+           '#(hd tl #,(compute-quoted-src-expression #'e2))))]
+     [(_ [hd (tl2) e1] [tl e2] . kwds)
+      (begin
+        (unless (free-identifier=? #'tl2 #'tl)
+          (raise-syntax-error 'cons/dc
+                              "expected matching identifiers"
+                              stx
+                              #'tl
+                              (list #'tl2)))
+        #`(#,(kwds->constructor #'kwds)
+           #f
+           (coerce-contract 'cons/dc #,(syntax-property
+                                        #'e2
+                                        'racket/contract:positive-position
+                                        this-one))
+           (λ (tl2) #,(syntax-property
+                       #'e1
+                       'racket/contract:positive-position
+                       this-one))
+           (quote-module-name)
+           '#(hd tl #,(compute-quoted-src-expression #'e1))))])
+   'racket/contract:contract
+   (vector this-one
+           (list (car (syntax-e stx)))
+           '())))
+
+
 (define (raise-not-cons-blame-error blame val #:missing-party [missing-party #f])
   (raise-blame-error
    blame

racket/collects/racket/contract/private/parametric.rkt

@@ -3,7 +3,7 @@
          "blame.rkt"
          "misc.rkt"
          "guts.rkt"
-         (for-syntax "arr-i-parse.rkt" racket/base))
+         (for-syntax "arr-util.rkt" racket/base))
 (provide parametric->/c)
 
 (define-syntax (parametric->/c stx)