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

added the _ special case to ->d

Browse Source 
svn: r8998
This commit is contained in:
Robby Findler 2008-03-17 04:01:39 +00:00
parent b64d03d932
commit 9ba432ab9c
6 changed files with 275 additions and 76 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
collects/framework/private/framework-exports.ss
View File

@ -100,16 +100,15 @@
(preferences:add-panel (preferences:add-panel
(-> (or/c string? (cons/c string? (listof string?))) (-> (or/c string? (cons/c string? (listof string?)))
(let ([old-children '()]) (->d ([parent (is-a?/c area-container-window<%>)])
(->d ([parent (is-a?/c area-container-window<%>)]) ()
() [_
#:pre-cond (set! old-children (send parent get-children)) (let ([old-children (send parent get-children)])
[child (and/c (is-a?/c area-container-window<%>)
(λ (child) (λ (child)
(and (is-a? child area-container-window<%>) (andmap eq?
(andmap eq? (append old-children (list child))
(append old-children (list child)) (send parent get-children)))))])
(send parent get-children))))]))
void?) void?)
(labels f) (labels f)
@{@scheme[preferences:add-preference-panel] adds the result of @{@scheme[preferences:add-preference-panel] adds the result of

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

@ -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: v4 todo:
- add case-> to object-contract - 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) - test object-contract with keywords (both optional and mandatory)
- change mzlib/contract to rewrite into scheme/contract (maybe?) - change mzlib/contract to rewrite into scheme/contract (maybe?)
@ -776,35 +766,60 @@ v4 todo:
[[id ctc] #'((id) (ctc))] [[id ctc] #'((id) (ctc))]
[x (raise-syntax-error #f "expected binding pair or any" stx #'x)])] [x (raise-syntax-error #f "expected binding pair or any" stx #'x)])]
[mtd? (syntax-parameter-value #'making-a-method)]) [mtd? (syntax-parameter-value #'making-a-method)])
(let ([dup (check-duplicate-identifier (syntax->list #'(dom-params ... rng-params ...)))]) (let ([rng-underscores?
(when dup (let ([is-underscore?
(raise-syntax-error #f "duplicate identifier" stx dup))) (λ (x)
#`(syntax-parameterize (syntax-case x (_)
((making-a-method #f)) [_ #t]
(build-->d mtd? [else #f]))])
(list (λ (dom-params ...) mandatory-doms) ...) (cond
(list (λ (dom-params ...) optional-doms) ...) [(andmap is-underscore? (syntax->list #'(rng-params ...)))
(list (λ (dom-params ...) mandatory-kwd-dom) ...) #t]
(list (λ (dom-params ...) optional-kwd-dom) ...) [(ormap (λ (x) (and (is-underscore? x) x))
#,(if id/rest (syntax->list #'(rng-params ...)))
(with-syntax ([(id rst-ctc) id/rest]) =>
#`(λ (dom-params ...) rst-ctc)) (λ (id)
#f) (raise-syntax-error '->d
#,(if pre-cond "expected all of the identifiers to be underscores, or none of them to be"
#`(λ (dom-params ...) #,pre-cond) stx
#f) id))]
#,(syntax-case #'rng-ctcs () [else #f]))])
[#f #f] (let ([dup (check-duplicate-identifier
[(ctc ...) #'(list (λ (rng-params ... dom-params ...) ctc) ...)]) (append (if rng-underscores?
#,(if post-cond '()
#`(λ (rng-params ... dom-params ...) #,post-cond) (syntax->list #'(rng-params ...)))
#f) (syntax->list #'(dom-params ...))))])
'(mandatory-kwd ...) (when dup
'(optional-kwd ...) (raise-syntax-error #f "duplicate identifier" stx dup)))
(λ (f) #`(syntax-parameterize
#,(add-name-prop ((making-a-method #f))
(syntax-local-infer-name stx) (build-->d mtd?
#`(λ args (apply f args)))))))))))])) (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) (define (->d-proj ->d-stct)
(let ([non-kwd-ctc-count (+ (length (->d-mandatory-dom-ctcs ->d-stct)) (let ([non-kwd-ctc-count (+ (length (->d-mandatory-dom-ctcs ->d-stct))
@ -879,12 +894,28 @@ v4 todo:
(error 'shouldnt\ happen))] (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) [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) (loop (cdr args)
(cdr non-kwd-ctcs)))])))))]) (cdr non-kwd-ctcs)))])))))]
(if (->d-range ->d-stct) [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 (call-with-values
thnk thnk
(λ orig-results (λ orig-results
(let* ([range-count (length (->d-range ->d-stct))] (let* ([range-count (length rng)]
[post-args (append orig-results raw-orig-args)] [post-args (append orig-results raw-orig-args)]
[post-non-kwd-arg-count (+ non-kwd-ctc-count range-count)] [post-non-kwd-arg-count (+ non-kwd-ctc-count range-count)]
[dep-post-args (build-dep-ctc-args post-non-kwd-arg-count [dep-post-args (build-dep-ctc-args post-non-kwd-arg-count
@ -909,21 +940,26 @@ v4 todo:
(apply (apply
values values
(let loop ([results orig-results] (let loop ([results orig-results]
[result-contracts (->d-range ->d-stct)]) [result-contracts rng])
(cond (cond
[(null? result-contracts) '()] [(null? result-contracts) '()]
[else [else
(cons (invoke-dep-ctc (car result-contracts) dep-post-args (car results) pos-blame neg-blame src-info orig-str) (cons
(loop (cdr results) (cdr result-contracts)))])))))) (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))))]) (thnk))))])
(make-keyword-procedure kwd-proc (make-keyword-procedure kwd-proc
((->d-name-wrapper ->d-stct) ((->d-name-wrapper ->d-stct)
(λ args (λ args
(apply kwd-proc '() '() 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) (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))) ((((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) ;; build-dep-ctc-args : number (listof any) boolean (listof keyword) (listof keyword) (listof any)
@ -976,14 +1012,20 @@ v4 todo:
optional-kwds optional-kwds
name-wrapper))) 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. (define-struct/prop ->d (mtd? ;; boolean; indicates if this is a contract on a method, for error reporing purposes.
mandatory-dom-ctcs ;; (listof (-> ??? ctc)) mandatory-dom-ctcs ;; (listof (-> d??? ctc))
optional-dom-ctcs ;; (listof (-> ??? ctc)) optional-dom-ctcs ;; (listof (-> d??? ctc))
keyword-ctcs ;; (listof (-> ??? ctc)) keyword-ctcs ;; (listof (-> d??? ctc))
rest-ctc ;; (or/c false/c (-> ??? ctc)) rest-ctc ;; (or/c false/c (-> d??? ctc))
pre-cond ;; (-> ??? boolean) pre-cond ;; (-> d??? boolean)
range ;; (or/c false/c (-> ??? ctc)) range ;; (or/c false/c (listof (-> dr??? ctc)) (box (listof (-> r??? ctc))))
post-cond ;; (-> ??? boolean) post-cond ;; (-> dr??? boolean)
keywords ;; (listof keywords) -- sorted by keyword< keywords ;; (listof keywords) -- sorted by keyword<
mandatory-keywords ;; (listof keywords) -- sorted by keyword< mandatory-keywords ;; (listof keywords) -- sorted by keyword<
optional-keywords ;; (listof keywords) -- sorted by keyword< optional-keywords ;; (listof keywords) -- sorted by keyword<
@ -1019,6 +1061,14 @@ v4 todo:
,(let ([range (->d-range ctc)]) ,(let ([range (->d-range ctc)])
(cond (cond
[(not range) 'any] [(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)) [(and (not (null? range))
(null? (cdr range))) (null? (cdr range)))
`[,(next-id) ...]] `[,(next-id) ...]]

34
collects/scheme/private/contract.ss
View File

@ -494,18 +494,28 @@ improve method arity mismatch contract violation error messages?
(syntax-case x () (syntax-case x ()
[(a b) #'(slc #'b)] [(a b) #'(slc #'b)]
[else #f])) [else #f]))
(syntax->list #'(mutator-codes/mutator-new-names ...)))]) (syntax->list #'(mutator-codes/mutator-new-names ...)))]
(syntax (begin [(exported-selector-ids ...) (reverse selector-ids)]
(provide (rename-out [id-rename struct-name])) )
(define-syntax id-rename #`(begin
(let ([slc (syntax-local-certifier)]) (provide (rename-out [id-rename struct-name]))
(list (slc #'-struct:struct-name) (define-syntax id-rename
(slc #'constructor-new-name) (let ([slc (syntax-local-certifier)])
(slc #'predicate-new-name) #;
(list (slc #'rev-selector-new-names) ... (list (slc #'-struct:struct-name)
(slc #'rev-selector-old-names) ...) (slc #'#,constructor-id)
(list mutator-id-info ...) (slc #'#,predicate-id)
super-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:struct-name -struct:struct-name] [-struct:struct-name -struct:struct-name]
[struct-name struct-name] [struct-name struct-name]

56
collects/scribblings/guide/contracts-general-function.scrbl
View File

@ -3,6 +3,7 @@
scribble/eval scribble/eval
"guide-utils.ss" "guide-utils.ss"
"contracts-utils.ss" "contracts-utils.ss"
(for-label framework/framework)
(for-label scheme/contract) (for-label scheme/contract)
(for-label scheme/gui)) (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 has a balance that is larger or smaller, depending on the
given comparison operator, than the original balance. 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]} @ctc-section[#:tag "case-lambda"]{Contracts for @scheme[case-lambda]}
Dybvig, in Chapter 5 of the Dybvig, in Chapter 5 of the

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

@ -417,6 +417,8 @@ symbols, and that return a symbol.
[dependent-rest (code:line) (code:line #:rest id rest-expr)] [dependent-rest (code:line) (code:line #:rest id rest-expr)]
[pre-cond (code:line) (code:line #:pre-cond boolean-expr)] [pre-cond (code:line) (code:line #:pre-cond boolean-expr)]
[dep-range any [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 [id range-expr] post-cond)
(code:line (values [id range-expr] ...) post-cond)] (code:line (values [id range-expr] ...) post-cond)]
[post-cond (code:line) (code:line #:post-cond boolean-expr)] [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 argument) is visible in all of the sub-expressions of
@scheme[->d]. Each of the @scheme[id]s on a result is @scheme[->d]. Each of the @scheme[id]s on a result is
visible in the subexpressions of the @scheme[dep-range]. 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 ->) @defform*/subs[#:literals (any values ->)

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

@ -1606,6 +1606,42 @@
'pos 'pos
'neg))) '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 '(require 'provide/contract27c))
(eval 'provide/contract27ans)) (eval 'provide/contract27ans))
"me") "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 (contract-error-test
#'(begin #'(begin