suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

finished case->

Browse Source 
svn: r8178
This commit is contained in:
Robby Findler 2008-01-02 01:24:55 +00:00
parent fca9c6b405
commit e7b5653dd6
4 changed files with 269 additions and 126 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/scheme/contract.ss
View File

@ -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)

181
collects/scheme/private/contract-arrow.ss
View File

@ -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)))

16
collects/scribblings/reference/contracts.scrbl
View File

@ -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

166
collects/tests/mzscheme/contract-test.ss
View File

@ -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?))