unstable/contract: added if/c combinator

other minor changes

svn: r17171

collects/unstable/contract.ss

@@ -1,4 +1,5 @@
-#lang scheme
+#lang scheme/base
+(require scheme/contract)
 
 (define path-element?
   (or/c path-string? (symbols 'up 'same)))
@@ -13,7 +14,45 @@
 ;; Eli: If this gets in, there should also be versions for bytes, lists, and
 ;;   vectors.
 
+;; ryanc added:
+
+;; (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.
+  |#
+  (let ([then-ctc (coerce-contract 'if/c then/c)]
+        [else-ctc (coerce-contract 'if/c else/c)])
+    (define name (build-compound-type-name 'if/c predicate then-ctc else-ctc))
+    ;; Special case: if both flat contracts, make a flat contract.
+    (if (and (flat-contract? then-ctc)
+             (flat-contract? else-ctc))
+        ;; flat contract
+        (let ([then-pred (flat-contract-predicate then-ctc)]
+              [else-pred (flat-contract-predicate else-ctc)])
+          (define (pred x)
+            (if (predicate x) (then-pred x) (else-pred x)))
+          (flat-named-contract name pred))
+        ;; ho contract
+        (let ([then-proj ((proj-get then-ctc) then-ctc)]
+              [then-fo ((first-order-get then-ctc) then-ctc)]
+              [else-proj ((proj-get else-ctc) else-ctc)]
+              [else-fo ((first-order-get else-ctc) else-ctc)])
+          (define ((proj pos neg srcinfo name pos?) x)
+            (if (predicate x)
+                ((then-proj pos neg srcinfo name pos?) x)
+                ((else-proj pos neg srcinfo name pos?) x)))
+          (make-proj-contract
+           name
+           proj
+           (lambda (x) (if (predicate x) (then-fo x) (else-fo x))))))))
+
 (provide/contract
  [non-empty-string/c contract?]
  [path-element? contract?]
- [port-number? contract?])
+ [port-number? contract?]
+ [if/c (-> procedure? contract? contract? contract?)])

collects/unstable/mutated-vars.ss

@@ -13,8 +13,7 @@
   ;; syntax -> void
   (define (fmv/list lstx)
     (for-each find-mutated-vars (syntax->list lstx)))
-  ;(when (and (pair? (syntax->datum form))) (printf "called with ~a~n" (syntax->datum form)))
-  (kernel-syntax-case* form #f (define-type-alias-internal define-typed-struct-internal require/typed-internal)     
+  (kernel-syntax-case* form #f ()
     ;; what we care about: set!
     [(set! v e)
      (begin
@@ -51,5 +50,8 @@
 ;;   less general.
 ;; - What's with the typed-scheme literals?  If they were needed, then
 ;;   typed-scheme is probably broken now.
+;; ryanc:
+;; - The for-template is needed.
+;; - I've removed the bogus literals.
 
 (provide find-mutated-vars is-var-mutated?)

collects/unstable/scribblings/contract.scrbl

@@ -1,6 +1,7 @@
 #lang scribble/doc
 @(require scribble/base
           scribble/manual
+          "utils.ss"
           (for-label unstable/contract
                      scheme/contract
                      scheme/base))
@@ -9,8 +10,39 @@
 
 @defmodule[unstable/contract]
 
-@defthing[non-empty-string/c contract?]{Contract for non-empty strings.}
+@defthing[non-empty-string/c contract?]{
+Contract for non-empty strings.
+}
 
-@defthing[port-number? contract?]{Equivalent to @scheme[(between/c 1 65535)].}
+@defthing[port-number? contract?]{
+Equivalent to @scheme[(between/c 1 65535)].
+}
 
-@defthing[path-element? contract?]{Equivalent to @scheme[(or/c path-string? (symbols 'up 'same))].}
+@defthing[path-element? contract?]{
+Equivalent to @scheme[(or/c path-string? (symbols 'up 'same))].
+}
+
+@addition{Ryan Culpepper}
+
+@defproc[(if/c [predicate (-> any/c any/c)]
+               [then-contract contract?]
+               [else-contract contract?])
+         contract?]{
+
+Produces a contract that, when applied to a value, first tests the
+value with @scheme[predicate]; if @scheme[predicate] returns true, the
+@scheme[then-contract] is applied; otherwise, the
+@scheme[else-contract] is applied. The resulting contract is a flat
+contract if both @scheme[then-contract] and @scheme[else-contract] are
+flat contracts.
+
+For example, the following contract enforces that if a value is a
+procedure, it is a thunk; otherwise it can be any (non-procedure)
+value:
+  @schemeblock[(if/c procedure? (-> any) any/c)]
+Note that the following contract is @bold{not} equivalent:
+  @schemeblock[(or/c (-> any) any/c) (code:comment "wrong!")]
+The last contract is the same as @scheme[any/c] because
+@scheme[or/c] tries flat contracts before higher-order contracts.
+
+}

collects/unstable/struct.ss

@@ -3,24 +3,27 @@
 (require (for-syntax scheme/base
                      scheme/struct-info))
 (provide make
-         struct->list)
+         struct->list
+         (for-syntax get-struct-info))
+
+;; get-struct-info : identifier stx -> struct-info-list
+(define-for-syntax (get-struct-info id ctx)
+  (define (bad-struct-name x)
+    (raise-syntax-error #f "expected struct name" ctx x))
+  (unless (identifier? id)
+    (bad-struct-name id))
+  (let ([value (syntax-local-value id (lambda () #f))])
+    (unless (struct-info? value)
+      (bad-struct-name id))
+    (extract-struct-info value)))
 
 ;; (make struct-name field-expr ...)
 ;; Checks that correct number of fields given.
 (define-syntax (make stx)
-  (define (bad-struct-name x)
-    (raise-syntax-error #f "expected struct name" stx x))
-  (define (get-struct-info id)
-    (unless (identifier? id)
-      (bad-struct-name id))
-    (let ([value (syntax-local-value id (lambda () #f))])
-      (unless (struct-info? value)
-        (bad-struct-name id))
-      (extract-struct-info value)))
   (syntax-case stx ()
     [(make S expr ...)
      (let ()
-       (define info (get-struct-info #'S))
+       (define info (get-struct-info #'S stx))
        (define constructor (list-ref info 1))
        (define accessors (list-ref info 3))
        (unless (identifier? #'constructor)