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

fix the late-neg construction for flat contracts

Browse Source 
Thanks to Sam for finding this problem!
This commit is contained in:
Robby Findler 2015-12-05 23:03:06 -06:00
parent 8b3369f81c
commit e814d742a7
1 changed files with 25 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -270,11 +270,11 @@
#:list-contract? [list-contract? (λ (c) #f)]) #:list-contract? [list-contract? (λ (c) #f)])
;; this code is here to help me find the combinators that ;; this code is here to help me find the combinators that
;; are still using only #:projection and not #:val-first-projection ;; are still using only #:projection and not #:late-neg-projection
#; #;
(when (and get-projection (when (and get-projection
(not get-val-first-projection)) (not get-late-neg-projection))
(printf "missing val-first-projection ~s\n" (printf "missing late-neg-projection ~s\n"
get-projection)) get-projection))
(let* ([get-name (or get-name (lambda (c) default-name))] (let* ([get-name (or get-name (lambda (c) default-name))]
@ -283,6 +283,10 @@
(or get-val-first-projection (or get-val-first-projection
(and (not get-projection) (and (not get-projection)
(get-val-first-first-order-projection get-name get-first-order)))] (get-val-first-first-order-projection get-name get-first-order)))]
[get-late-neg-projection
(or get-late-neg-projection
(and (not get-projection)
(get-late-neg-first-order-projection get-name get-first-order)))]
[get-projection [get-projection
(cond (cond
[get-projection [get-projection
@ -462,6 +466,9 @@
[val-first-projection (or val-first-projection [val-first-projection (or val-first-projection
(and (not projection) (and (not projection)
(val-first-first-order-projection name first-order)))] (val-first-first-order-projection name first-order)))]
[late-neg-projection (or late-neg-projection
(and (not projection)
(late-neg-first-order-projection name first-order)))]
[stronger (or stronger as-strong?)]) [stronger (or stronger as-strong?)])
(mk name first-order (mk name first-order
@ -473,6 +480,9 @@
(define ((get-val-first-first-order-projection get-name get-first-order) c) (define ((get-val-first-first-order-projection get-name get-first-order) c)
(val-first-first-order-projection (get-name c) (get-first-order c))) (val-first-first-order-projection (get-name c) (get-first-order c)))
(define ((get-late-neg-first-order-projection get-name get-first-order) c)
(late-neg-first-order-projection (get-name c) (get-first-order c)))
(define (val-first-first-order-projection name p?) (define (val-first-first-order-projection name p?)
(λ (b) (λ (b)
(λ (v) (λ (v)
@ -486,6 +496,18 @@
name name
v)))))) v))))))
(define (late-neg-first-order-projection name p?)
(λ (b)
(λ (v neg-party)
(if (p? v)
v
(raise-blame-error
b #:missing-party neg-party
v
'(expected: "~s" given: "~e")
name
v)))))
(define (as-strong? a b) (define (as-strong? a b)
(procedure-closure-contents-eq? (procedure-closure-contents-eq?
(contract-struct-projection a) (contract-struct-projection a)