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

port struct-type-property/c to late-neg and add some tests for it

Browse Source
This commit is contained in:
Robby Findler 2015-12-19 10:38:04 -06:00
parent 557b039f3c
commit 8e2179a6eb
2 changed files with 85 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

77
pkgs/racket-test/tests/racket/contract/struct-type-property.rkt Normal file
View File

@ -0,0 +1,77 @@
#lang racket/base
(require "test-util.rkt")
(parameterize ([current-contract-namespace
(make-basic-contract-namespace)])
(test/spec-passed
'struct-type-prop.1
'(let ()
(define-values (_prop prop? prop-ref) (make-struct-type-property 'prop))
(define app-prop (contract (-> prop? integer? boolean?)
(λ (x v) (((prop-ref x) x) v))
'pos1 'neg1))
(define prop (contract (struct-type-property/c (-> prop? (-> integer? boolean?)))
_prop
'pos2 'neg2))
(struct s (f) #:property prop (λ (x) (s-f x)))
(define s1 (s even?))
(app-prop s1 5)))
(test/neg-blame
'struct-type-prop.2
'(let ()
(define-values (_prop prop? prop-ref) (make-struct-type-property 'prop))
(define app-prop (contract (-> prop? integer? boolean?)
(λ (x v) (((prop-ref x) x) v))
'pos1 'neg1))
(define prop (contract (struct-type-property/c (-> prop? (-> integer? boolean?)))
_prop
'pos2 'neg2))
(struct s (f) #:property prop (λ (x) (s-f x)))
(define s1 (s even?))
(app-prop s1 'apple)))
(test/neg-blame
'struct-type-prop.3
'(let ()
(define-values (_prop prop? prop-ref) (make-struct-type-property 'prop))
(define app-prop (contract (-> prop? integer? boolean?)
(λ (x v) (((prop-ref x) x) v))
'pos1 'neg1))
(define prop (contract (struct-type-property/c (-> prop? (-> integer? boolean?)))
_prop
'pos 'neg))
(struct s (f) #:property prop (λ (x) (s-f x)))
(define s2 (s "not a fun"))
(app-prop s2 5)))
(test/neg-blame
'struct-type-prop.4
'(let ()
(define-values (_prop prop? prop-ref) (make-struct-type-property 'prop))
(define app-prop (contract (-> prop? integer? boolean?)
(λ (x v) (((prop-ref x) x) v))
'pos1 'neg1))
(define prop (contract (struct-type-property/c (-> prop? (-> integer? boolean?)))
_prop
'pos 'neg))
(struct s (f) #:property prop (λ (x) (s-f x)))
(define s3 (s list))
(app-prop s3 5)))
(test/pos-blame
'struct-type-prop.5
'(let ()
(define-values (_prop prop? prop-ref) (make-struct-type-property 'prop))
(define app-prop (contract (-> prop? integer? boolean?)
(λ (x v) (((prop-ref x) x) v))
'pos1 'neg1))
(define prop (contract (struct-type-property/c (-> prop? (-> integer? boolean?)))
_prop
'pos2 'neg2))
(struct s (f) #:property prop (λ (x) (s-f x)))
(define s3 (s list?))
((prop-ref s3) 'apple)))
)

16
racket/collects/racket/contract/private/struct-prop.rkt
View File

@ -5,23 +5,23 @@
"misc.rkt")
(provide (rename-out [struct-type-property/c* struct-type-property/c]))
(define (get-stpc-proj stpc)
(define get-val-proj
(contract-projection
(define (get-stpc-late-neg-proj stpc)
(define get-late-neg-proj
(contract-late-neg-projection
(struct-type-property/c-value-contract stpc)))
(λ (input-blame)
(define blame (blame-add-context input-blame "the struct property value of" #:swap? #t))
(define val-proj (get-val-proj blame))
(λ (x)
(define late-neg-proj (get-late-neg-proj blame))
(λ (x neg-party)
(unless (struct-type-property? x)
(raise-blame-error input-blame x
(raise-blame-error input-blame x #:neg-party
'(expected "struct-type-property" given: "~e")
x))
(define-values (nprop _pred _acc)
(make-struct-type-property
(wrap-name x)
(lambda (val _info)
(val-proj val))
(late-neg-proj val neg-party))
(list (cons x values))))
nprop)))
@ -37,7 +37,7 @@
'struct-type-property/c
(struct-type-property/c-value-contract c)))
#:first-order (lambda (c) struct-type-property?)
#:projection get-stpc-proj))
#:late-neg-projection get-stpc-late-neg-proj))
(define struct-type-property/c*
(let ([struct-type-property/c