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

Add prompt tag contracts using control proxies

Browse Source
This commit is contained in:
Asumu Takikawa 2012-06-08 11:29:21 -04:00
parent d527426cac
commit 1cce922d97
2 changed files with 152 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

51
collects/racket/contract/private/misc.rkt
View File

@ -35,6 +35,8 @@
none/c
make-none/c
prompt/c
chaperone-contract?
impersonator-contract?
flat-contract?
@ -943,6 +945,55 @@
(define/final-prop none/c (make-none/c 'none/c))
;; prompt/c
(define/subexpression-pos-prop (prompt/c ctc-arg)
(define ctc (coerce-contract 'prompt/c ctc-arg))
(cond [(chaperone-contract? ctc) (chaperone-prompt/c ctc)]
[else (impersonator-prompt/c ctc)]))
(define (prompt/c-name ctc)
(build-compound-type-name 'prompt/c (base-prompt/c-ctc ctc)))
(define ((prompt/c-proj proxy) ctc)
(define ho-proj (contract-projection (base-prompt/c-ctc ctc)))
(λ (blame)
(define proj1 (ho-proj blame))
(define proj2 (ho-proj (blame-swap blame)))
(λ (val)
(unless (contract-first-order-passes? ctc val)
(raise-blame-error
blame val
'(expected: "~s," given: "~e")
(contract-name ctc)
val))
(proxy val proj1 proj2))))
(define ((prompt/c-first-order ctc) v)
(continuation-prompt-tag? v))
(define (prompt/c-stronger? this that)
(and (base-prompt/c? that)
(contract-stronger? (base-prompt/c-ctc this)
(base-prompt/c-ctc that))))
(define-struct base-prompt/c (ctc))
(define-struct (chaperone-prompt/c base-prompt/c) ()
#:property prop:chaperone-contract
(build-chaperone-contract-property
#:projection (prompt/c-proj chaperone-prompt-tag)
#:first-order prompt/c-first-order
#:stronger prompt/c-stronger?
#:name prompt/c-name))
(define-struct (impersonator-prompt/c base-prompt/c) ()
#:property prop:contract
(build-contract-property
#:projection (prompt/c-proj impersonate-prompt-tag)
#:first-order prompt/c-first-order
#:stronger prompt/c-stronger?
#:name prompt/c-name))
(define (flat-contract-predicate x)
(contract-struct-first-order

100
collects/tests/racket/contract-test.rktl
View File

@ -4044,6 +4044,106 @@
(for ([(k v) (in-hash h)])
(hash-ref k v))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; prompt/c
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(test/spec-passed
'prompt/c-fo-1
'(contract (prompt/c string?)
(make-continuation-prompt-tag)
'pos 'neg))
(test/pos-blame
'prompt/c-fo-2
'(contract (prompt/c string?) 5 'pos 'neg))
(test/spec-passed
'prompt/c-ho-1
'(let ([pt (contract (prompt/c number?)
(make-continuation-prompt-tag)
'pos
'neg)])
(call-with-continuation-prompt
(λ () (abort-current-continuation pt 3))
pt
(λ (x) (+ x 1)))))
(test/neg-blame
'prompt/c-ho-2
'(let ([pt (contract (prompt/c string?)
(make-continuation-prompt-tag)
'pos
'neg)])
(call-with-continuation-prompt
(λ () (abort-current-continuation pt 3))
pt
(λ (x) (+ x 1)))))
(test/neg-blame
'prompt/c-ho-3
'(let ([pt (contract (prompt/c (-> string? number?))
(make-continuation-prompt-tag)
'pos
'neg)])
(call-with-continuation-prompt
(λ () (abort-current-continuation pt (λ (x) 5)))
pt
(λ (x) (x 8)))))
(test/neg-blame
'prompt/c-ho-4
'(let ([pt (contract (prompt/c (-> string? number?))
(make-continuation-prompt-tag)
'pos
'neg)])
(call-with-continuation-prompt
(λ () (abort-current-continuation pt (λ (x) "bad")))
pt
(λ (x) (x "potato")))))
(test/pos-blame
'prompt/c-ho-5
'(let* ([pt (make-continuation-prompt-tag)]
[do-prompt (contract
(-> (-> (prompt/c (-> number? number?))
any)
number?)
(λ (f) (call-with-continuation-prompt
(λ () (f pt))
pt
(λ (f) (f "bad"))))
'pos
'neg)])
(do-prompt (λ (pt)
(abort-current-continuation pt (λ (v) (+ v 1)))))))
(test/spec-failed
'prompt/c-ho-5
'(let* ([pt (make-continuation-prompt-tag)]
[do-prompt (contract
(-> (-> (prompt/c (-> number? number?))
any)
number?)
(λ (f) (call-with-continuation-prompt
(λ () (f pt))
pt
(λ (f) (f 0))))
'A
'B)]
[do-prompt2 (contract
(-> (-> (prompt/c (-> string? number?))
any)
number?)
do-prompt
'B
'C)])
(do-prompt2
(λ (pt) (abort-current-continuation pt (λ (v) (+ v 1))))))
"B")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; make-contract