port if/c to late-neg, add tests, and fix some (minor) bugs

pkgs/racket-test/tests/racket/contract/flat-contracts.rkt

@@ -71,6 +71,9 @@
   (test-flat-contract #rx#".x." "axq" "x")
   (test-flat-contract ''() '() #f)
 
+  (test-flat-contract '(if/c integer? even? list?) 2 3)
+  (test-flat-contract '(if/c integer? even? list?) '() #f)
+  
   (test/spec-passed 'any/c '(contract any/c 1 'pos 'neg))
   (test-flat-contract 'printable/c (vector (cons 1 (box #f))) (lambda (x) x))
   (let ()

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

@@ -0,0 +1,85 @@
+#lang racket/base
+(require "test-util.rkt")
+
+(parameterize ([current-contract-namespace
+                (make-basic-contract-namespace)])
+
+  (test/spec-passed/result
+   'if/c1
+   '(contract (if/c integer? even? (listof number?))
+              2
+              'pos 'neg)
+   2)
+
+  (test/spec-passed/result
+   'if/c2
+   '(contract (if/c integer? even? (listof number?))
+              '()
+              'pos 'neg)
+   '())
+
+  (test/pos-blame
+   'if/c3
+   '(contract (if/c integer? even? (listof number?))
+              3
+              'pos 'neg))
+
+  (test/pos-blame
+   'if/c4
+   '(contract (if/c integer? even? (listof number?))
+              '(#f)
+              'pos 'neg))
+
+  (test/pos-blame
+   'if/c5
+   '(contract (if/c integer? even? (listof number?))
+              #f
+              'pos 'neg))
+
+  (test/pos-blame
+   'if/c6
+   '(contract (if/c (λ (x) (and (procedure? x) (procedure-arity-includes? x 1)))
+                    (-> integer? integer?)
+                    number?)
+              #f
+              'pos 'neg))
+
+  (test/neg-blame
+   'if/c7
+   '((contract (if/c (λ (x) (and (procedure? x) (procedure-arity-includes? x 1)))
+                     (-> integer? integer?)
+                     number?)
+               (λ (x) x)
+               'pos 'neg)
+     #f))
+
+  (test/spec-passed/result
+   'if/c8
+   '(contract (if/c (λ (x) (and (procedure? x) (procedure-arity-includes? x 1)))
+                    (-> integer? integer?)
+                    number?)
+              1
+              'pos 'neg)
+   1)
+
+  (test/spec-passed/result
+   'if/c9
+   '(let ([f (λ (x) x)])
+      (chaperone-of?
+       (contract (if/c (λ (x) (and (procedure? x) (procedure-arity-includes? x 1)))
+                       (-> integer? integer?)
+                       number?)
+                 f
+                 'pos 'neg)
+       f))
+   #t)
+
+  (test/spec-passed/result
+   'if/c10
+   '(chaperone-contract?
+     (if/c (λ (x) (and (procedure? x) (procedure-arity-includes? x 1)))
+           (-> integer? integer?)
+           number?))
+   #t))
+
+

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

@@ -32,6 +32,11 @@
              (or/c (-> (>=/c 5) (>=/c 5)) boolean?))
   (test-name '(or/c boolean? (-> (>=/c 5) (>=/c 5)))
              (or/c boolean? (-> (>=/c 5) (>=/c 5))))
