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

add stronger to is-a?/c

Browse Source
This commit is contained in:
Robby Findler 2014-09-24 10:40:26 -05:00
parent 748e3ef7cc
commit 9e3a9d17d5
2 changed files with 49 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -316,6 +316,20 @@
(instanceof/c (class/c (m (-> any/c (<=/c 4)))))
(instanceof/c (class/c (m (-> any/c (<=/c 3))))))
(ctest #t contract-stronger? (is-a?/c object%) (is-a?/c object%))
(ctest #t contract-stronger? (is-a?/c (class object% (super-new))) (is-a?/c object%))
(ctest #f contract-stronger? (is-a?/c object%) (is-a?/c (class object% (super-new))))
(contract-eval `(define one-interface<%> (interface ())))
(contract-eval `(define another-interface<%> (interface (one-interface<%>))))
(ctest #t contract-stronger? (is-a?/c another-interface<%>) (is-a?/c one-interface<%>))
(ctest #f contract-stronger? (is-a?/c one-interface<%>) (is-a?/c another-interface<%>))
(ctest #t contract-stronger?
(is-a?/c (class* object% (one-interface<%>) (super-new)))
(is-a?/c one-interface<%>))
(ctest #f contract-stronger?
(is-a?/c one-interface<%>)
(is-a?/c (class* object% (one-interface<%>) (super-new))))
;; chances are, this predicate will accept "x", but
;; we don't want to consider it stronger, since it
;; will not always accept "x".

46
racket/collects/racket/contract/private/object.rkt
View File

@ -120,21 +120,45 @@
(format "~s" '(or/c interface? class?))
%/<%>)]))
(struct is-a?-ctc (<%>)
#:property prop:custom-write custom-write-property-proc
#:property prop:flat-contract
(build-flat-contract-property
#:first-order
(λ (ctc)
(define <%> (is-a?-ctc-<%> ctc))
(λ (x) (is-a? x <%>)))
#:stronger
(λ (this that)
(define this-<%> (is-a?-ctc-<%> this))
(cond
[(is-a?-ctc? that)
(define that-<%> (is-a?-ctc-<%> that))
(cond
[(and (class? this-<%>) (class? that-<%>))
(subclass? this-<%> that-<%>)]
[(and (class? this-<%>) (interface? that-<%>))
(implementation? this-<%> that-<%>)]
[(and (interface? this-<%>) (interface? that-<%>))
(interface-extension? this-<%> that-<%>)]
[else #f])]
[else #f]))
#:name
(λ (ctc)
(define <%> (is-a?-ctc-<%> ctc))
(define name (object-name <%>))
(cond
[name `(is-a?/c ,name)]
[(class? <%>) `(is-a?/c unknown%)]
[else `(is-a?/c unknown<%>)]))))
(define (is-a?/c <%>)
(check-is-a?/c <%>)
(define name (object-name <%>))
(flat-named-contract
(cond
[name
`(is-a?/c ,name)]
[(class? <%>)
`(is-a?/c unknown%)]
[else `(is-a?/c unknown<%>)])
(lambda (x) (is-a? x <%>))))
(is-a?-ctc <%>))
(define mixin-contract (->i ([c% class?]) [res (c%) (subclass?/c c%)]))
(define/opter (is-a?/c opt/i opt/info stx)
(syntax-case stx ()
[(_ cls)