finished case->

svn: r8178

collects/scheme/contract.ss

@@ -18,7 +18,7 @@ differences from v3:
          "private/contract-basic-opters.ss")
 
 (provide 
- opt/c define-opt/c ;(all-from "private/contract-opt.ss")
+ opt/c define-opt/c ;(all-from-out "private/contract-opt.ss")
  (except-out (all-from-out "private/contract-ds.ss")
              lazy-depth-to-look)
  

collects/scheme/private/contract-arrow.ss

@@ -6,19 +6,17 @@ v4 done:
 
 - added mandatory keywords to ->
 - rewrote ->* using new notation
+- rewrote ->d using new notation
+- rewrote case->
 
 v4 todo:
 
-- rewrite ->d
-  - to test:
-    ->d first-order
-
-- rewrite case->
-
 - rewrite object-contract to use new function combinators.
 
 - remove opt-> opt->* ->pp ->pp-rest ->r ->d*
 
+- remove extra checks from contract-arr-checks.ss (after object-contract is done).
+
 - change mzlib/contract to rewrite into scheme/contract (maybe?)
 
 - raise-syntax-errors
@@ -40,6 +38,7 @@ v4 todo:
 (provide ->
          ->*
          ->d
+         case->
          unconstrained-domain->
          the-unsupplied-arg)
 
@@ -974,3 +973,173 @@ v4 todo:
                               (list))))))
    (first-order-prop (λ (ctc) (λ (x) #f)))
    (stronger-prop (λ (this that) (eq? this that)))))
+
+
+;                                               
+;                                               
+;                                               
+;                                               
+;                                        ;      
+;    ;;;;; ;;;;;;;   ;;;;;   ;;;         ;;;    
+;   ;;;;;; ;;;;;;;; ;;;;;;  ;;;;;         ;;;;  
+;  ;;;;;;;     ;;;; ;;;;   ;;;; ;;          ;;; 
+;  ;;;;     ;;;;;;;  ;;;;  ;;;;;;; ;;;;;    ;;; 
+;  ;;;;;;; ;;  ;;;;   ;;;; ;;;;;   ;;;;;  ;;;;  
+;   ;;;;;; ;;;;;;;; ;;;;;;  ;;;;;;       ;;;    
+;    ;;;;;  ;; ;;;; ;;;;;    ;;;;        ;      
+;                                               
+;                                               
+;                                               
+
+
+(define-for-syntax (parse-rng stx rng)
+  (syntax-case rng (any values)
+    [any #f]
+    [(values x ...) #'(x ...)]
+    [x #'(x)]))
+
+(define-for-syntax (separate-out-doms/rst/rng stx case)
+  (syntax-case case (->)
+    [(-> doms ... #:rest rst rng)
+     (values #'(doms ...) #'rst (parse-rng stx #'rng))]
+    [(-> doms ... rng)
+     (values #'(doms ...) #f (parse-rng stx #'rng))]
+    [(x y ...)
+     (raise-syntax-error #f "expected ->" stx #'x)]
+    [_
+     (raise-syntax-error #f "expected ->" stx case)]))
+
+(define-for-syntax (parse-out-case stx case)
+  (let-values ([(doms rst rng) (separate-out-doms/rst/rng stx case)])
+    (with-syntax ([(dom-proj-x  ...) (generate-temporaries doms)]
+                  [(rst-proj-x) (generate-temporaries '(rest-proj-x))]
+                  [(rng-proj-x ...) (generate-temporaries (if rng rng '()))])
+      (with-syntax ([(dom-formals ...) (generate-temporaries doms)]
+                    [(rst-formal) (generate-temporaries '(rest-param))]
+                    [(rng-id ...) (if rng
+                                      (generate-temporaries rng)
+                                      '())])
+        #`(#,doms
+           #,rst
+           #,(if rng #`(list #,@rng) #f)
+           #,(length (syntax->list doms)) ;; spec
+           (dom-proj-x ... #,@(if rst #'(rst-proj-x) #'()))
+           (rng-proj-x ...)
+           (dom-formals ... . #,(if rst #'rst-formal '()))
+           #,(cond
+               [rng
+                (with-syntax ([(rng-exp ...) #'((rng-proj-x rng-id) ...)])
+                  (with-syntax ([rng (if (= 1 (length (syntax->list #'(rng-exp ...))))
+                                         (car (syntax->list #'(rng-exp ...)))
+                                         #`(values rng-exp ...))])
+                    (if rst
+                        #`(let-values ([(rng-id ...) (apply f (dom-proj-x dom-formals) ... (rst-proj-x rst-formal))])
+                            rng)
+                        #`(let-values ([(rng-id ...) (f (dom-proj-x dom-formals) ...)])
+                            rng))))]
+               [rst
+                #`(apply f (dom-proj-x dom-formals) ... (rst-proj-x rst-formal))]
+               [else
+                #`(f (dom-proj-x dom-formals) ...)]))))))
+
+(define-syntax (case-> stx)
+  (syntax-case stx ()
+    [(_ cases ...)
+     (begin 
+       (with-syntax ([(((dom-proj ...)
+                        rst-proj
+                        rng-proj
+                        spec
+                        (dom-proj-x ...)
+                        (rng-proj-x ...)
+                        formals
+                        body) ...)
+                      (map (λ (x) (parse-out-case stx x)) (syntax->list #'(cases ...)))])
+         #`(build-case-> (list (list dom-proj ...) ...)
+                         (list rst-proj ...)
+                         (list rng-proj ...)
+                         '(spec ...)
+                         (λ (chk
+                             #,@(apply append (map syntax->list (syntax->list #'((dom-proj-x ...) ...))))
+                             #,@(apply append (map syntax->list (syntax->list #'((rng-proj-x ...) ...)))))
+                           (λ (f)
+                             (chk f)
+                             (case-lambda
+                               [formals body] ...))))))]))
+
+;; dom-ctcs : (listof (listof contract))
+;; rst-ctcs : (listof contract)
+;; rng-ctcs : (listof (listof contract))
+;; specs : (listof (list boolean exact-positive-integer)) ;; indicates the required arities of the input functions
+;; wrapper : (->* () () (listof contract?) (-> procedure? procedure?)) -- generates a wrapper from projections
+(define-struct/prop case-> (dom-ctcs rst-ctcs rng-ctcs specs wrapper)
+  ((proj-prop
+    (λ (ctc)
+      (let* ([to-proj (λ (c) ((proj-get c) c))]
+             [dom-ctcs (map to-proj (get-case->-dom-ctcs ctc))]
+             [rng-ctcs (map to-proj (get-case->-rng-ctcs ctc))]
+             [rst-ctcs (case->-rst-ctcs ctc)]
+             [specs (case->-specs ctc)])
+        (λ (pos-blame neg-blame src-info orig-str)
+          (let ([projs (append (map (λ (f) (f neg-blame pos-blame src-info orig-str)) dom-ctcs)
+                               (map (λ (f) (f pos-blame neg-blame src-info orig-str)) rng-ctcs))]
+                [chk
+                 (λ (val) 
+                   (cond
+                     [(null? specs)
+                      (unless (procedure? val)
+                        (raise-contract-error val
+                                              src-info
+                                              pos-blame
+                                              orig-str
+                                              "expected a procedure"))]
+                     [else
+                      (for-each 
+                       (λ (dom-length has-rest?)
+                         (if has-rest?
+                             (check-procedure/more val dom-length '() '() src-info pos-blame orig-str)
+                             (check-procedure val dom-length 0 '() '() src-info pos-blame orig-str)))
+                       specs rst-ctcs)]))])
+            (apply (case->-wrapper ctc)
+                   chk
+                   projs))))))
+   (name-prop (λ (ctc) (apply
+                        build-compound-type-name
+                        'case->
+                        (map (λ (dom rst range)
+                               (apply 
+                                build-compound-type-name 
+                                '-> 
+                                (append dom
+                                        (if rst
+                                            (list '#:rest rst)
+                                            '())
+                                        (list
+                                         (cond
+                                           [(not range) 'any]
+                                           [(and (pair? range) (null? (cdr range)))
+                                            (car range)]
+                                           [else (apply build-compound-type-name 'values range)])))))
+                             (case->-dom-ctcs ctc)
+                             (case->-rst-ctcs ctc)
+                             (case->-rng-ctcs ctc)))))
+   (first-order-prop (λ (ctc) #f))
+   (stronger-prop (λ (this that) #f))))
+
+(define (build-case-> dom-ctcs rst-ctcs rng-ctcs specs wrapper)
+  (make-case-> (map (λ (l) (map (λ (x) (coerce-contract 'case-> x)) l)) dom-ctcs)
+               (map (λ (x) (and x (coerce-contract 'case-> x))) rst-ctcs)
+               (map (λ (l) (and l (map (λ (x) (coerce-contract 'case-> x)) l))) rng-ctcs)
+               specs
+               wrapper))
+  
+
+(define (get-case->-dom-ctcs ctc)
+  (apply append
+         (map (λ (doms rst) (if rst
+                                (append doms (list rst))
+                                doms))
+              (case->-dom-ctcs ctc)
+              (case->-rst-ctcs ctc))))
+
+(define (get-case->-rng-ctcs ctc) (apply append (case->-rng-ctcs ctc)))

collects/scribblings/reference/contracts.scrbl

@@ -426,16 +426,20 @@ argument) is visible in all of the sub-expressions of
 visible in the subexpressions of the @scheme[dep-range].
 }
 
-@;{
+@defform*/subs[#:literals (any values ->)
-@defform*/subs[#:literals (any values)
 [(case-> (-> dom-expr ... rest range) ...)]
 ([rest (code:line) (code:line #:rest rest-expr)]
- [range range-expr (values range-expr ...) any])]
+ [range range-expr (values range-expr ...) any])]{
-{
+This contract form is designed to match
-case->.
+@scheme[case-lambda]. Each argument to @scheme[case->] is a
-}
+contract that governs a clause in the
+@scheme[case-lambda]. If the @scheme[#:rest] keyword is
+present, the corresponding clause must accept an arbitrary
+number of arguments. The @scheme[range] specification is
+just like that for @scheme[->] and @scheme[->*]. 
 }
 
+
 @defform[(unconstrained-domain-> res-expr ...)]{
 
 Constructs a contract that accepts a function, but makes no constraint

collects/tests/mzscheme/contract-test.ss

@@ -1302,7 +1302,7 @@
      2)
    1)
 
-(test/spec-passed/result
+  (test/spec-passed/result
    '->d28
    '(call-with-values
      (λ ()
@@ -1322,6 +1322,46 @@
                'pos
                'neg)))
   
+  (test/pos-blame
+   '->d-arity1
+   '(contract (->d ([x number?]) () any) (λ () 1) 'pos 'neg))
+  
+  (test/pos-blame
+   '->d-arity2
+   '(contract (->d ([x number?]) () any) (λ (x #:y y) 1) 'pos 'neg))
+  
+  (test/spec-passed
+   '->d-arity3
+   '(contract (->d ([x number?] #:y [y integer?]) () any) (λ (x #:y y) 1) 'pos 'neg))
+  
+  (test/pos-blame
+   '->d-arity4
+   '(contract (->d () ([x integer?]) any) (λ (x) 1) 'pos 'neg))
+  
+  (test/pos-blame
+   '->d-arity5
+   '(contract (->d () ([x integer?]) any) (λ () 1) 'pos 'neg))
+  
+  (test/spec-passed
+   '->d-arity6
+   '(contract (->d () ([x integer?]) any) (λ ([x 1]) 1) 'pos 'neg))
+  
+  (test/pos-blame
+   '->d-arity7
+   '(contract (->d () (#:x [x integer?]) any) (λ ([x 1]) 1) 'pos 'neg))
+  
+  (test/pos-blame
+   '->d-arity8
+   '(contract (->d () (#:x [x integer?]) any) (λ () 1) 'pos 'neg))
+  
+  (test/pos-blame
+   '->d-arity8
+   '(contract (->d () (#:x [x integer?]) any) (λ (#:x x) 1) 'pos 'neg))
+  
+  (test/spec-passed
+   '->d-arity10
+   '(contract (->d () (#:x [x integer?]) any) (λ (#:x [x 1]) 1) 'pos 'neg))
+    
   (test/pos-blame
    '->d-pp1
    '((contract (->d ([x number?]) () #:pre-cond (= x 1) [result number?] #:post-cond (= x 2))
@@ -1434,6 +1474,18 @@
                'neg)
      1))
 
+  (test/neg-blame
+   '->d-protect-shared-state
+   '(let ([x 1])
+      ((contract (let ([save #f]) 
+                   (-> (->d () () #:pre-cond (set! save x) [range any/c] #:post-cond (= save x))
+                       any))
+                 (λ (t) (t))
+                 'pos
+                 'neg)
+       (lambda () (set! x 2)))))
+  
+  
   ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   ;;
   ;;  make sure the variables are all bound properly
@@ -1533,8 +1585,6 @@
                'pos
                'neg)))
   
-#|
-  
 ;                                               
 ;                                               
 ;                                               
@@ -1552,14 +1602,14 @@
 ;                                               
 
 
-  (test/pos-blame
+  (test/spec-passed
    'contract-case->0a
    '(contract (case->)
               (lambda (x) x)
               'pos
               'neg))
   
-  (test/pos-blame
+  (test/spec-passed
    'contract-case->0b
    '(contract (case->)
               (lambda () 1)
@@ -1580,6 +1630,7 @@
               'pos
               'neg))
   
+  
   (test/pos-blame
    'contract-case->1
    '(contract (case-> (integer? integer? . -> . integer?) (integer? . -> . integer?))
@@ -1639,15 +1690,16 @@
 
   (test/pos-blame
    'contract-case->7
-   '((contract (case-> (integer? integer? . -> . integer?) (->* (integer?) any/c (boolean?)))
+   '((contract (case-> (integer? integer? . -> . integer?) (-> integer? #:rest any/c boolean?))
                (lambda x #\a)
                'pos
                'neg)
      1 2))
 
+  
   (test/pos-blame
    'contract-case->8
-   '((contract (case-> (integer? integer? . -> . integer?) (->* (integer?) any/c (boolean?)))
+   '((contract (case-> (integer? integer? . -> . integer?) (-> integer? #:rest any/c boolean?))
                (lambda x #t)
                'pos
                'neg)
@@ -1655,47 +1707,12 @@
  
   (test/spec-passed
    'contract-case->8
-   '((contract (case-> (integer? integer? . -> . integer?) (->* (integer?) any/c (boolean?)))
+   '((contract (case-> (integer? integer? . -> . integer?) (-> integer? #:rest any/c boolean?))
                (lambda x 1)
                'pos
                'neg)
      1 2))
   
-  (test/spec-passed
-   'contract-case->9
-   '((contract (case-> (->r ([x number?]) (<=/c x)))
-               (lambda (x) (- x 1))
-               'pos
-               'neg)
-     1))
-  
-  (test/spec-passed
-   'contract-case->9b
-   '((contract (case-> (->r ([x number?]) (<=/c x)) (-> integer? integer? integer?))
-               (case-lambda 
-                 [(x) (- x 1)]
-                 [(x y) x])
-               'pos
-               'neg)
-     1))
-  
-  (test/pos-blame 
-   'contract-case->10
-   '((contract (case-> (->r ([x number?]) (<=/c x)))
-               (lambda (x) (+ x 1))
-               'pos
-               'neg)
-     1))
-  
-  (test/pos-blame 
-   'contract-case->10b
-   '((contract (case-> (->r ([x number?]) (<=/c x)) (-> number? number? number?))
-               (case-lambda
-                 [(x) (+ x 1)]
-                 [(x y) x])
-               'pos
-               'neg)
-     1))
   
   (test/spec-passed/result
    'contract-case->11
@@ -1715,37 +1732,6 @@
             (f 'x (open-input-string (format "~s" "string")))))
    (list #\a #f "xstring"))
     
-  (test/neg-blame
-   'contract-d-protect-shared-state
-   '(let ([x 1])
-      ((contract ((->d (lambda () (let ([pre-x x]) (lambda (res) (= x pre-x)))))
-                  . -> .
-                  (lambda (x) #t))
-                 (lambda (thnk) (thnk))
-                 'pos
-                 'neg)
-       (lambda () (set! x 2)))))
-  
-  #;
-  (test/neg-blame
-   'combo1
-   '(let ([cf (contract (case->
-                         ((class? . ->d . (lambda (%) (lambda (x) #f))) . -> . void?)
-                         ((class? . ->d . (lambda (%) (lambda (x) #f))) boolean? . -> . void?))
-                        (letrec ([c% (class object% (super-instantiate ()))]
-                                 [f
-                                  (case-lambda
-                                    [(class-maker) (f class-maker #t)]
-                                    [(class-maker b) 
-                                     (class-maker c%)
-                                     (void)])])
-                          f)
-                        'pos
-                        'neg)])
-      (cf (lambda (x%) 'going-to-be-bad))))   
-
-  
-    
   ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   ;;                                                        ;;
   ;;   case-> arity checking tests                          ;;
@@ -1757,16 +1743,6 @@
   (test/well-formed '(case-> (-> integer? integer?) (-> integer? integer? any)))
   (test/well-formed '(case-> (-> integer? any) (-> integer? integer? any)))
     
-  (test/well-formed '(case-> (->d (lambda x any/c)) (-> integer? integer?)))
-
-  (test/well-formed '(case-> (->* (any/c any/c) (integer?)) (-> integer? integer?)))
-  (test/well-formed '(case-> (->* (any/c any/c) any/c (integer?)) (-> integer? integer?)))
-  (test/well-formed '(case-> (->* (any/c any/c) any/c any) (-> integer? integer?)))
-  
-  (test/well-formed '(case-> (->d* (any/c any/c) (lambda x any/c)) (-> integer? integer?)))
-  (test/well-formed '(case-> (->d* (any/c any/c) any/c (lambda x any/c)) (-> integer? integer?)))
-|#
-  
 ;                                                                                                                 
 ;                                                                                                                 
 ;                                                                                                                 
@@ -1812,19 +1788,18 @@
    'unconstrained-domain->4
    '((contract (unconstrained-domain-> number?) (λ (x) x) 'pos 'neg) #f))
   
-#|
   (test/spec-passed/result
    'unconstrained-domain->5
-   '((contract (->r ([size natural-number/c]
+   '((contract (->d ([size natural-number/c]
                      [proc (and/c (unconstrained-domain-> number?)
                                   (λ (p) (procedure-arity-includes? p size)))])
-                    number?)
+                    ()
+                    [range number?])
                (λ (i f) (apply f (build-list i add1)))
                'pos
                'neg)
      10 +)
    55)
-|#
   
 ;                              
 ;                              
@@ -4695,20 +4670,15 @@ so that propagation occurs.
   (test-name '(->d () () #:pre-cond ... [x ...] #:post-cond ...) (->d () () #:pre-cond #t [q number?] #:post-cond #t))
   (test-name '(->d () () [x ...] #:post-cond ...) (->d () () [q number?] #:post-cond #t))
   
-#|
-  (test-name '(case-> (->r ((x ...)) ...) (-> integer? integer? integer?))
-             (case-> (->r ((x number?)) number?) (-> integer? integer? integer?)))
-  (test-name '(->r ((x ...) (y ...) (z ...)) ...)
-             (case-> (->r ((x number?) (y boolean?) (z pair?)) number?)))
-  (test-name '(case-> (->r ((x ...) (y ...) (z ...)) ...)
-                      (-> integer? integer? integer?))
-             (case-> (->r ((x number?) (y boolean?) (z pair?)) number?)
-                     (-> integer? integer? integer?)))
   (test-name '(case->) (case->))
-  
+  (test-name '(case-> (-> integer? any) (-> boolean? boolean? any) (-> char? char? char? any))
+             (case-> (-> integer? any) (-> boolean? boolean? any) (-> char? char? char? any)))
   (test-name '(case-> (-> integer? integer?) (-> integer? integer? integer?))
              (case-> (-> integer? integer?) (-> integer? integer? integer?)))
-|#
+  (test-name '(case-> (-> integer? #:rest any/c any)) (case-> (-> integer? #:rest any/c any)))
+  (test-name '(case-> (-> integer? #:rest any/c (values boolean? char? number?))) 
+             (case-> (-> integer? #:rest any/c (values boolean? char? number?))))
+  (test-name '(case-> (-> integer? (values))) (case-> (-> integer? (values))))
   
   (test-name '(unconstrained-domain-> number?) (unconstrained-domain-> number?))