+
+  (test-name '(if/c integer? odd? (-> integer? integer?))
+             (if/c integer? odd? (-> integer? integer?)))
+  (test-name '(if/c integer? odd? boolean?)
+             (if/c integer? odd? boolean?))
   
   (test-name '(first-or/c) (first-or/c))
   (test-name '(first-or/c integer? gt0?) (first-or/c integer? (let ([gt0? (lambda (x) (> x 0))]) gt0?)))

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

@@ -1999,44 +1999,66 @@
                          #:stronger stronger?
                          #:list-contract? (list-contract? ctc))))))
 
-;; (if/c predicate then/c else/c) applies then/c to satisfying
-;;   predicate, else/c to those that don't.
 (define (if/c predicate then/c else/c)
-  #|
-  Naive version:
-    (or/c (and/c predicate then/c)
-          (and/c (not/c predicate) else/c))
-  But that applies predicate twice.
-  |#
   (unless (procedure? predicate)
     (raise-type-error 'if/c "procedure?" predicate))
-  (unless (contract? then/c)
+  (unless (procedure-arity-includes? predicate 1)
-    (raise-type-error 'if/c "contract?" then/c))
+    (raise-type-error 'if/c "procedure that accepts 1 argument" predicate))
-  (unless (contract? else/c)
+  (define then-ctc (coerce-contract 'if/c then/c))
-    (raise-type-error 'if/c "contract?" else/c))
+  (define else-ctc (coerce-contract 'if/c else/c))
-  (let ([then-ctc (coerce-contract 'if/c then/c)]
+  (cond
-        [else-ctc (coerce-contract 'if/c else/c)])
+    [(and (flat-contract? then-ctc)
-    (define name (build-compound-type-name 'if/c predicate then-ctc else-ctc))
+          (flat-contract? else-ctc))
-    ;; Special case: if both flat contracts, make a flat contract.
+     (define then-pred (flat-contract-predicate then-ctc))
-    (if (and (flat-contract? then-ctc)
+     (define else-pred (flat-contract-predicate else-ctc))
-             (flat-contract? else-ctc))
+     (define name `(if/c ,(object-name predicate)
-        ;; flat contract
+                         ,(contract-name then-pred)
-        (let ([then-pred (flat-contract-predicate then-ctc)]
+                         ,(contract-name else-pred)))
-              [else-pred (flat-contract-predicate else-ctc)])
+     (define (pred x)
-          (define (pred x)
+       (if (predicate x) (then-pred x) (else-pred x)))
-            (if (predicate x) (then-pred x) (else-pred x)))
+     (flat-named-contract name pred)]
-          (flat-named-contract name pred))
+    [(and (chaperone-contract? then-ctc)
-        ;; ho contract
+          (chaperone-contract? else-ctc))
-        (let ([then-proj (contract-projection then-ctc)]
+     (chaperone-if/c predicate then-ctc else-ctc)]
-              [then-fo (contract-first-order then-ctc)]
+    [else
-              [else-proj (contract-projection else-ctc)]
+     (impersonator-if/c predicate then-ctc else-ctc)]))
-              [else-fo (contract-first-order else-ctc)])
+
-          (define ((proj blame) x)
+(define (if/c-first-order ctc)
-            (if (predicate x)
+  (define predicate (base-if/c-predicate ctc))
-                ((then-proj blame) x)
+  (define thn (contract-first-order (base-if/c-thn ctc)))
-                ((else-proj blame) x)))
+  (define els (contract-first-order (base-if/c-els ctc)))
-          (make-contract
+  (λ (x) (if (predicate x) (thn x) (els x))))
-           #:name name
+
-           #:projection proj
+(define (if/c-name ctc)
-           #:first-order
+  (define predicate (base-if/c-predicate ctc))
-           (lambda (x) (if (predicate x) (then-fo x) (else-fo x))))))))
+  (define thn (contract-name (base-if/c-thn ctc)))
+  (define els (contract-name (base-if/c-els ctc)))
+  `(if/c ,(object-name predicate) ,thn ,els))
+
+(define (if/c-late-neg-proj ctc)
+  (define predicate (base-if/c-predicate ctc))
+  (define thn (contract-late-neg-projection (base-if/c-thn ctc)))
+  (define els (contract-late-neg-projection (base-if/c-els ctc)))
+  (λ (blame)
+    (define thn-proj (thn blame))
+    (define els-proj (els blame))
+    (λ (val neg-party)
+      (if (predicate val)
+          (thn-proj val neg-party)
+          (els-proj val neg-party)))))
+
+(define-struct base-if/c (predicate thn els)
+  #:property prop:custom-write custom-write-property-proc)
+(define-struct (chaperone-if/c base-if/c) ()
+  #:property prop:chaperone-contract
+  (build-chaperone-contract-property
+   #:late-neg-projection if/c-late-neg-proj
+   #:first-order if/c-first-order
+   #:name if/c-name))
+
+(define-struct (impersonator-if/c base-if/c) ()
+  #:property prop:contract
+  (build-contract-property
+   #:late-neg-projection if/c-late-neg-proj
+   #:first-order if/c-first-order
+   #:name if/c-name))