added the _ special case to ->d
svn: r8998
This commit is contained in:
Robby Findler
parent
b64d03d932
commit
9ba432ab9c
|
|
@ -100,16 +100,15 @@
|
|||
|
||||
(preferences:add-panel
|
||||
(-> (or/c string? (cons/c string? (listof string?)))
|
||||
(let ([old-children '()])
|
||||
(->d ([parent (is-a?/c area-container-window<%>)])
|
||||
()
|
||||
#:pre-cond (set! old-children (send parent get-children))
|
||||
[child
|
||||
(λ (child)
|
||||
(and (is-a? child area-container-window<%>)
|
||||
(andmap eq?
|
||||
(append old-children (list child))
|
||||
(send parent get-children))))]))
|
||||
(->d ([parent (is-a?/c area-container-window<%>)])
|
||||
()
|
||||
[_
|
||||
(let ([old-children (send parent get-children)])
|
||||
(and/c (is-a?/c area-container-window<%>)
|
||||
(λ (child)
|
||||
(andmap eq?
|
||||
(append old-children (list child))
|
||||
(send parent get-children)))))])
|
||||
void?)
|
||||
(labels f)
|
||||
@{@scheme[preferences:add-preference-panel] adds the result of
|
||||
|
|
|
|||
|
|
@ -2,20 +2,10 @@
|
|||
|
||||
#|
|
||||
|
||||
v4 done:
|
||||
|
||||
- added mandatory keywords to ->
|
||||
- rewrote ->* using new notation
|
||||
- rewrote ->d using new notation
|
||||
- rewrote case->
|
||||
- rewrote object-contract
|
||||
|
||||
v4 todo:
|
||||
|
||||
- add case-> to object-contract
|
||||
|
||||
- improve the generation of wrappers to avoid 'apply' and to make keywords work.
|
||||
|
||||
- test object-contract with keywords (both optional and mandatory)
|
||||
|
||||
- change mzlib/contract to rewrite into scheme/contract (maybe?)
|
||||
|
|
@ -776,35 +766,60 @@ v4 todo:
|
|||
[[id ctc] #'((id) (ctc))]
|
||||
[x (raise-syntax-error #f "expected binding pair or any" stx #'x)])]
|
||||
[mtd? (syntax-parameter-value #'making-a-method)])
|
||||
(let ([dup (check-duplicate-identifier (syntax->list #'(dom-params ... rng-params ...)))])
|
||||
(when dup
|
||||
(raise-syntax-error #f "duplicate identifier" stx dup)))
|
||||
#`(syntax-parameterize
|
||||
((making-a-method #f))
|
||||
(build-->d mtd?
|
||||
(list (λ (dom-params ...) mandatory-doms) ...)
|
||||
(list (λ (dom-params ...) optional-doms) ...)
|
||||
(list (λ (dom-params ...) mandatory-kwd-dom) ...)
|
||||
(list (λ (dom-params ...) optional-kwd-dom) ...)
|
||||
#,(if id/rest
|
||||
(with-syntax ([(id rst-ctc) id/rest])
|
||||
#`(λ (dom-params ...) rst-ctc))
|
||||
#f)
|
||||
#,(if pre-cond
|
||||
#`(λ (dom-params ...) #,pre-cond)
|
||||
#f)
|
||||
#,(syntax-case #'rng-ctcs ()
|
||||
[#f #f]
|
||||
[(ctc ...) #'(list (λ (rng-params ... dom-params ...) ctc) ...)])
|
||||
#,(if post-cond
|
||||
#`(λ (rng-params ... dom-params ...) #,post-cond)
|
||||
#f)
|
||||
'(mandatory-kwd ...)
|
||||
'(optional-kwd ...)
|
||||
(λ (f)
|
||||
#,(add-name-prop
|
||||
(syntax-local-infer-name stx)
|
||||
#`(λ args (apply f args)))))))))))]))
|
||||
(let ([rng-underscores?
|
||||
(let ([is-underscore?
|
||||
(λ (x)
|
||||
(syntax-case x (_)
|
||||
[_ #t]
|
||||
[else #f]))])
|
||||
(cond
|
||||
[(andmap is-underscore? (syntax->list #'(rng-params ...)))
|
||||
#t]
|
||||
[(ormap (λ (x) (and (is-underscore? x) x))
|
||||
(syntax->list #'(rng-params ...)))
|
||||
=>
|
||||
(λ (id)
|
||||
(raise-syntax-error '->d
|
||||
"expected all of the identifiers to be underscores, or none of them to be"
|
||||
stx
|
||||
id))]
|
||||
[else #f]))])
|
||||
(let ([dup (check-duplicate-identifier
|
||||
(append (if rng-underscores?
|
||||
'()
|
||||
(syntax->list #'(rng-params ...)))
|
||||
(syntax->list #'(dom-params ...))))])
|
||||
(when dup
|
||||
(raise-syntax-error #f "duplicate identifier" stx dup)))
|
||||
#`(syntax-parameterize
|
||||
((making-a-method #f))
|
||||
(build-->d mtd?
|
||||
(list (λ (dom-params ...) mandatory-doms) ...)
|
||||
(list (λ (dom-params ...) optional-doms) ...)
|
||||
(list (λ (dom-params ...) mandatory-kwd-dom) ...)
|
||||
(list (λ (dom-params ...) optional-kwd-dom) ...)
|
||||
#,(if id/rest
|
||||
(with-syntax ([(id rst-ctc) id/rest])
|
||||
#`(λ (dom-params ...) rst-ctc))
|
||||
#f)
|
||||
#,(if pre-cond
|
||||
#`(λ (dom-params ...) #,pre-cond)
|
||||
#f)
|
||||
#,(syntax-case #'rng-ctcs ()
|
||||
[#f #f]
|
||||
[(ctc ...)
|
||||
(if rng-underscores?
|
||||
#'(box (list (λ (dom-params ...) ctc) ...))
|
||||
#'(list (λ (rng-params ... dom-params ...) ctc) ...))])
|
||||
#,(if post-cond
|
||||
#`(λ (rng-params ... dom-params ...) #,post-cond)
|
||||
#f)
|
||||
'(mandatory-kwd ...)
|
||||
'(optional-kwd ...)
|
||||
(λ (f)
|
||||
#,(add-name-prop
|
||||
(syntax-local-infer-name stx)
|
||||
#`(λ args (apply f args))))))))))))]))
|
||||
|
||||
(define (->d-proj ->d-stct)
|
||||
(let ([non-kwd-ctc-count (+ (length (->d-mandatory-dom-ctcs ->d-stct))
|
||||
|
|
@ -879,12 +894,28 @@ v4 todo:
|
|||
(error 'shouldnt\ happen))]
|
||||
[else (cons (invoke-dep-ctc (car non-kwd-ctcs) dep-pre-args (car args) neg-blame pos-blame src-info orig-str)
|
||||
(loop (cdr args)
|
||||
(cdr non-kwd-ctcs)))])))))])
|
||||
(if (->d-range ->d-stct)
|
||||
(cdr non-kwd-ctcs)))])))))]
|
||||
[rng (let ([rng (->d-range ->d-stct)])
|
||||
(cond
|
||||
[(not rng) #f]
|
||||
[(box? rng)
|
||||
(map (λ (val)
|
||||
(keyword-apply
|
||||
val
|
||||
kwd-args
|
||||
kwd-arg-vals
|
||||
(append
|
||||
;; this parameter (if necc.)
|
||||
(if (->d-mtd? ->d-stct) (list (car raw-orig-args)) '())
|
||||
orig-args)))
|
||||
(unbox rng))]
|
||||
[else rng]))]
|
||||
[rng-underscore? (box? (->d-range ->d-stct))])
|
||||
(if rng
|
||||
(call-with-values
|
||||
thnk
|
||||
(λ orig-results
|
||||
(let* ([range-count (length (->d-range ->d-stct))]
|
||||
(let* ([range-count (length rng)]
|
||||
[post-args (append orig-results raw-orig-args)]
|
||||
[post-non-kwd-arg-count (+ non-kwd-ctc-count range-count)]
|
||||
[dep-post-args (build-dep-ctc-args post-non-kwd-arg-count
|
||||
|
|
@ -909,21 +940,26 @@ v4 todo:
|
|||
(apply
|
||||
values
|
||||
(let loop ([results orig-results]
|
||||
[result-contracts (->d-range ->d-stct)])
|
||||
[result-contracts rng])
|
||||
(cond
|
||||
[(null? result-contracts) '()]
|
||||
[else
|
||||
(cons (invoke-dep-ctc (car result-contracts) dep-post-args (car results) pos-blame neg-blame src-info orig-str)
|
||||
(loop (cdr results) (cdr result-contracts)))]))))))
|
||||
(cons
|
||||
(invoke-dep-ctc (car result-contracts)
|
||||
(if rng-underscore? #f dep-post-args)
|
||||
(car results) pos-blame neg-blame src-info orig-str)
|
||||
(loop (cdr results) (cdr result-contracts)))]))))))
|
||||
(thnk))))])
|
||||
(make-keyword-procedure kwd-proc
|
||||
((->d-name-wrapper ->d-stct)
|
||||
(λ args
|
||||
(apply kwd-proc '() '() args)))))))))
|
||||
|
||||
;; invoke-dep-ctc : (...? -> ctc) (listof tst) val pos-blame neg-blame src-info orig-src -> tst
|
||||
;; invoke-dep-ctc : (...? -> ctc) (or/c #f (listof tst)) val pos-blame neg-blame src-info orig-src -> tst
|
||||
(define (invoke-dep-ctc dep-ctc dep-args val pos-blame neg-blame src-info orig-str)
|
||||
(let ([ctc (coerce-contract '->d (apply dep-ctc dep-args))])
|
||||
(let ([ctc (coerce-contract '->d (if dep-args
|
||||
(apply dep-ctc dep-args)
|
||||
dep-ctc))])
|
||||
((((proj-get ctc) ctc) pos-blame neg-blame src-info orig-str) val)))
|
||||
|
||||
;; build-dep-ctc-args : number (listof any) boolean (listof keyword) (listof keyword) (listof any)
|
||||
|
|
@ -976,14 +1012,20 @@ v4 todo:
|
|||
optional-kwds
|
||||
name-wrapper)))
|
||||
|
||||
;; in the struct type descriptions "d???" refers to the arguments (domain) of the function that
|
||||
;; is under the contract, and "dr???" refers to the arguments & the results of the function that
|
||||
;; is under the contract.
|
||||
;; the `box' in the range only serves to differentiate between range contracts that depend on
|
||||
;; both the domain and the range from those that depend only on the domain (and thus, those
|
||||
;; that can be applied early)
|
||||
(define-struct/prop ->d (mtd? ;; boolean; indicates if this is a contract on a method, for error reporing purposes.
|
||||
mandatory-dom-ctcs ;; (listof (-> ??? ctc))
|
||||
optional-dom-ctcs ;; (listof (-> ??? ctc))
|
||||
keyword-ctcs ;; (listof (-> ??? ctc))
|
||||
rest-ctc ;; (or/c false/c (-> ??? ctc))
|
||||
pre-cond ;; (-> ??? boolean)
|
||||
range ;; (or/c false/c (-> ??? ctc))
|
||||
post-cond ;; (-> ??? boolean)
|
||||
mandatory-dom-ctcs ;; (listof (-> d??? ctc))
|
||||
optional-dom-ctcs ;; (listof (-> d??? ctc))
|
||||
keyword-ctcs ;; (listof (-> d??? ctc))
|
||||
rest-ctc ;; (or/c false/c (-> d??? ctc))
|
||||
pre-cond ;; (-> d??? boolean)
|
||||
range ;; (or/c false/c (listof (-> dr??? ctc)) (box (listof (-> r??? ctc))))
|
||||
post-cond ;; (-> dr??? boolean)
|
||||
keywords ;; (listof keywords) -- sorted by keyword<
|
||||
mandatory-keywords ;; (listof keywords) -- sorted by keyword<
|
||||
optional-keywords ;; (listof keywords) -- sorted by keyword<
|
||||
|
|
@ -1019,6 +1061,14 @@ v4 todo:
|
|||
,(let ([range (->d-range ctc)])
|
||||
(cond
|
||||
[(not range) 'any]
|
||||
[(box? range)
|
||||
(let ([range (unbox range)])
|
||||
(cond
|
||||
[(and (not (null? range))
|
||||
(null? (cdr range)))
|
||||
`[_ ...]]
|
||||
[else
|
||||
`(values ,@(map (λ (x) `(_ ...)) range))]))]
|
||||
[(and (not (null? range))
|
||||
(null? (cdr range)))
|
||||
`[,(next-id) ...]]
|
||||
|
|
|
|||
|
|
@ -494,18 +494,28 @@ improve method arity mismatch contract violation error messages?
|
|||
(syntax-case x ()
|
||||
[(a b) #'(slc #'b)]
|
||||
[else #f]))
|
||||
(syntax->list #'(mutator-codes/mutator-new-names ...)))])
|
||||
(syntax (begin
|
||||
(provide (rename-out [id-rename struct-name]))
|
||||
(define-syntax id-rename
|
||||
(let ([slc (syntax-local-certifier)])
|
||||
(list (slc #'-struct:struct-name)
|
||||
(slc #'constructor-new-name)
|
||||
(slc #'predicate-new-name)
|
||||
(list (slc #'rev-selector-new-names) ...
|
||||
(slc #'rev-selector-old-names) ...)
|
||||
(list mutator-id-info ...)
|
||||
super-id))))))]
|
||||
(syntax->list #'(mutator-codes/mutator-new-names ...)))]
|
||||
[(exported-selector-ids ...) (reverse selector-ids)]
|
||||
)
|
||||
#`(begin
|
||||
(provide (rename-out [id-rename struct-name]))
|
||||
(define-syntax id-rename
|
||||
(let ([slc (syntax-local-certifier)])
|
||||
#;
|
||||
(list (slc #'-struct:struct-name)
|
||||
(slc #'#,constructor-id)
|
||||
(slc #'#,predicate-id)
|
||||
(list (slc #'exported-selector-ids) ...)
|
||||
(list mutator-id-info ...)
|
||||
super-id)
|
||||
;#;
|
||||
(list (slc #'-struct:struct-name)
|
||||
(slc #'constructor-new-name)
|
||||
(slc #'predicate-new-name)
|
||||
(list (slc #'rev-selector-new-names) ...
|
||||
(slc #'rev-selector-old-names) ...)
|
||||
(list mutator-id-info ...)
|
||||
super-id)))))]
|
||||
[struct:struct-name struct:struct-name]
|
||||
[-struct:struct-name -struct:struct-name]
|
||||
[struct-name struct-name]
|
||||
|
|
|
|||
|
|
@ -3,6 +3,7 @@
|
|||
scribble/eval
|
||||
"guide-utils.ss"
|
||||
"contracts-utils.ss"
|
||||
(for-label framework/framework)
|
||||
(for-label scheme/contract)
|
||||
(for-label scheme/gui))
|
||||
|
||||
|
|
@ -395,6 +396,61 @@ balance. The resulting contract checks whether an account
|
|||
has a balance that is larger or smaller, depending on the
|
||||
given comparison operator, than the original balance.
|
||||
|
||||
@ctc-section[#:tag "arrow-d-eval-order"]{Ensuring that a function properly modifies state}
|
||||
|
||||
The @scheme[->d] contract combinator can also ensure that a
|
||||
function only modifies state according to certain
|
||||
constraints. For example, consider this contract
|
||||
(it is a slightly simplified from the function
|
||||
@scheme[preferences:add-panel] in the framework):
|
||||
@schemeblock[
|
||||
(->d ([parent (is-a?/c area-container-window<%>)])
|
||||
()
|
||||
[_
|
||||
(let ([old-children (send parent get-children)])
|
||||
(λ (child)
|
||||
(andmap eq?
|
||||
(append old-children (list child))
|
||||
(send parent get-children))))])
|
||||
]
|
||||
It says that the function accepts a single argument, named
|
||||
@scheme[parent], and that @scheme[parent] must be
|
||||
an object matching the interface @scheme[area-container-window<%>].
|
||||
|
||||
The range contract ensures that the function only modifies
|
||||
the children of @scheme[parent] by adding a new child to the
|
||||
front of the list. It accomplishes this by using the
|
||||
@scheme[_] instead of a normal identifier, which tells the
|
||||
contract library that the range contract does not depend on
|
||||
the values of any of the results, and thus the contract
|
||||
library evaluates the expression following the @scheme[_]
|
||||
when the function is called, instead of when it
|
||||
returns. Therefore the call to the @scheme[get-children] method
|
||||
happens before the function under the contract is called.
|
||||
When the function under contract returns, its result is
|
||||
passed in as @scheme[child], and the contract ensures that
|
||||
the children after the function return are the same as the
|
||||
children before the function called, but with one more
|
||||
child, at the front of the list.
|
||||
|
||||
To see the difference in a toy example that focuses
|
||||
on this point, consider this program
|
||||
@schememod[
|
||||
scheme
|
||||
(define x '())
|
||||
(define (get-x) x)
|
||||
(define (f) (set! x (cons 'f x)))
|
||||
(provide/contract
|
||||
[f (->d () () [_ (begin (set! x (cons 'ctc x)) any/c)])]
|
||||
[get-x (-> (listof symbol?))])
|
||||
]
|
||||
If you were to require this module, call @scheme[f], then
|
||||
the result of @scheme[get-x] would be @scheme['(f ctc)]. In
|
||||
contrast, if the contract for @scheme[f] were
|
||||
@schemeblock[(->d () () [res (begin (set! x (cons 'ctc x)) any/c)])]
|
||||
(only changing the underscore to @scheme[res]), then
|
||||
the result of @scheme[get-x] would be @scheme['(ctc f)].
|
||||
|
||||
@ctc-section[#:tag "case-lambda"]{Contracts for @scheme[case-lambda]}
|
||||
|
||||
Dybvig, in Chapter 5 of the
|
||||
|
|
|
|||
|
|
@ -417,6 +417,8 @@ symbols, and that return a symbol.
|
|||
[dependent-rest (code:line) (code:line #:rest id rest-expr)]
|
||||
[pre-cond (code:line) (code:line #:pre-cond boolean-expr)]
|
||||
[dep-range any
|
||||
(code:line [_ range-expr] post-cond)
|
||||
(code:line (values [_ range-expr] ...) post-cond)
|
||||
(code:line [id range-expr] post-cond)
|
||||
(code:line (values [id range-expr] ...) post-cond)]
|
||||
[post-cond (code:line) (code:line #:post-cond boolean-expr)]
|
||||
|
|
@ -445,6 +447,12 @@ Each of the @scheme[id]s on an argument (including the rest
|
|||
argument) is visible in all of the sub-expressions of
|
||||
@scheme[->d]. Each of the @scheme[id]s on a result is
|
||||
visible in the subexpressions of the @scheme[dep-range].
|
||||
|
||||
If the identifier position of the range contract is
|
||||
@scheme[_] (an underscore), then the range contract
|
||||
expressions are evaluated when the function is called (and
|
||||
the underscore is not bound in the range). Otherwise the
|
||||
range expressions are evaluated when the function returns.
|
||||
}
|
||||
|
||||
@defform*/subs[#:literals (any values ->)
|
||||
|
|
|
|||
|
|
@ -1606,6 +1606,42 @@
|
|||
'pos
|
||||
'neg)))
|
||||
|
||||
(test/pos-blame
|
||||
'->d-underscore1
|
||||
'((contract (->d ([b (box/c integer?)])
|
||||
()
|
||||
[_ (let ([old (unbox b)])
|
||||
(and/c
|
||||
void?
|
||||
(λ (new)
|
||||
(printf "old ~a new ~a\n" old (unbox b))
|
||||
(= old (unbox b)))))])
|
||||
(λ (b)
|
||||
(set-box! b (+ (unbox b) 1)))
|
||||
'pos
|
||||
'neg)
|
||||
(box 1)))
|
||||
|
||||
(test/spec-passed/result
|
||||
'->d-underscore2
|
||||
'(let ([x '()])
|
||||
((contract (->d () () [_ (begin (set! x (cons 'ctc x)) any/c)])
|
||||
(λ () (set! x (cons 'body x)))
|
||||
'pos
|
||||
'neg))
|
||||
x)
|
||||
'(body ctc))
|
||||
|
||||
(test/spec-passed/result
|
||||
'->d-underscore3
|
||||
'(let ([x '()])
|
||||
((contract (->d () () [res (begin (set! x (cons 'ctc x)) any/c)])
|
||||
(λ () (set! x (cons 'body x)))
|
||||
'pos
|
||||
'neg))
|
||||
x)
|
||||
'(ctc body))
|
||||
|
||||
;
|
||||
;
|
||||
;
|
||||
|
|
@ -5515,6 +5551,46 @@ so that propagation occurs.
|
|||
(eval '(require 'provide/contract27c))
|
||||
(eval 'provide/contract27ans))
|
||||
"me")
|
||||
|
||||
#;
|
||||
(test/spec-passed/result
|
||||
'provide/contract28
|
||||
'(begin
|
||||
(eval '(module provide/contract28-m1 scheme/base
|
||||
(require scheme/contract)
|
||||
(define-struct repair () #:transparent)
|
||||
(provide/contract [struct repair ()])))
|
||||
(eval '(module provide/contract28-m2 scheme/base
|
||||
(require 'provide/contract28-m1 scheme/contract)
|
||||
(provide/contract [struct repair ()])))
|
||||
(eval '(module provide/contract28-m3 scheme/base
|
||||
(require 'provide/contract28-m2)
|
||||
(provide provide/contract28-res)
|
||||
(define provide/contract28-res (repair? (make-repair)))))
|
||||
(eval '(require 'provide/contract28-m3))
|
||||
(eval 'provide/contract28-res))
|
||||
#t)
|
||||
|
||||
#;
|
||||
(test/spec-passed/result
|
||||
'provide/contract29
|
||||
'(begin
|
||||
(eval '(module provide/contract29-m1 scheme/base
|
||||
(require scheme/contract)
|
||||
(define-struct q (a b))
|
||||
(define-struct (repair q) (c d) #:transparent)
|
||||
(provide/contract [struct repair ([a integer?] [b integer?] [c integer?] [d integer?])])))
|
||||
(eval '(module provide/contract29-m2 scheme/base
|
||||
(require 'provide/contract29-m1 scheme/contract)
|
||||
(provide/contract [struct repair ([a integer?] [b integer?] [c integer?] [d integer?])])))
|
||||
(eval '(module provide/contract29-m3 scheme/base
|
||||
(require 'provide/contract29-m2)
|
||||
(provide provide/contract29-res)
|
||||
(define provide/contract29-res (list (repair? (make-repair 1 2 3 4))
|
||||
(repair-c (make-repair 1 2 3 4))))))
|
||||
(eval '(require 'provide/contract29-m3))
|
||||
(eval 'provide/contract29-res))
|
||||
(list #t 3))
|
||||
|
||||
(contract-error-test
|
||||
#'(begin
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user