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

improve contract-stronger for instanceof/c

Browse Source
This commit is contained in:
Robby Findler 2014-09-21 05:33:06 -05:00
parent 9ea9d0eaf8
commit 9681032783
2 changed files with 18 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -2,7 +2,8 @@
(require "test-util.rkt") (require "test-util.rkt")
(parameterize ([current-contract-namespace (parameterize ([current-contract-namespace
(make-basic-contract-namespace 'racket/contract)]) (make-basic-contract-namespace 'racket/contract
'racket/class)])
(contract-eval '(define-contract-struct couple (hd tl))) (contract-eval '(define-contract-struct couple (hd tl)))
(contract-eval '(define-contract-struct triple (a b c))) (contract-eval '(define-contract-struct triple (a b c)))
@ -149,6 +150,10 @@
(ctest #t contract-stronger? 'x symbol?) (ctest #t contract-stronger? 'x symbol?)
(ctest #f contract-stronger? symbol? 'x) (ctest #f contract-stronger? symbol? 'x)
(contract-eval
`(let ([c (class/c (m (-> any/c integer?)))])
(,test #t contract-stronger? (instanceof/c c) (instanceof/c c))))
;; chances are, this predicate will accept "x", but ;; chances are, this predicate will accept "x", but
;; we don't want to consider it stronger, since it ;; we don't want to consider it stronger, since it
;; will not always accept "x". ;; will not always accept "x".

13
racket/collects/racket/private/class-c-old.rkt
View File

@ -825,10 +825,12 @@
absents absent-fields absents absent-fields
internal opaque? name) internal opaque? name)
#:omit-define-syntaxes #:omit-define-syntaxes
#:property prop:custom-write custom-write-property-proc
#:property prop:contract #:property prop:contract
(build-contract-property (build-contract-property
#:projection class/c-proj #:projection class/c-proj
#:name build-class/c-name #:name build-class/c-name
#:stronger (λ (this that) (equal? this that))
#:first-order #:first-order
(λ (ctc) (λ (ctc)
(λ (cls) (λ (cls)
@ -1118,6 +1120,7 @@
(λ args (ret #f)))))) (λ args (ret #f))))))
(define-struct base-object/c (methods method-contracts fields field-contracts) (define-struct base-object/c (methods method-contracts fields field-contracts)
#:property prop:custom-write custom-write-property-proc
#:property prop:contract #:property prop:contract
(build-contract-property (build-contract-property
#:projection object/c-proj #:projection object/c-proj
@ -1187,14 +1190,22 @@
(and (object? val) (and (object? val)
(contract-first-order-passes? cls-ctc (object-ref val)))))) (contract-first-order-passes? cls-ctc (object-ref val))))))
(define (instanceof/c-stronger this that)
(and (base-instanceof/c? that)
(contract-stronger? (base-instanceof/c-class-ctc this)
(base-instanceof/c-class-ctc that))))
(define-struct base-instanceof/c (class-ctc) (define-struct base-instanceof/c (class-ctc)
#:property prop:custom-write custom-write-property-proc
#:property prop:contract #:property prop:contract
(build-contract-property (build-contract-property
#:projection instanceof/c-proj #:projection instanceof/c-proj
#:name #:name
(λ (ctc) (λ (ctc)
(build-compound-type-name 'instanceof/c (base-instanceof/c-class-ctc ctc))) (build-compound-type-name 'instanceof/c (base-instanceof/c-class-ctc ctc)))
#:first-order instanceof/c-first-order)) #:first-order instanceof/c-first-order
#:stronger instanceof/c-stronger))
(define (instanceof/c cctc) (define (instanceof/c cctc)
(let ([ctc (coerce-contract 'instanceof/c cctc)]) (let ([ctc (coerce-contract 'instanceof/c cctc)])