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

add stronger to implementation?/c and subclass?/c

Browse Source 
also, bring down below 102 cols
This commit is contained in:
Robby Findler 2014-09-24 12:43:04 -05:00
parent 9e3a9d17d5
commit 1f1479c7be
2 changed files with 43 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -330,6 +330,15 @@
(is-a?/c one-interface<%>)
(is-a?/c (class* object% (one-interface<%>) (super-new))))
(ctest #t contract-stronger? (subclass?/c (class object% (super-new))) (subclass?/c object%))
(ctest #f contract-stronger? (subclass?/c object%) (subclass?/c (class object% (super-new))))
(ctest #t contract-stronger?
(implementation?/c another-interface<%>)
(implementation?/c one-interface<%>))
(ctest #f contract-stronger?
(implementation?/c one-interface<%>)
(implementation?/c another-interface<%>))
;; chances are, this predicate will accept "x", but
;; we don't want to consider it stronger, since it
;; will not always accept "x".

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

@ -71,10 +71,13 @@
(with-syntax ([(((method-id method-ctc) ...)
((field-id field-ctc) ...))
(parse-object-contract stx #'(spec ...))])
(with-syntax ([(method-name ...) (map (λ (x) (string->symbol (format "~a method" (syntax-e x))))
(syntax->list #'(method-id ...)))])
(with-syntax ([(method-name ...)
(map (λ (x) (string->symbol (format "~a method" (syntax-e x))))
(syntax->list #'(method-id ...)))])
#'(build-object-contract '(method-id ...)
(syntax-parameterize ((making-a-method #t)) (list (let ([method-name method-ctc]) method-name) ...))
(syntax-parameterize
((making-a-method #t))
(list (let ([method-name method-ctc]) method-name) ...))
'(field-id ...)
(list field-ctc ...))))]))
@ -90,25 +93,39 @@
(apply and/c (map sub/impl?/c %/<%>s)))])
[res (c%) (subclass?/c c%)]))
(struct subclass/c (%)
#:property prop:custom-write custom-write-property-proc
#:property prop:flat-contract
(build-flat-contract-property
#:first-order (λ (ctc) (define % (subclass/c-% ctc)) (λ (x) (subclass? x %)))
#:stronger (λ (this that)
(cond
[(subclass/c? that)
(subclass? (subclass/c-% this) (subclass/c-% that))]
[else #f]))
#:name (λ (ctc) `(subclass?/c ,(or (object-name (subclass/c-% ctc)) 'unknown%)))))
(define (subclass?/c %)
(unless (class? %)
(raise-argument-error 'subclass?/c
"class?"
%))
(define name (object-name %))
(flat-named-contract
`(subclass?/c ,(or name 'unknown%))
(lambda (x) (subclass? x %))))
(raise-argument-error 'subclass?/c "class?" %))
(subclass/c %))
(struct implementation/c (<%>)
#:property prop:custom-write custom-write-property-proc
#:property prop:flat-contract
(build-flat-contract-property
#:first-order (λ (ctc) (define <%> (implementation/c-<%> ctc)) (λ (x) (implementation? x <%>)))
#:stronger (λ (this that)
(cond
[(implementation/c? that)
(interface-extension? (implementation/c-<%> this)
(implementation/c-<%> that))]
[else #f]))
#:name (λ (ctc) `(implementation?/c ,(or (object-name (implementation/c-<%> ctc)) 'unknown<%>)))))
(define (implementation?/c <%>)
(unless (interface? <%>)
(raise-argument-error 'implementation?/c
"interface?"
<%>))
(define name (object-name <%>))
(flat-named-contract
`(implementation?/c ,(or name 'unknown<%>))
(lambda (x) (implementation? x <%>))))
(raise-argument-error 'implementation?/c "interface?" <%>))
(implementation/c <%>))
(define (sub/impl?/c %/<%>)
(cond