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

add stronger to syntax/c

Browse Source
This commit is contained in:
Robby Findler 2014-09-24 06:56:24 -05:00
parent 8ea68c743f
commit 748e3ef7cc
2 changed files with 20 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -230,6 +230,9 @@
(ctest #t contract-stronger? (promise/c (<=/c 2)) (promise/c (<=/c 3)))
(ctest #f contract-stronger? (promise/c (<=/c 3)) (promise/c (<=/c 2)))
(ctest #t contract-stronger? (syntax/c (<=/c 3)) (syntax/c (<=/c 4)))
(ctest #f contract-stronger? (syntax/c (<=/c 4)) (syntax/c (<=/c 3)))
(ctest #t contract-stronger?
(class/c (m (-> any/c (<=/c 3))))
(class/c (m (-> any/c (<=/c 4)))))

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

@ -1037,14 +1037,24 @@
#:val-first-projection list/c-chaperone/other-val-first-projection
#:list-contract? (λ (c) #t)))
(struct syntax-ctc (ctc)
#:property prop:custom-write custom-write-property-proc
#:property prop:flat-contract
(build-flat-contract-property
#:name (λ (ctc) (build-compound-type-name 'syntax/c (syntax-ctc-ctc ctc)))
#:stronger (λ (this that)
(and (syntax-ctc? that)
(contract-stronger? (syntax-ctc-ctc this)
(syntax-ctc-ctc that))))
#:first-order (λ (ctc)
(define ? (flat-contract-predicate (syntax-ctc-ctc ctc)))
(λ (v)
(and (syntax? v)
(? (syntax-e v)))))))
(define/subexpression-pos-prop (syntax/c ctc-in)
(let ([ctc (coerce-flat-contract 'syntax/c ctc-in)])
(flat-named-contract
(build-compound-type-name 'syntax/c ctc)
(let ([pred (flat-contract-predicate ctc)])
(λ (val)
(and (syntax? val)
(pred (syntax-e val))))))))
(define ctc (coerce-flat-contract 'syntax/c ctc-in))
(syntax-ctc ctc))
(define/subexpression-pos-prop promise/c
(λ (ctc-in)