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

improve contract stronger for promise/c

Browse Source
This commit is contained in:
Robby Findler 2014-09-22 21:39:43 -05:00
parent 932f041597
commit 5099b380e6
2 changed files with 59 additions and 25 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
pkgs/racket-pkgs/racket-test/tests/racket/contract/stronger.rkt
View File

@ -195,6 +195,8 @@
(ctest #t contract-stronger? (list/c (<=/c 3)) (non-empty-listof (<=/c 5))) (ctest #t contract-stronger? (list/c (<=/c 3)) (non-empty-listof (<=/c 5)))
(ctest #f contract-stronger? (list/c) (non-empty-listof (<=/c 5))) (ctest #f contract-stronger? (list/c) (non-empty-listof (<=/c 5)))
(ctest #t contract-stronger? (list/c) (listof (<=/c 5))) (ctest #t contract-stronger? (list/c) (listof (<=/c 5)))
(ctest #t contract-stronger? (promise/c (<=/c 2)) (promise/c (<=/c 3)))
(ctest #f contract-stronger? (promise/c (<=/c 3)) (promise/c (<=/c 2)))
(contract-eval (contract-eval
`(let ([c (class/c (m (-> any/c integer?)))]) `(let ([c (class/c (m (-> any/c integer?)))])

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

@ -1048,31 +1048,63 @@
(define/subexpression-pos-prop promise/c (define/subexpression-pos-prop promise/c
(λ (ctc-in) (λ (ctc-in)
(let* ([ctc (coerce-contract 'promise/c ctc-in)] (define ctc (coerce-contract 'promise/c ctc-in))
[ctc-proc (contract-projection ctc)]) (cond
(define chap? (chaperone-contract? ctc)) [(chaperone-contract? ctc)
(define c/i-struct (if chap? chaperone-struct impersonate-struct)) (chaperone-promise-ctc ctc)]
(define c/i-procedure (if chap? chaperone-procedure impersonate-procedure)) [else
((if chap? make-chaperone-contract make-contract) (promise-ctc ctc)])))
#:name (build-compound-type-name 'promise/c ctc)
#:projection (define (promise-contract-val-first-proj ctc)
(λ (blame) (define chap? (chaperone-promise-ctc? ctc))
(let ([p-app (ctc-proc (blame-add-context blame "the promise from"))]) (define c/i-struct (if chap? chaperone-struct impersonate-struct))
(λ (val) (define c/i-procedure (if chap? chaperone-procedure impersonate-procedure))
(unless (promise? val) (define ctc-proc (get/build-val-first-projection (promise-base-ctc-ctc ctc)))
(raise-blame-error (λ (blame)
blame (define p-app (ctc-proc (blame-add-context blame "the promise from")))
val (λ (val)
'(expected: "<promise>" given: "~e") (if (promise? val)
val)) (λ (neg-party)
(c/i-struct (c/i-struct
val val
promise-forcer (λ (_ proc) promise-forcer
(c/i-procedure (λ (_ proc)
proc (c/i-procedure
(λ (promise) proc
(values p-app promise)))))))) (λ (promise)
#:first-order promise?)))) (values (λ (val) ((p-app val) neg-party)) promise))))))
(λ (neg-party)
(raise-blame-error
blame #:missing-party neg-party
val
'(expected: "<promise>" given: "~e")
val))))))
(define (promise-contract-name ctc)
(build-compound-type-name 'promise/c (promise-base-ctc-ctc ctc)))
(define (promise-ctc-stronger? this that)
(and (promise-base-ctc? that)
(contract-stronger? (promise-base-ctc-ctc this)
(promise-base-ctc-ctc that))))
(struct promise-base-ctc (ctc))
(struct chaperone-promise-ctc promise-base-ctc ()
#:property prop:custom-write custom-write-property-proc
#:property prop:chaperone-contract
(build-chaperone-contract-property
#:name promise-contract-name
#:val-first-projection promise-contract-val-first-proj
#:stronger promise-ctc-stronger?
#:first-order (λ (ctc) promise?)))
(struct promise-ctc promise-base-ctc ()
#:property prop:custom-write custom-write-property-proc
#:property prop:contract
(build-contract-property
#:name promise-contract-name
#:val-first-projection promise-contract-val-first-proj
#:stronger promise-ctc-stronger?
#:first-order (λ (ctc) promise?)))
;; (parameter/c in/out-ctc) ;; (parameter/c in/out-ctc)
;; (parameter/c in-ctc out-ctc) ;; (parameter/c in-ctc out-ctc)