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

port parametric->/c to late-neg

Browse Source
This commit is contained in:
Robby Findler 2015-12-20 21:17:14 -06:00
parent 35b2320730
commit 7d02f4c7b1
1 changed files with 28 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -54,38 +54,40 @@
(apply (polymorphic-contract-body that) instances))] (apply (polymorphic-contract-body that) instances))]
[else #f])] [else #f])]
[else #f])) [else #f]))
#:projection #:late-neg-projection
(lambda (c) (lambda (c)
(lambda (orig-blame) (lambda (orig-blame)
(define blame (blame-add-context orig-blame #f)) (define blame (blame-add-context orig-blame #f))
(define (wrap p)
;; values in polymorphic types come in from negative position,
;; relative to the poly/c contract
(define negative? (blame-swapped? blame)) (define negative? (blame-swapped? blame))
(define barrier/c (polymorphic-contract-barrier c)) (define barrier/c (polymorphic-contract-barrier c))
(define vars (polymorphic-contract-vars c))
(define (wrap p neg-party)
;; values in polymorphic types come in from negative position,
;; relative to the poly/c contract
(define instances (define instances
(for/list ([var (in-list (polymorphic-contract-vars c))]) (for/list ([var (in-list vars)])
(barrier/c negative? var))) (barrier/c negative? var)))
(define protector (define protector
(apply (polymorphic-contract-body c) instances)) (apply (polymorphic-contract-body c) instances))
(((contract-projection protector) blame) p)) (((contract-late-neg-projection protector) blame) p neg-party))
(lambda (p) (lambda (p neg-party)
(unless (procedure? p) (unless (procedure? p)
(raise-blame-error blame p '(expected "a procedure" given: "~e") p)) (raise-blame-error blame #:missing-party neg-party
p '(expected "a procedure" given: "~e") p))
(make-keyword-procedure (make-keyword-procedure
(lambda (keys vals . args) (keyword-apply (wrap p) keys vals args)) (lambda (keys vals . args) (keyword-apply (wrap p) keys vals args))
(case-lambda (case-lambda
[() ((wrap p))] [() ((wrap p neg-party))]
[(a) ((wrap p) a)] [(a) ((wrap p neg-party) a)]
[(a b) ((wrap p) a b)] [(a b) ((wrap p neg-party) a b)]
[(a b c) ((wrap p) a b c)] [(a b c) ((wrap p neg-party) a b c)]
[(a b c d) ((wrap p) a b c d)] [(a b c d) ((wrap p neg-party) a b c d)]
[(a b c d e) ((wrap p) a b c d e)] [(a b c d e) ((wrap p neg-party) a b c d e)]
[(a b c d e f) ((wrap p) a b c d e f)] [(a b c d e f) ((wrap p neg-party) a b c d e f)]
[(a b c d e f g) ((wrap p) a b c d e f g)] [(a b c d e f g) ((wrap p neg-party) a b c d e f g)]
[(a b c d e f g h) ((wrap p) a b c d e f g h)] [(a b c d e f g h) ((wrap p neg-party) a b c d e f g h)]
[args (apply (wrap p) args)]))))))) [args (apply (wrap p neg-party) args)])))))))
(define (opaque/c positive? name) (define (opaque/c positive? name)
(define-values [ type make pred getter setter ] (define-values [ type make pred getter setter ]
@ -100,17 +102,20 @@
#:name (lambda (c) (barrier-contract-name c)) #:name (lambda (c) (barrier-contract-name c))
#:first-order (λ (c) (barrier-contract-pred c)) #:first-order (λ (c) (barrier-contract-pred c))
#:stronger (λ (this that) (eq? this that)) #:stronger (λ (this that) (eq? this that))
#:projection #:late-neg-projection
(lambda (c) (lambda (c)
(define mk (barrier-contract-make c)) (define mk (barrier-contract-make c))
(define (mk-np x neg-party) (mk x))
(define pred (barrier-contract-pred c)) (define pred (barrier-contract-pred c))
(define get (barrier-contract-get c)) (define get (barrier-contract-get c))
(define cp? (barrier-contract-positive? c))
(lambda (blame) (lambda (blame)
(if (equal? (blame-original? blame) (barrier-contract-positive? c)) (if (equal? (blame-original? blame) cp?)
mk mk-np
(lambda (x) (lambda (x neg-party)
(if (pred x) (if (pred x)
(get x) (get x)
(raise-blame-error blame x '(expected: "~a" given: "~e") (raise-blame-error blame #:missing-party neg-party
x '(expected: "~a" given: "~e")
(barrier-contract-name c) (barrier-contract-name c)
x)))))))) x))))))))