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

fix a bug in the way that an old style projection

Browse Source 
was created when a val-first-projection was needed
This commit is contained in:
Robby Findler 2015-01-25 15:07:26 -06:00
parent ffbf01ad4e
commit 87a231b792
2 changed files with 40 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
pkgs/racket-test/tests/racket/contract/make-contract.rkt
View File

@ -3,7 +3,8 @@
(require "test-util.rkt")
(parameterize ([current-contract-namespace
(make-basic-contract-namespace 'racket/contract)])
(make-basic-contract-namespace 'racket/contract
'racket/contract/private/blame)])
(contract-eval
'(define proj:add1->sub1
(make-contract
@ -133,6 +134,29 @@
'(contract proj:bad-prime-box-list/c (list (box 2) (box 3)) 'pos 'neg)
exn:fail?)
(test/pos-blame
'build-chaperone-contract-property1
'(let ()
(struct val-first-none ()
#:property prop:chaperone-contract
(build-chaperone-contract-property
#:val-first-projection (λ (me)
(λ (blame)
(λ (val)
(λ (neg-party)
(raise-blame-error
blame
val
"bad")))))
#:name (λ (x) 'the-name)
;; make a very aproximate first-order check
#:first-order (λ (c) (λ (x) #t))
#:stronger (λ (x y) #f)))
(((contract-projection (val-first-none))
(make-blame (srcloc #f #f #f #f #f) 5 (λ () 'the-name) 'pos 'neg #t))
5)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; make-flat-contract

19
racket/collects/racket/contract/private/prop.rkt
View File

@ -281,8 +281,9 @@
(if (skip-projection-wrapper?)
get-projection
(projection-wrapper get-projection)))]
[else (get-first-order-projection
get-name get-first-order)])]
[else (val-first-projection->projection get-val-first-projection
get-name
get-first-order)])]
[stronger (or stronger weakest)])
(mk get-name get-first-order
@ -341,8 +342,18 @@
(define (weakest a b) #f)
(define ((get-first-order-projection get-name get-first-order) c)
(first-order-projection (get-name c) (get-first-order c)))
(define ((val-first-projection->projection get-val-first-projection
get-name
get-first-order) c)
(cond
[(flat-contract-struct? c)
(first-order-projection (get-name c) (get-first-order c))]
[else
(define vfp (get-val-first-projection c))
(λ (blame)
(define vp (vfp blame))
(λ (val)
((vp val) #f)))]))
(begin-encourage-inline
(define (first-order-projection name first-order)