finished case->
svn: r8178
This commit is contained in:
parent
fca9c6b405
commit
e7b5653dd6
|
@ -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)
|
||||
|
||||
|
|
|
@ -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)))
|
||||
|
|
|
@ -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])]
|
||||
{
|
||||
case->.
|
||||
}
|
||||
[range range-expr (values range-expr ...) any])]{
|
||||
This contract form is designed to match
|
||||
@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
|
||||
|
|
|
@ -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?))
|
||||
|
||||
|
|
Loading…
Reference in New Issue
Block a user