add first-or/c

2015-11-07 19:24:46 -06:00 · 2015-11-07 19:24:46 -06:00 · 71690384a4
commit 71690384a4
parent 12d063ad87
21 changed files with 769 additions and 37 deletions
--- a/pkgs/racket-doc/scribblings/reference/contracts.scrbl
+++ b/pkgs/racket-doc/scribblings/reference/contracts.scrbl
@ -199,6 +199,48 @@ If all of its arguments are @racket[list-contract?]s, then @racket[or/c]
 returns a @racket[list-contract?].
 }

+@defproc[(first-or/c [contract contract?] ...)
+         contract?]{
+
+ Takes any number of contracts and returns a contract that
+ accepts any value that any one of the contracts accepts
+ individually.
+
+ The @racket[first-or/c] result tests any value by applying the
+ contracts in order from left to right. Thus, a contract
+ such as @racket[(first-or/c (not/c real?) positive?)]
+ is guaranteed to only invoke the 
+ @racket[positive?] predicate on real numbers.
+
+ If all of the arguments are procedures or @tech{flat
+  contracts}, the result is a @tech{flat contract} and
+ similarly if all of the arguments are @tech{chaperone
+  contracts} the result is too. Otherwise, the result is an
+ @tech{impersonator contract}.
+
+ If there are multiple higher-order contracts, 
+ @racket[first-or/c] uses @racket[contract-first-order-passes?]
+ to distinguish between them. More precisely, when an 
+ @racket[first-or/c] is checked, it checks the first order passes
+ of the first contract against the value. If it succeeds,
+ then it uses only that contract. If it fails, then it moves
+ to the second contract, continuing until it finds one of
+ the contracts where the first order check succeeds. If none
+ of them do, a contract violation is signaled.
+
+ For example, this contract
+ @racketblock[
+ (first-or/c (-> number? number?)
+        (-> string? string? string?))]
+ accepts the function @racket[(λ args 0)],
+ applying the @racket[(->number? number?)] contract to the function
+ because it comes first, even though
+ @racket[(-> string? string? string?)] also applies.
+
+ If all of its arguments are @racket[list-contract?]s, then @racket[first-or/c]
+ returns a @racket[list-contract?].
+}
+
@defproc[(and/c [contract contract?] ...) contract?]{

 Takes any number of contracts and returns a contract that
--- a/pkgs/racket-test/tests/racket/contract-rand-test.rkt
+++ b/pkgs/racket-test/tests/racket/contract-rand-test.rkt
@ -58,6 +58,7 @@
 (check-not-exn (λ () (test-contract-generation (=/c 0))))
 (check-not-exn (λ () (test-contract-generation (=/c 0.0))))
 (check-not-exn (λ () (test-contract-generation (or/c boolean? boolean?))))
+(check-not-exn (λ () (test-contract-generation (first-or/c boolean? boolean?))))
 (check-not-exn (λ () (test-contract-generation (cons/c integer? boolean?))))
 (check-not-exn (λ () (test-contract-generation (cons/dc [hd integer?] [tl (hd) (<=/c hd)]))))
 (check-not-exn (λ () (test-contract-generation (cons/dc [hd (tl) (<=/c tl)] [tl integer?]))))
@ -69,6 +70,7 @@
 (check-not-exn (λ () (test-contract-generation (and/c procedure? (-> integer? integer?)))))
 (check-not-exn (λ () (test-contract-generation (and/c integer? even?))))
 (check-not-exn (λ () (test-contract-generation (or/c (and/c real? positive? (</c 0)) boolean?))))
+(check-not-exn (λ () (test-contract-generation (first-or/c (and/c real? positive? (</c 0)) boolean?))))

 (check-not-exn (λ () (test-contract-generation (listof boolean?))))
 (check-not-exn (λ () (test-contract-generation (listof some-crazy-predicate?))))
@ -85,6 +87,14 @@
     (or/c (cons/c any/c (cons/c any/c even-length-list/c))
           '())))))

+(check-not-exn
+ (λ ()
+   (test-contract-generation
+    (flat-rec-contract
+     even-length-list/c
+     (first-or/c (cons/c any/c (cons/c any/c even-length-list/c))
+            '())))))
+
 (check-not-exn
 (λ ()
   (test-contract-generation
@ -95,6 +105,11 @@
   (test-contract-generation
    (letrec ([c (or/c null? (cons/c real? (recursive-contract c)))])
      c))))
+(check-not-exn
+ (λ ()
+   (test-contract-generation
+    (letrec ([c (first-or/c null? (cons/c real? (recursive-contract c)))])
+      c))))

 (check-not-exn
 (λ ()
@ -119,6 +134,17 @@
                      [l tree/c]
                      [r tree/c])
           #f)))))
+(check-not-exn
+ (λ ()
+   (struct node (v l r) #:transparent)
+   (test-contract-generation
+    (flat-rec-contract
+     tree/c
+     (first-or/c (struct/dc node
+                       [v integer?]
+                       [l tree/c]
+                       [r tree/c])
+            #f)))))

 (check-exn exn:fail? (λ () ((test-contract-generation (-> char? integer?)) 0)))
 (check-not-exn (λ () ((test-contract-generation (-> integer? integer?)) 1)))
@ -149,6 +175,7 @@


 (check-not-exn (lambda () (test-contract-generation (or/c #f number?))))
+(check-not-exn (lambda () (test-contract-generation (first-or/c #f number?))))
 (check-not-exn (lambda () (test-contract-generation (or/c some-crazy-predicate?
                                                          some-crazy-predicate?
                                                          some-crazy-predicate?
@ -160,9 +187,23 @@
                                                          some-crazy-predicate?
                                                          some-crazy-predicate?
                                                          #f))))
+(check-not-exn (lambda () (test-contract-generation (first-or/c some-crazy-predicate?
+                                                           some-crazy-predicate?
+                                                           some-crazy-predicate?
+                                                           some-crazy-predicate?
+                                                           some-crazy-predicate?
+                                                           some-crazy-predicate?
+                                                           some-crazy-predicate?
+                                                           some-crazy-predicate?
+                                                           some-crazy-predicate?
+                                                           some-crazy-predicate?
+                                                           #f))))
 (check-exn cannot-generate-exn? (λ () (test-contract-generation 
                                       (or/c some-crazy-predicate?
                                             some-crazy-predicate?))))
+(check-exn cannot-generate-exn? (λ () (test-contract-generation 
+                                       (first-or/c some-crazy-predicate?
+                                              some-crazy-predicate?))))

 ;; testing a bunch of impossible and/c's inside some or/c doesn't crash
 (check-not-exn (λ () (test-contract-generation 
@ -171,6 +212,12 @@
                            (and/c (-> number? number?)
                                   any/c
                                   number?)))))
+(check-not-exn (λ () (test-contract-generation 
+                      (first-or/c (first-or/c (and/c integer? boolean?)
+                                    (and/c (listof integer?) string?))
+                            (and/c (-> number? number?)
+                                   any/c
+                                   number?)))))

 ;; in this test, the and/c shoudl generate a dynamic
 ;; failure, which should trigger the 'cons/c' failing
@ -285,6 +332,13 @@
           (λ (x) (if x 'fail 11))
           'pos
           'neg))
+(check-exercise
+ 10000
+ pos-exn?
+ (contract (-> (first-or/c #f some-crazy-predicate?) some-crazy-predicate?)
+           (λ (x) (if x 'fail 11))
+           'pos
+           'neg))

 (check-exercise
 10000
@ -293,3 +347,10 @@
           (λ (x) (if x 'fail 11))
           'pos
           'neg))
+(check-exercise
+ 10000
+ pos-exn?
+ (contract (-> (first-or/c #f some-crazy-predicate?) (first-or/c #f some-crazy-predicate?))
+           (λ (x) (if x 'fail 11))
+           'pos
+           'neg))
--- a/pkgs/racket-test/tests/racket/contract/arrow-neg-party.rkt
+++ b/pkgs/racket-test/tests/racket/contract/arrow-neg-party.rkt
@ -243,6 +243,22 @@
     'neg #:database "db" #:password "password" #:user "user")
   (list "user" "db" "password" #f))

+  (test/spec-passed/result
+   '->*neg-party18b
+   '((neg-party-fn 
+      (->* (#:user string?)
+           (#:database (or/c string? #f)
+                       #:password (first-or/c string? (list/c 'hash string?) #f)
+                       #:port (first-or/c exact-positive-integer? #f))
+           any/c)
+      (λ (#:user user
+                 #:database [db #f]
+                 #:password [password #f]
+                 #:port [port #f])
+        (list user db password port)))
+     'neg #:database "db" #:password "password" #:user "user")
+   (list "user" "db" "password" #f))
+
  (test/pos-blame
   '->*neg-party19
   '((neg-party-fn 
--- a/pkgs/racket-test/tests/racket/contract/arrow-star.rkt
+++ b/pkgs/racket-test/tests/racket/contract/arrow-star.rkt
@ -543,6 +543,23 @@
      'pos 'neg)
     #:database "db" #:password "password" #:user "user")
   (list "user" "db" "password" #f))
+
+  (test/spec-passed/result
+   'contract-arrow-star-optional25b
+   '((contract 
+      (->* (#:user string?)
+           (#:database (first-or/c string? #f)
+                       #:password (first-or/c string? (list/c 'hash string?) #f)
+                       #:port (first-or/c exact-positive-integer? #f))
+           any/c)
+      (λ (#:user user
+                 #:database [db #f]
+                 #:password [password #f]
+                 #:port [port #f])
+        (list user db password port))
+      'pos 'neg)
+     #:database "db" #:password "password" #:user "user")
+   (list "user" "db" "password" #f))
  
  (test/spec-passed
   'contract-arrow-star-keyword-ordering
--- a/pkgs/racket-test/tests/racket/contract/async-channel.rkt
+++ b/pkgs/racket-test/tests/racket/contract/async-channel.rkt
@ -30,4 +30,11 @@
   '(let ([ac (contract (or/c (async-channel/c integer?) (integer? . -> . integer?))
               (make-async-channel) 'pos 'neg)])
      (async-channel-put ac 1)
+      (async-channel-get ac)))
+
+  (test/spec-passed
+   'async-channel/c-with-higher-order2
+   '(let ([ac (contract (first-or/c (async-channel/c integer?) (integer? . -> . integer?))
+               (make-async-channel) 'pos 'neg)])
+      (async-channel-put ac 1)
      (async-channel-get ac))))
--- a/pkgs/racket-test/tests/racket/contract/context.rkt
+++ b/pkgs/racket-test/tests/racket/contract/context.rkt
@ -94,8 +94,8 @@
                                    'neg))
                  1))
  
-  (context-test '("a part of the or/c of")
-                '(contract (or/c 1 (-> number? number?))
+  (context-test '()
+                '(contract (or/c 1 2)
                           3
                           'pos
                           'neg))
@ -106,6 +106,19 @@
                            'pos
                            'neg)
                  1))
+
+  (context-test '()
+                '(contract (first-or/c 1 (-> number? number?))
+                           3
+                           'pos
+                           'neg))
+
+  (context-test '("the range of" "a part of the first-or/c of")
+                '((contract (first-or/c 1 (-> number? number?) (-> number? boolean? number?))
+                            (λ (x) #f)
+                            'pos
+                            'neg)
+                  1))
  
  (context-test '("the 2nd conjunct of")
                '(contract (and/c procedure? (-> integer? integer?))
--- a/pkgs/racket-test/tests/racket/contract/first-order.rkt
+++ b/pkgs/racket-test/tests/racket/contract/first-order.rkt
@ -130,6 +130,27 @@
              (-> integer? integer?))
        1)

+  (ctest #t contract-first-order-passes? (first-or/c (-> (>=/c 5) (>=/c 5)) boolean?) #t)
+  (ctest #t contract-first-order-passes? (first-or/c (-> (>=/c 5) (>=/c 5)) boolean?) (λ (x) x))
+  (ctest #f contract-first-order-passes? (first-or/c (-> (>=/c 5) (>=/c 5)) boolean?) 'x)
+
+  (ctest #t contract-first-order-passes?
+         (first-or/c (-> integer? integer? integer?)
+                (-> integer? integer?))
+         (λ (x) x))
+  (ctest #t contract-first-order-passes?
+         (first-or/c (-> integer? integer? integer?)
+                (-> integer? integer?))
+         (λ (x y) x))
+  (ctest #f contract-first-order-passes?
+         (first-or/c (-> integer? integer? integer?)
+                (-> integer? integer?))
+         (λ () x))
+  (ctest #f contract-first-order-passes?
+         (first-or/c (-> integer? integer? integer?)
+                (-> integer? integer?))
+         1)
+
  (ctest #t contract-first-order-passes? (hash/c any/c any/c) (make-hash))
  (ctest #f contract-first-order-passes? (hash/c any/c any/c) #f)
  (ctest #f contract-first-order-passes? (hash/c symbol? boolean?) (let ([ht (make-hash)])
@ -175,6 +196,12 @@
  (ctest #f contract-first-order-passes? (or/c 'x "x" #rx"x.") "yx")
  (ctest #f contract-first-order-passes? (or/c 'x "x" #rx"x.") 'y)
  
+  (ctest #t contract-first-order-passes? (first-or/c 'x "x" #rx"x") 'x)
+  (ctest #t contract-first-order-passes? (first-or/c 'x "x" #rx"x") "x")
+  (ctest #t contract-first-order-passes? (first-or/c 'x "x" #rx"x.") "xy")
+  (ctest #f contract-first-order-passes? (first-or/c 'x "x" #rx"x.") "yx")
+  (ctest #f contract-first-order-passes? (first-or/c 'x "x" #rx"x.") 'y)
+  
  (ctest #f contract-first-order-passes? (->m integer? integer?) (λ (x) 1))
  (ctest #t contract-first-order-passes? (->m integer? integer?) (λ (this x) 1))
  
--- a/pkgs/racket-test/tests/racket/contract/flat-contracts.rkt
+++ b/pkgs/racket-test/tests/racket/contract/flat-contracts.rkt
@ -109,6 +109,12 @@
                        (contract-eval `(new (class* object% (flat-is-a-test<%>) (super-new))))
                        (contract-eval '(new object%)))
    (test-flat-contract `(or/c #f (is-a?/c flat-is-a-test%))
+                        (contract-eval `(new flat-is-a-test%))
+                        (contract-eval '(new object%)))
+    (test-flat-contract `(first-or/c #f (is-a?/c flat-is-a-test<%>))
+                        (contract-eval `(new (class* object% (flat-is-a-test<%>) (super-new))))
+                        (contract-eval '(new object%)))
+    (test-flat-contract `(first-or/c #f (is-a?/c flat-is-a-test%))
                        (contract-eval `(new flat-is-a-test%))
                        (contract-eval '(new object%))))

@ -162,6 +168,11 @@
                                            even1)
                      '(1 2 3 4)
                      '(1 2 3))
+  (test-flat-contract '(flat-murec-contract ([even1 (first-or/c null? (cons/c number? even2))]
+                                             [even2 (cons/c number? even1)])
+                                            even1)
+                      '(1 2 3 4)
+                      '(1 2 3))

  (test-flat-contract '(hash/c symbol? boolean? #:flat? #t) (make-hash) 1)
  (test-flat-contract '(hash/c symbol? boolean? #:flat? #t)
@ -200,6 +211,9 @@
  (test-flat-contract '(or/c (flat-contract integer?) char?) #\a #t)
  (test-flat-contract '(or/c (flat-contract integer?) char?) 1 #t)

+  (test-flat-contract '(first-or/c (flat-contract integer?) char?) #\a #t)
+  (test-flat-contract '(first-or/c (flat-contract integer?) char?) 1 #t)
+
  
  ;; test flat-contract-predicate
  (test #t (flat-contract-predicate integer?) 1)
--- a/pkgs/racket-test/tests/racket/contract/instanceof.rkt
+++ b/pkgs/racket-test/tests/racket/contract/instanceof.rkt
@ -55,6 +55,27 @@
           [c%/c (class/c [m (->m number? number?)])]
           [d%/c (class/c [n (->m number? number?)])])
      (contract (instanceof/c (or/c c%/c d%/c)) (new e%) 'pos 'neg)))
+
+  (test/spec-passed
+   'instanceof/c-first-order-9
+   '(let* ([c% (class object% (super-new) (define/public (m x) x))]
+           [c%/c (class/c [m (->m number? number?)])]
+           [d%/c (class/c [n (->m number? number?)])])
+      (contract (instanceof/c (first-or/c c%/c d%/c)) (new c%) 'pos 'neg)))
+  
+  (test/spec-passed
+   'instanceof/c-first-order-10
+   '(let* ([d% (class object% (super-new) (define/public (n x) x))]
+           [c%/c (class/c [m (->m number? number?)])]
+           [d%/c (class/c [n (->m number? number?)])])
+      (contract (instanceof/c (first-or/c c%/c d%/c)) (new d%) 'pos 'neg)))
+  
+  (test/pos-blame
+   'instanceof/c-first-order-11
+   '(let* ([e% (class object% (super-new) (define/public (p x) x))]
+           [c%/c (class/c [m (->m number? number?)])]
+           [d%/c (class/c [n (->m number? number?)])])
+      (contract (instanceof/c (first-or/c c%/c d%/c)) (new e%) 'pos 'neg)))
  
  (test/spec-passed/result
   'instanceof/c-higher-order-1
@ -87,7 +108,7 @@
      (send o m 3)))
  
  (test/pos-blame
-   'instanceof/c-higher-order-4
+   'instanceof/c-higher-order-5
   '(let* ([c% (class object% (super-new) (define/public (m x) #t))]
           [c%/c (class/c [m (->m number? number?)])]
           [d%/c (class/c [n (->m number? number?)])]
@ -95,9 +116,33 @@
      (send o m 3)))
  
  (test/neg-blame
-   'instanceof/c-higher-order-4
+   'instanceof/c-higher-order-6
   '(let* ([c% (class object% (super-new) (define/public (m x) x))]
           [c%/c (class/c [m (->m number? number?)])]
           [d%/c (class/c [n (->m number? number?)])]
           [o (contract (instanceof/c (or/c c%/c d%/c)) (new c%) 'pos 'neg)])
+      (send o m #t)))
+
+  (test/spec-passed
+   'instanceof/c-higher-order-7
+   '(let* ([c% (class object% (super-new) (define/public (m x) x))]
+           [c%/c (class/c [m (->m number? number?)])]
+           [d%/c (class/c [n (->m number? number?)])]
+           [o (contract (instanceof/c (first-or/c c%/c d%/c)) (new c%) 'pos 'neg)])
+      (send o m 3)))
+  
+  (test/pos-blame
+   'instanceof/c-higher-order-8
+   '(let* ([c% (class object% (super-new) (define/public (m x) #t))]
+           [c%/c (class/c [m (->m number? number?)])]
+           [d%/c (class/c [n (->m number? number?)])]
+           [o (contract (instanceof/c (first-or/c c%/c d%/c)) (new c%) 'pos 'neg)])
+      (send o m 3)))
+  
+  (test/neg-blame
+   'instanceof/c-higher-order-9
+   '(let* ([c% (class object% (super-new) (define/public (m x) x))]
+           [c%/c (class/c [m (->m number? number?)])]
+           [d%/c (class/c [n (->m number? number?)])]
+           [o (contract (instanceof/c (first-or/c c%/c d%/c)) (new c%) 'pos 'neg)])
      (send o m #t))))
--- a/pkgs/racket-test/tests/racket/contract/list-contract.rkt
+++ b/pkgs/racket-test/tests/racket/contract/list-contract.rkt
@ -115,5 +115,45 @@
              'pos 'neg)
   (λ (x)
     (and (exn:fail? x)
-          (regexp-match #rx"list-contract[?]" (exn-message x))))))
+          (regexp-match #rx"list-contract[?]" (exn-message x)))))
+  
+  (test/spec-passed/result
+   'list-contract-20
+   '(list-contract? (first-or/c (cons/c 1 empty?) empty?))
+   #t)
+  
+  (test/spec-passed/result
+   'list-contract-21
+   '(list-contract? (first-or/c (cons/c (-> integer? integer?) empty?)
+                           empty?))
+   #t)
+  
+  (test/spec-passed/result
+   'list-contract-22
+   '(list-contract? (first-or/c (cons/c (-> integer? integer?) empty?)
+                           (cons/c (-> integer? integer? integer?) empty?)
+                           empty?))
+   #t)
+  
+  (test/spec-passed/result
+   'list-contract-23
+   '(list-contract? 
+     (letrec ([c (recursive-contract (first-or/c (cons/c 1 c) empty?))])
+       c))
+   #f)
+  
+  (test/spec-passed/result
+   'list-contract-24
+   '(list-contract? 
+     (letrec ([c (recursive-contract (first-or/c (cons/c 1 c) empty?) #:list-contract?)])
+       c))
+   #t)
+  
+  (test/pos-blame
+   'test-contract-25
+   '(contract (letrec ([c (recursive-contract (first-or/c (cons/c any/c c) empty?) 
+                                              #:list-contract?)])
+                c)
+              (read (open-input-string "#1=(1 . #1#)"))
+              'pos 'neg)))

--- a/pkgs/racket-test/tests/racket/contract/name.rkt
+++ b/pkgs/racket-test/tests/racket/contract/name.rkt
@ -33,6 +33,16 @@
  (test-name '(or/c boolean? (-> (>=/c 5) (>=/c 5)))
             (or/c boolean? (-> (>=/c 5) (>=/c 5))))
  
+  (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?)))
+  (test-name '(first-or/c integer? boolean?)
+             (first-or/c (flat-contract integer?)
+                    (flat-contract boolean?)))
+  (test-name '(first-or/c (-> (>=/c 5) (>=/c 5)) boolean?)
+             (first-or/c (-> (>=/c 5) (>=/c 5)) boolean?))
+  (test-name '(first-or/c boolean? (-> (>=/c 5) (>=/c 5)))
+             (first-or/c boolean? (-> (>=/c 5) (>=/c 5))))
+  
  (test-name 'mumble (let ([frotz/c integer?]
                           [bazzle/c boolean?])
                       (flat-named-contract 'mumble
@ -167,6 +177,29 @@
                   (-> (>=/c 5) (>=/c 5))
                   (-> (<=/c 5) (<=/c 5) (<=/c 5))))

+  (test-name '(first-or/c) (first-or/c))
+  (test-name 'integer? (first-or/c integer?))
+  (test-name '(first-or/c integer? gt0?) (first-or/c integer? (let ([gt0? (lambda (x) (> x 0))]) gt0?)))
+  (test-name '(first-or/c integer? boolean?)
+             (first-or/c (flat-contract integer?)
+                   (flat-contract boolean?)))
+  (test-name '(first-or/c integer? boolean?)
+             (first-or/c integer? boolean?))
+  (test-name '(first-or/c (-> (>=/c 5) (>=/c 5)) boolean?)
+             (first-or/c (-> (>=/c 5) (>=/c 5)) boolean?))
+  (test-name '(first-or/c boolean? (-> (>=/c 5) (>=/c 5)))
+             (first-or/c boolean? (-> (>=/c 5) (>=/c 5))))
+  (test-name '(first-or/c (-> (>=/c 5) (>=/c 5))
+                     (-> (<=/c 5) (<=/c 5) (<=/c 5)))
+             (first-or/c (-> (>=/c 5) (>=/c 5))
+                    (-> (<=/c 5) (<=/c 5) (<=/c 5))))
+  (test-name '(first-or/c boolean?
+                     (-> (>=/c 5) (>=/c 5))
+                     (-> (<=/c 5) (<=/c 5) (<=/c 5)))
+             (first-or/c boolean?
+                    (-> (>=/c 5) (>=/c 5))
+                    (-> (<=/c 5) (<=/c 5) (<=/c 5))))
+
  (test-name 'any/c (and/c))
  (test-name '(and/c any/c) (and/c any/c))
  (test-name '(and/c any/c any/c) (and/c any/c any/c))
--- a/pkgs/racket-test/tests/racket/contract/obligations.rkt
+++ b/pkgs/racket-test/tests/racket/contract/obligations.rkt
@ -94,4 +94,12 @@
                    '((racket/contract:contract (vector-immutable/c) ())
                      (racket/contract:positive-position a)
                      (racket/contract:positive-position b)
-                      (racket/contract:positive-position c))))
+                      (racket/contract:positive-position c)))
+  (test-obligations '(or/c a b)
+                    '((racket/contract:contract (or/c) ())
+                      (racket/contract:positive-position a)
+                      (racket/contract:positive-position b)))
+  (test-obligations '(first-or/c a b)
+                    '((racket/contract:contract (first-or/c) ())
+                      (racket/contract:positive-position a)
+                      (racket/contract:positive-position b))))
--- a/pkgs/racket-test/tests/racket/contract/or-and.rkt
+++ b/pkgs/racket-test/tests/racket/contract/or-and.rkt
@ -93,7 +93,7 @@
               'pos
               'neg)
   exn:fail?)
-  
+
  (test/spec-passed/result
   'or/c-ordering
   '(let ([x '()])
@ -238,4 +238,147 @@
                   number?)
               (λ (x) 1)
               'pos 'neg)
-     (lambda (x) 1))))
+     (lambda (x) 1)))
+
+  (test/pos-blame
+   'first-or/c1
+   '(contract (first-or/c false/c) #t 'pos 'neg))
+  
+  (test/spec-passed
+   'first-or/c2
+   '(contract (first-or/c false/c) #f 'pos 'neg))
+  
+  (test/spec-passed
+   'first-or/c3
+   '((contract (first-or/c (-> integer? integer?)) (lambda (x) x) 'pos 'neg) 1))
+  
+  (test/neg-blame
+   'first-or/c4
+   '((contract (first-or/c (-> integer? integer?)) (lambda (x) x) 'pos 'neg) #f))
+  
+  (test/pos-blame
+   'first-or/c5
+   '((contract (first-or/c (-> integer? integer?)) (lambda (x) #f) 'pos 'neg) 1))
+  
+  (test/spec-passed
+   'first-or/c6
+   '(contract (first-or/c false/c (-> integer? integer?)) #f 'pos 'neg))
+  
+  (test/spec-passed
+   'first-or/c7
+   '((contract (first-or/c false/c (-> integer? integer?)) (lambda (x) x) 'pos 'neg) 1))
+  
+  (test/spec-passed/result
+   'first-or/c8
+   '((contract ((first-or/c false/c (-> string?))  . -> . any)
+               (λ (y) y)
+               'pos
+               'neg)
+     #f)
+   #f)
+  
+  (test/spec-passed/result
+   'first-or/c9
+   '((contract (first-or/c (-> string?) (-> integer? integer?))
+               (λ () "x")
+               'pos
+               'neg))
+   "x")
+  
+  (test/spec-passed/result
+   'first-or/c10
+   '((contract (first-or/c (-> string?) (-> integer? integer?))
+               (λ (x) x)
+               'pos
+               'neg)
+     1)
+   1)
+  
+  (test/pos-blame
+   'first-or/c11
+   '(contract (first-or/c (-> string?) (-> integer? integer?))
+              1
+              'pos
+              'neg))
+  
+  (test/pos-blame
+   'first-or/c12
+   '((contract (first-or/c (-> string?) (-> integer? integer?))
+               1
+               'pos
+               'neg)
+     'x))
+  
+  (test/pos-blame
+   'first-or/c13
+   '(contract (first-or/c not) #t 'pos 'neg))
+  
+  (test/spec-passed
+   'first-or/c14
+   '(contract (first-or/c not) #f 'pos 'neg))
+  
+  (test/spec-passed/result
+   'first-or/c-not-error-early
+   '(begin (first-or/c (-> integer? integer?) (-> boolean? boolean?))
+           1)
+   1)
+  
+  (test/spec-passed/result
+   'contract-not-an-error-test4-ior
+   '((contract (first-or/c (-> integer? integer?) (-> boolean? boolean?))
+               (λ (x) x)
+               'pos
+               'neg) 1)
+   1)
+  
+  (test/spec-passed/result
+   'first-or/c-ordering
+   '(let ([x '()])
+      (contract (first-or/c (lambda (y) (set! x (cons 2 x)) #f) (lambda (y) (set! x (cons 1 x)) #t))
+                'anything
+                'pos
+                'neg)
+      x)
+   '(1 2))
+  
+  (test/spec-passed/result
+   'first-or/c-ordering2
+   '(let ([x '()])
+      (contract (first-or/c (lambda (y) (set! x (cons 2 x)) #t) (lambda (y) (set! x (cons 1 x)) #t))
+                'anything
+                'pos
+                'neg)
+      x)
+   '(2))
+  
+  (test/spec-passed
+   'first-or/c-hmm
+   '(let ([funny/c (first-or/c (and/c procedure? (-> any)) (listof (-> number?)))])
+      (contract (-> funny/c any) void 'pos 'neg)))
+  
+  
+  (test/spec-passed
+   'first-or/c-opt-unknown-flat
+   '(let ()
+      (define arr (-> number? number?))
+      ((contract (opt/c (first-or/c not arr)) (λ (x) x) 'pos 'neg) 1)))
+  
+ 
+  (test/neg-blame
+   'ho-first-or/c-val-first1
+   '((contract (-> (first-or/c (-> number?)
+                         (-> number? number?))
+                   number?)
+               (λ (x) 1)
+               'pos 'neg)
+     (lambda (x y z) 1)))
+  
+  (test/spec-passed/result
+   'ho-first-or/c-val-first2
+   '((contract (-> (first-or/c (-> number? number?)
+                          (-> number? number?))
+                   number?)
+               (λ (x) (x 1))
+               'pos 'neg)
+     (lambda (x) (+ x 1)))
+   2))
--- a/pkgs/racket-test/tests/racket/contract/parametric.rkt
+++ b/pkgs/racket-test/tests/racket/contract/parametric.rkt
@ -53,6 +53,14 @@
               'pos 'neg)
     1 "foo")
   1)
+
+  (test/spec-passed/result
+   'parametric->/c6b
+   '((contract (parametric->/c (A B) (-> A B (first-or/c A B)))
+               (λ (x y) x)
+               'pos 'neg)
+     1 "foo")
+   1)
  
  (test/pos-blame
   'parametric->/c7
--- a/pkgs/racket-test/tests/racket/contract/predicates.rkt
+++ b/pkgs/racket-test/tests/racket/contract/predicates.rkt
@ -10,6 +10,11 @@
  (ctest #t flat-contract? (or/c (flat-contract integer?) (flat-contract boolean?)))
  (ctest #t flat-contract? (or/c integer? boolean?))
  
+  (ctest #t flat-contract? (first-or/c))
+  (ctest #t flat-contract? (first-or/c integer? (lambda (x) (> x 0))))
+  (ctest #t flat-contract? (first-or/c (flat-contract integer?) (flat-contract boolean?)))
+  (ctest #t flat-contract? (first-or/c integer? boolean?))
+  
  (ctest #t flat-contract? (-> any/c any/c any))

  (ctest #t flat-contract? (and/c))
@ -196,7 +201,7 @@
                                               (cons/c (recursive-contract ctc #:flat)
                                                       (recursive-contract ctc #:flat)))])
                             ctc))
-
+  
  (ctest #f flat-contract? (letrec ([ctc (or/c number?
                                               (box/c (recursive-contract ctc #:chaperone)))])
                             ctc))
@ -204,6 +209,20 @@
                                                    (box/c (recursive-contract ctc #:chaperone)))])
                                  ctc))
  (ctest #f impersonator-contract? (letrec ([ctc (or/c number?
+                                                       (box/c (recursive-contract ctc #:chaperone)))])
+                                     ctc))
+  (ctest #t flat-contract? (letrec ([ctc (first-or/c number?
+                                                (cons/c (recursive-contract ctc #:flat)
+                                                        (recursive-contract ctc #:flat)))])
+                             ctc))
+  
+  (ctest #f flat-contract? (letrec ([ctc (first-or/c number?
+                                                (box/c (recursive-contract ctc #:chaperone)))])
+                             ctc))
+  (ctest #t chaperone-contract? (letrec ([ctc (first-or/c number?
+                                                     (box/c (recursive-contract ctc #:chaperone)))])
+                                  ctc))
+  (ctest #f impersonator-contract? (letrec ([ctc (first-or/c number?
                                                  (box/c (recursive-contract ctc #:chaperone)))])
                                    ctc))

--- a/pkgs/racket-test/tests/racket/contract/stream.rkt
+++ b/pkgs/racket-test/tests/racket/contract/stream.rkt
@ -31,4 +31,14 @@
  (test/pos-blame
   'stream/c7
   '(stream-first (stream-rest (contract (stream/c (and/c integer? (or/c 0 positive?)))
+                                         (stream 0 -1) 'pos 'neg))))
+
+  (test/spec-passed
+   'stream/c8
+   '(stream-first (stream-rest (contract (stream/c (and/c integer? (first-or/c 0 positive?)))
+                                         (in-naturals) 'pos 'neg))))
+  
+  (test/pos-blame
+   'stream/c9
+   '(stream-first (stream-rest (contract (stream/c (and/c integer? (first-or/c 0 positive?)))
                                         (stream 0 -1) 'pos 'neg)))))
--- a/pkgs/racket-test/tests/racket/contract/stronger.rkt
+++ b/pkgs/racket-test/tests/racket/contract/stronger.rkt
@ -108,6 +108,38 @@
  (ctest #t contract-stronger? (-> (or/c #f number?) any/c) (-> number? any/c))
  (ctest #f contract-stronger? (-> (or/c #f number?)) (-> number?))
  (ctest #f contract-stronger? (-> number? any/c) (-> (or/c #f number?) any/c))
+
+  (ctest #t contract-stronger? (first-or/c null? any/c) (first-or/c null? any/c))
+  (ctest #f contract-stronger? (first-or/c null? any/c) (first-or/c boolean? any/c))
+  (ctest #t contract-stronger? (first-or/c null? boolean?) (first-or/c null? boolean?))
+  (ctest #t contract-stronger? (first-or/c null? boolean?) (first-or/c boolean? null?))
+  (ctest #t contract-stronger? 
+         (first-or/c null? (-> integer? integer?))
+         (first-or/c null? (-> integer? integer?)))
+  (ctest #f contract-stronger?
+         (first-or/c null? (-> boolean? boolean?))
+         (first-or/c null? (-> integer? integer?)))
+  (ctest #f contract-stronger? (first-or/c number? #f) number?)
+  (ctest #t contract-stronger? number? (first-or/c number? #f))
+  (ctest #f contract-stronger? (first-or/c (-> number? number?) #f) (-> number? number?))
+  (ctest #t contract-stronger? (-> number? number?) (first-or/c (-> number? number?) #f))
+  (ctest #f contract-stronger? (first-or/c (-> number? number?) (-> number? number? number?) #f) #f)
+  (ctest #t contract-stronger? #f (first-or/c (-> number? number?) (-> number? number? number?) #f))
+  (ctest #t contract-stronger? (first-or/c real?) (first-or/c integer? real?))
+  (ctest #t contract-stronger? (-> number?) (-> (first-or/c #f number?)))
+  (ctest #t contract-stronger? (-> (first-or/c #f number?) any/c) (-> number? any/c))
+  (ctest #f contract-stronger? (-> (first-or/c #f number?)) (-> number?))
+  (ctest #f contract-stronger? (-> number? any/c) (-> (first-or/c #f number?) any/c))
+
+  (ctest #t contract-stronger? (first-or/c null? any/c) (or/c null? any/c))
+  (ctest #f contract-stronger? (first-or/c null? any/c) (or/c boolean? any/c))
+  (ctest #t contract-stronger? (first-or/c null? boolean?) (or/c null? boolean?))
+  (ctest #t contract-stronger? (first-or/c null? boolean?) (or/c boolean? null?))
+
+  (ctest #t contract-stronger? (or/c null? any/c) (first-or/c null? any/c))
+  (ctest #f contract-stronger? (or/c null? any/c) (first-or/c boolean? any/c))
+  (ctest #t contract-stronger? (or/c null? boolean?) (first-or/c null? boolean?))
+  (ctest #t contract-stronger? (or/c null? boolean?) (first-or/c boolean? null?))
  
  (ctest #t contract-stronger? number? number?)
  (ctest #f contract-stronger? boolean? number?)
@ -226,6 +258,10 @@
   `(let ()
      (define x (flat-rec-contract x (or/c (cons/c x '()) '())))
      (,test #t contract-stronger? x (or/c (cons/c x '()) '()))))
+  (contract-eval
+   `(let ()
+      (define x (flat-rec-contract x (first-or/c (cons/c x '()) '())))
+      (,test #t contract-stronger? x (first-or/c (cons/c x '()) '()))))
  
  (ctest #t contract-stronger? "x" string?)
  (ctest #f contract-stronger? string? "x")
@ -263,10 +299,13 @@
  (ctest #f contract-stronger? (syntax/c (<=/c 4)) (syntax/c (<=/c 3)))
  
  (ctest #t contract-stronger? (parametric->/c (x) (-> x x)) (parametric->/c (x) (-> x (or/c x #f))))
+  (ctest #t contract-stronger? (parametric->/c (x) (-> x x)) (parametric->/c (x) (-> x (first-or/c x #f))))
  (ctest #f contract-stronger? (parametric->/c (x y) (-> x y)) (parametric->/c (x y) (-> x x y)))
  (contract-eval `(define α (new-∀/c)))
  (ctest #t contract-stronger? (-> α α) (-> α (or/c #f α)))
  (ctest #f contract-stronger? (-> α (or/c #f α)) (-> α α))
+  (ctest #t contract-stronger? (-> α α) (-> α (first-or/c #f α)))
+  (ctest #f contract-stronger? (-> α (first-or/c #f α)) (-> α α))
  
  (ctest #t contract-stronger?
         (class/c (m (-> any/c (<=/c 3))))
@ -464,6 +503,64 @@
                             [c (a b) (or/c #f (mk-c a))]))])
        (,test #t contract-stronger? (mk-c 1) (mk-c 2)))))

+  (contract-eval
+   `(let ()
+      (define (non-zero? x) (not (zero? x)))
+      (define list-of-numbers
+        (first-or/c null?
+               (couple/c number?
+                         (recursive-contract list-of-numbers))))
+      (define (short-list/less-than n)
+        (first-or/c null?
+              (couple/c (<=/c n)
+                        (first-or/c null?
+                              (couple/c (<=/c n)
+                                        any/c)))))
+      (define (short-sorted-list/less-than n)
+        (first-or/c null?
+              (couple/dc
+               [hd (<=/c n)]
+               [tl (hd) (first-or/c null?
+                              (couple/c (<=/c hd)
+                                        any/c))])))
+
+      (define (sorted-list/less-than n)
+        (first-or/c null?
+              (couple/dc
+               [hd (<=/c n)]
+               [tl (hd) (sorted-list/less-than hd)])))
+
+      ;; for some reason, the `n' makes it harder to optimize. 
+      ;; without it, this test isn't as good a test
+      (define (closure-comparison-test n)
+        (couple/dc
+         [hd any/c]
+         [tl (hd) any/c]))
+
+      (,test #t contract-stronger? (couple/c any/c any/c) (couple/c any/c any/c))
+      (,test #f contract-stronger? (couple/c (>=/c 2) (>=/c 3)) (couple/c (>=/c 4) (>=/c 5)))
+      (,test #t contract-stronger? (couple/c (>=/c 4) (>=/c 5)) (couple/c (>=/c 2) (>=/c 3)))
+      (,test #f contract-stronger? (couple/c (>=/c 1) (>=/c 5)) (couple/c (>=/c 5) (>=/c 1)))
+      (let ([ctc (couple/dc [hd any/c] [tl (hd) any/c])])
+        (,test #t contract-stronger? ctc ctc))
+      (let ([ctc (couple/dc [hd any/c] [tl (hd) (<=/c hd)])])
+        (,test #t contract-stronger? ctc ctc))
+      (,test #t contract-stronger? list-of-numbers list-of-numbers)
+      (,test #t contract-stronger? (short-list/less-than 4) (short-list/less-than 5))
+      (,test #f contract-stronger? (short-list/less-than 5) (short-list/less-than 4))
+      (,test #t contract-stronger? (short-sorted-list/less-than 4) (short-sorted-list/less-than 5))
+      (,test #f contract-stronger? (short-sorted-list/less-than 5) (short-sorted-list/less-than 4))
+      (,test #t contract-stronger? (sorted-list/less-than 4) (sorted-list/less-than 5))
+      (,test #f contract-stronger? (sorted-list/less-than 5) (sorted-list/less-than 4))
+      (,test #t contract-stronger? (closure-comparison-test 4) (closure-comparison-test 5))
+
+      (letrec ([mk-c
+                (λ (x)
+                  (triple/dc [a (<=/c x)]
+                             [b any/c]
+                             [c (a b) (or/c #f (mk-c a))]))])
+        (,test #t contract-stronger? (mk-c 1) (mk-c 2)))))
+

  (contract-eval
   `(let ()
--- a/pkgs/racket-test/tests/racket/contract/struct-dc.rkt
+++ b/pkgs/racket-test/tests/racket/contract/struct-dc.rkt
@ -416,6 +416,22 @@
                                  'pos
                                  'neg))))
   2)
+
+  (test/spec-passed/result
+   'struct/dc-12b
+   '(let ()
+      (struct kons (hd tl) #:transparent)
+      (define (unknown-function a) (=/c a))
+      (define-opt/c (f a b)
+        (first-or/c not
+               (struct/dc kons
+                          [hd (unknown-function a)]
+                          [tl () #:lazy (first-or/c #f (f b a))])))
+      (kons-hd (kons-tl (contract (f 1 2)
+                                  (kons 1 (kons 2 #f))
+                                  'pos
+                                  'neg))))
+   2)
  
  (test/spec-passed
   'struct/dc-13
--- a/racket/collects/racket/contract/base.rkt
+++ b/racket/collects/racket/contract/base.rkt
@ -50,7 +50,7 @@
             check-between/c
             check-unary-between/c
             random-any/c)
- symbols or/c one-of/c
+ symbols or/c first-or/c one-of/c
 flat-rec-contract
 provide/contract
 ;(for-syntax make-provide/contract-transformer) ;; not documented!
--- a/racket/collects/racket/contract/private/opters.rkt
+++ b/racket/collects/racket/contract/private/opters.rkt
@ -64,7 +64,8 @@
           (define ps-optres (opt/i (opt/info-add-blame-context
                                     opt/info
                                     (λ (blame-stx)
-                                       #`(blame-add-or-context #,blame-stx)))
+                                       #`(blame-add-or-context #,blame-stx)
+                                       blame-stx))
                                    (car ps)))
           (if (optres-flat ps-optres)
               (loop (cdr ps)
--- a/racket/collects/racket/contract/private/orc.rkt
+++ b/racket/collects/racket/contract/private/orc.rkt
@ -7,8 +7,9 @@
         "misc.rkt"
         (for-syntax racket/base))

-(provide symbols or/c one-of/c
+(provide symbols or/c first-or/c one-of/c
         blame-add-or-context
+         blame-add-ior-context
         (rename-out [_flat-rec-contract flat-rec-contract]))

 (define/subexpression-pos-prop or/c
@ -22,7 +23,7 @@
                  [flat-contracts '()]
                  [args args])
         (cond
-           [(null? args) (values ho-contracts (reverse flat-contracts))]
+           [(null? args) (values (reverse ho-contracts) (reverse flat-contracts))]
           [else 
            (let ([arg (car args)])
              (cond
@ -30,19 +31,7 @@
                 (loop ho-contracts (cons arg flat-contracts) (cdr args))]
                [else
                 (loop (cons arg ho-contracts) flat-contracts (cdr args))]))])))
-     (define pred 
-       (cond
-         [(null? flat-contracts) not]
-         [else
-          (let loop ([fst (car flat-contracts)]
-                     [rst (cdr flat-contracts)])
-            (let ([fst-pred (flat-contract-predicate fst)])
-              (cond
-                [(null? rst) fst-pred]
-                [else 
-                 (let ([r (loop (car rst) (cdr rst))])
-                   (λ (x) (or (fst-pred x) (r x))))])))]))
-     
+     (define pred (make-flat-predicate flat-contracts))
     (cond
       [(null? ho-contracts)
        (make-flat-or/c pred flat-contracts)]
@ -57,6 +46,32 @@
            (make-chaperone-multi-or/c name flat-contracts ho-contracts)
            (make-impersonator-multi-or/c name flat-contracts ho-contracts))])]))

+(define/subexpression-pos-prop first-or/c
+  (case-lambda 
+    [() (make-none/c '(first-or/c))]
+    [(x) (coerce-contract 'first-or/c x)]
+    [raw-args
+     (define args (coerce-contracts 'first-or/c raw-args))
+     (cond
+       [(andmap flat-contract? args)
+        (make-flat-first-or/c (make-flat-predicate args) args)]
+       [(andmap chaperone-contract? args)
+        (make-chaperone-first-or/c args)]
+       [else (make-impersonator-first-or/c args)])]))
+
+(define (make-flat-predicate flat-contracts)
+  (cond
+    [(null? flat-contracts) not]
+    [else
+     (let loop ([fst (car flat-contracts)]
+                [rst (cdr flat-contracts)])
+       (let ([fst-pred (flat-contract-predicate fst)])
+         (cond
+           [(null? rst) fst-pred]
+           [else 
+            (let ([r (loop (car rst) (cdr rst))])
+              (λ (x) (or (fst-pred x) (r x))))])))]))
+
 (define (single-or/c-projection ctc)
  (let ([c-proc (contract-projection (single-or/c-ho-ctc ctc))]
        [pred (single-or/c-pred ctc)])
@ -70,16 +85,20 @@

 (define (single-or/c-late-neg-projection ctc)
  (define c-proj (get/build-late-neg-projection (single-or/c-ho-ctc ctc)))
+  (define c-first-order (contract-first-order (single-or/c-ho-ctc ctc)))
  (define pred (single-or/c-pred ctc))
  (λ (blame)
    (define p-app (c-proj (blame-add-or-context blame)))
    (λ (val neg-party)
-      (if (pred val)
-          val
-          (p-app val neg-party)))))
+      (cond 
+       [(pred val) val]
+       [(c-first-order val) (p-app val neg-party)]
+       [else (raise-none-or-matched blame val #f)]))))

 (define (blame-add-or-context blame)
  (blame-add-context blame "a part of the or/c of"))
+(define (blame-add-ior-context blame)
+  (blame-add-context blame "a part of the first-or/c of"))

 (define (single-or/c-first-order ctc)
  (let ([pred (single-or/c-pred ctc)]
@ -117,6 +136,7 @@
             (multi-or/c-ho-ctcs ctc))]
    [(flat-or/c? ctc)
     (flat-or/c-flat-ctcs ctc)]
+    [(base-first-or/c? ctc) (base-first-or/c-ctcs ctc)]
    [else #f]))

 (define (or/c-exercise ho-contracts)
@ -231,7 +251,7 @@
         [first-order-checks (map (λ (x) (contract-first-order x)) ho-contracts)]
         [predicates (map flat-contract-predicate (multi-or/c-flat-ctcs ctc))])
    (λ (blame)
-      (define disj-blame (blame-add-context blame "a part of the or/c of"))
+      (define disj-blame (blame-add-or-context blame))
      (define partial-contracts
        (for/list ([c-proc (in-list c-procs)])
          (c-proc disj-blame)))
@ -249,9 +269,7 @@
               [(null? checks)
                (if candidate-proc
                    (candidate-proc val)
-                    (raise-blame-error blame val 
-                                       '("none of the branches of the or/c matched" given: "~e")
-                                       val))]
+                    (raise-none-or-matched blame val #f))]
               [((car checks) val)
                (if candidate-proc
                    (raise-blame-error blame val
@ -298,9 +316,7 @@
                [candidate-c-proj
                 (candidate-c-proj val neg-party)]
                [else
-                 (raise-blame-error blame val #:missing-party neg-party
-                                    '("none of the branches of the or/c matched" given: "~e")
-                                    val)])]
+                 (raise-none-or-matched blame val neg-party)])]
             [((car checks) val)
              (if candidate-c-proj
                  (raise-blame-error blame val #:missing-party neg-party
@ -322,6 +338,11 @@
                    candidate-c-proj
                    candidate-contract)]))]))))

+(define (raise-none-or-matched blame val neg-party)
+  (raise-blame-error blame val #:missing-party neg-party
+                              '("none of the branches of the or/c matched" given: "~e")
+                              val))
+
 (define (multi-or/c-first-order ctc)
  (let ([flats (map flat-contract-predicate (multi-or/c-flat-ctcs ctc))]
        [hos (map (λ (x) (contract-first-order x)) (multi-or/c-ho-ctcs ctc))])
@ -392,7 +413,7 @@
   #:name
   (λ (ctc)
      (apply build-compound-type-name 
-             'or/c 
+             (if (flat-first-or/c? ctc) 'first-or/c 'or/c)
             (flat-or/c-flat-ctcs ctc)))
   #:stronger
   (λ (this that)
@ -432,6 +453,73 @@
     (for/and ([c (in-list (flat-or/c-flat-ctcs ctc))])
       (list-contract? c)))))

+(define-struct (flat-first-or/c flat-or/c) ())
+
+(define (first-or/c-proj ctc)
+  (define contracts (base-first-or/c-ctcs ctc))
+  (define c-procs (map (λ (x) (contract-projection x)) contracts))
+  (define first-order-checks (map (λ (x) (contract-first-order x)) contracts))
+  (λ (blame)
+    (define disj-blame (blame-add-ior-context blame))
+    (define partial-contracts
+      (for/list ([c-proc (in-list c-procs)])
+        (c-proc disj-blame)))
+    (λ (val)
+      (let loop ([checks first-order-checks]
+                 [procs partial-contracts]
+                 [contracts contracts])
+        (cond
+          [(null? checks)
+           (raise-none-ior-matched blame val #f)]
+          [else
+           (cond
+             [((car checks) val)
+              ((car procs) val)]
+             [else
+              (loop (cdr checks)
+                    (cdr procs)
+                    (cdr contracts))])])))))
+
+(define (first-or/c-late-neg-proj ctc)  
+  (define ho-contracts (base-first-or/c-ctcs ctc))
+  (define c-projs (map get/build-late-neg-projection ho-contracts))
+  (define first-order-checks (map (λ (x) (contract-first-order x)) ho-contracts))
+  (λ (blame)
+    (define blame-w-context (blame-add-ior-context blame))
+    (define c-projs+blame (map (λ (c-proj) (c-proj blame-w-context)) c-projs))
+    (λ (val neg-party)
+      (let loop ([checks first-order-checks]
+                 [c-projs c-projs+blame]
+                 [contracts ho-contracts])
+        (cond
+          [(null? checks)
+           (raise-none-ior-matched blame val neg-party)]
+          [else
+           (cond
+             [((car checks) val)
+              ((car c-projs) val neg-party)]
+             [else
+              (loop (cdr checks)
+                    (cdr c-projs)
+                    (cdr contracts))])])))))
+
+(define (raise-none-ior-matched blame val neg-party)
+  (raise-blame-error blame val #:missing-party neg-party
+                              '("none of the branches of the first-or/c matched" given: "~e")
+                              val))
+
+(define (first-or/c-name ctc)
+  (apply build-compound-type-name 
+         'first-or/c
+         (base-first-or/c-ctcs ctc)))
+
+(define (first-or/c-first-order ctc)
+  (define preds (map contract-first-order (base-first-or/c-ctcs ctc)))
+  (λ (x) (ormap (lambda (p?) (p? x)) preds)))
+
+(define (first-or/c-list-contract? c)
+  (for/and ([c (in-list (base-first-or/c-ctcs c))])
+    (list-contract? c)))

 (define/final-prop (symbols s1 . s2s)
  (define ss (cons s1 s2s))
@ -444,7 +532,34 @@
                            ss)))
  (apply or/c ss))

+(define-struct base-first-or/c (ctcs)
+  #:property prop:custom-write custom-write-property-proc
+  #:property prop:orc-contract
+  (λ (this) (base-first-or/c-ctcs this)))

+(define-struct (chaperone-first-or/c base-first-or/c) ()
+  #:property prop:chaperone-contract
+  (parameterize ([skip-projection-wrapper? #t])
+    (build-chaperone-contract-property
+     #:projection first-or/c-proj
+     #:late-neg-projection first-or/c-late-neg-proj
+     #:name first-or/c-name
+     #:first-order first-or/c-first-order
+     #:stronger multi-or/c-stronger?
+     #:generate (λ (ctc) (or/c-generate ctc (base-first-or/c-ctcs ctc)))
+     #:exercise (λ (ctc) (or/c-exercise (base-first-or/c-ctcs ctc)))
+     #:list-contract? first-or/c-list-contract?)))
+(define-struct (impersonator-first-or/c base-first-or/c) ()
+  #:property prop:contract
+  (build-contract-property
+   #:projection first-or/c-proj
+   #:late-neg-projection first-or/c-late-neg-proj
+   #:name first-or/c-name
+   #:first-order first-or/c-first-order
+   #:stronger generic-or/c-stronger?
+   #:generate (λ (ctc) (or/c-generate ctc (base-first-or/c-ctcs ctc)))
+   #:exercise (λ (ctc) (or/c-exercise (base-first-or/c-ctcs ctc)))
+   #:list-contract? first-or/c-list-contract?))

 (define/final-prop (one-of/c . elems)
  (for ([arg (in-list elems)]