add a stronger to class/c
This commit is contained in:
Robby Findler
parent
e946fed565
commit
bbb4897ce2
|
|
@ -230,9 +230,88 @@
|
|||
(ctest #t contract-stronger? (promise/c (<=/c 2)) (promise/c (<=/c 3)))
|
||||
(ctest #f contract-stronger? (promise/c (<=/c 3)) (promise/c (<=/c 2)))
|
||||
|
||||
(contract-eval
|
||||
`(let ([c (class/c (m (-> any/c integer?)))])
|
||||
(,test #t contract-stronger? (instanceof/c c) (instanceof/c c))))
|
||||
(ctest #t contract-stronger?
|
||||
(class/c (m (-> any/c (<=/c 3))))
|
||||
(class/c (m (-> any/c (<=/c 4)))))
|
||||
(ctest #f contract-stronger?
|
||||
(class/c (m (-> any/c (<=/c 4))))
|
||||
(class/c (m (-> any/c (<=/c 3)))))
|
||||
(ctest #t contract-stronger?
|
||||
(class/c (field [f integer?]))
|
||||
(class/c (field [f integer?])))
|
||||
(ctest #f contract-stronger?
|
||||
(class/c (field [f (<=/c 3)]))
|
||||
(class/c (field [f (<=/c 4)])))
|
||||
(ctest #f contract-stronger?
|
||||
(class/c (field [f (<=/c 4)]))
|
||||
(class/c (field [f (<=/c 3)])))
|
||||
(ctest #t contract-stronger?
|
||||
(class/c (init [f (<=/c 3)]))
|
||||
(class/c (init [f (<=/c 4)])))
|
||||
(ctest #f contract-stronger?
|
||||
(class/c (init [f (<=/c 4)]))
|
||||
(class/c (init [f (<=/c 3)])))
|
||||
(ctest #t contract-stronger?
|
||||
(class/c (inherit [m (-> any/c (<=/c 3))]))
|
||||
(class/c (inherit [m (-> any/c (<=/c 4))])))
|
||||
(ctest #f contract-stronger?
|
||||
(class/c (inherit [m (-> any/c (<=/c 4))]))
|
||||
(class/c (inherit [m (-> any/c (<=/c 3))])))
|
||||
(ctest #t contract-stronger?
|
||||
(class/c (super [m (-> any/c (<=/c 3))]))
|
||||
(class/c (super [m (-> any/c (<=/c 4))])))
|
||||
(ctest #f contract-stronger?
|
||||
(class/c (super [m (-> any/c (<=/c 4))]))
|
||||
(class/c (super [m (-> any/c (<=/c 3))])))
|
||||
(ctest #t contract-stronger?
|
||||
(class/c (inner [m (-> any/c (<=/c 3))]))
|
||||
(class/c (inner [m (-> any/c (<=/c 4))])))
|
||||
(ctest #f contract-stronger?
|
||||
(class/c (inner [m (-> any/c (<=/c 4))]))
|
||||
(class/c (inner [m (-> any/c (<=/c 3))])))
|
||||
(ctest #t contract-stronger?
|
||||
(class/c (override [m (-> any/c (<=/c 3))]))
|
||||
(class/c (override [m (-> any/c (<=/c 4))])))
|
||||
(ctest #f contract-stronger?
|
||||
(class/c (override [m (-> any/c (<=/c 4))]))
|
||||
(class/c (override [m (-> any/c (<=/c 3))])))
|
||||
(ctest #t contract-stronger?
|
||||
(class/c (augment [m (-> any/c (<=/c 3))]))
|
||||
(class/c (augment [m (-> any/c (<=/c 4))])))
|
||||
(ctest #f contract-stronger?
|
||||
(class/c (augment [m (-> any/c (<=/c 4))]))
|
||||
(class/c (augment [m (-> any/c (<=/c 3))])))
|
||||
(ctest #t contract-stronger?
|
||||
(class/c (augride [m (-> any/c (<=/c 3))]))
|
||||
(class/c (augride [m (-> any/c (<=/c 4))])))
|
||||
(ctest #f contract-stronger?
|
||||
(class/c (augride [m (-> any/c (<=/c 4))]))
|
||||
(class/c (augride [m (-> any/c (<=/c 3))])))
|
||||
(ctest #t contract-stronger?
|
||||
(class/c (absent m n))
|
||||
(class/c (absent m)))
|
||||
(ctest #f contract-stronger?
|
||||
(class/c (absent m))
|
||||
(class/c (absent m n)))
|
||||
(ctest #t contract-stronger?
|
||||
(class/c (absent (field f g)))
|
||||
(class/c (absent (field f))))
|
||||
(ctest #f contract-stronger?
|
||||
(class/c (absent (field f)))
|
||||
(class/c (absent (field f g))))
|
||||
(ctest #f contract-stronger?
|
||||
(class/c (absent (field x)))
|
||||
(class/c (absent x)))
|
||||
(ctest #f contract-stronger?
|
||||
(class/c (absent x))
|
||||
(class/c (absent (field x))))
|
||||
|
||||
(ctest #t contract-stronger?
|
||||
(instanceof/c (class/c (m (-> any/c (<=/c 3)))))
|
||||
(instanceof/c (class/c (m (-> any/c (<=/c 4))))))
|
||||
(ctest #f contract-stronger?
|
||||
(instanceof/c (class/c (m (-> any/c (<=/c 4)))))
|
||||
(instanceof/c (class/c (m (-> any/c (<=/c 3))))))
|
||||
|
||||
;; chances are, this predicate will accept "x", but
|
||||
;; we don't want to consider it stronger, since it
|
||||
|
|
|
|||
|
|
@ -819,7 +819,118 @@
|
|||
(list (cons 'absent meths))]
|
||||
[else
|
||||
(list `(absent ,@meths (field ,@fields)))]))
|
||||
|
||||
|
||||
(define (class/c-stronger this that)
|
||||
(define this-internal (class/c-internal this))
|
||||
(cond
|
||||
[(class/c? that)
|
||||
(define that-internal (class/c-internal that))
|
||||
(and
|
||||
;; methods
|
||||
(check-one-stronger class/c-methods class/c-method-contracts this that)
|
||||
|
||||
;; inits
|
||||
(check-one-stronger class/c-inits class/c-init-contracts this that)
|
||||
|
||||
;; check both ways for fields (since mutable)
|
||||
(check-one-stronger class/c-fields class/c-field-contracts this that)
|
||||
(check-one-stronger class/c-fields class/c-field-contracts that this)
|
||||
|
||||
|
||||
;; inherits
|
||||
(check-one-stronger internal-class/c-inherits internal-class/c-inherit-contracts
|
||||
this-internal that-internal)
|
||||
;; inherit fields, both ways
|
||||
(check-one-stronger internal-class/c-inherit-fields internal-class/c-inherit-field-contracts
|
||||
this-internal that-internal)
|
||||
(check-one-stronger internal-class/c-inherit-fields internal-class/c-inherit-field-contracts
|
||||
that-internal this-internal)
|
||||
;; supers
|
||||
(check-one-stronger internal-class/c-supers internal-class/c-super-contracts
|
||||
this-internal that-internal)
|
||||
;; inners
|
||||
(check-one-stronger internal-class/c-inners internal-class/c-inner-contracts
|
||||
this-internal that-internal)
|
||||
;; overrides
|
||||
(check-one-stronger internal-class/c-overrides internal-class/c-override-contracts
|
||||
this-internal that-internal)
|
||||
;; augments
|
||||
(check-one-stronger internal-class/c-augments internal-class/c-augment-contracts
|
||||
this-internal that-internal)
|
||||
;; augrides
|
||||
(check-one-stronger internal-class/c-augrides internal-class/c-augride-contracts
|
||||
this-internal that-internal)
|
||||
|
||||
(if (class/c-opaque? this) (class/c-opaque? that) #t)
|
||||
(all-included? (class/c-absent-fields that) (class/c-absent-fields this))
|
||||
(all-included? (class/c-absents that) (class/c-absents this)))]
|
||||
[else #f]))
|
||||
|
||||
(define (all-included? this-items that-items)
|
||||
(for/and ([this-item (in-list this-items)])
|
||||
(for/or ([that-item (in-list that-items)])
|
||||
(equal? this-item that-item))))
|
||||
|
||||
(define (check-one-stronger names-sel ctcs-sel this that)
|
||||
;; this is an O(n^2) loop that could be made asymptotically
|
||||
;; better with sorting, but since there are generally not a
|
||||
;; ton of methods, the naive loop appears to be faster.
|
||||
;; in the current racket, and assuming the code below is
|
||||
;; representative of the two approaches, the tradeoff point
|
||||
;; appears to be somewhere around 60 or 70 methods.
|
||||
#|
|
||||
#lang racket
|
||||
|
||||
(define (n2-way l1 l2)
|
||||
(for/and ([x (in-list l1)])
|
||||
(or (for/or ([y (in-list l2)])
|
||||
#f)
|
||||
#t)))
|
||||
|
||||
(define (nlgn-way l1 l2)
|
||||
(define sl1 (sort l1 <))
|
||||
(define sl2 (sort l2 <))
|
||||
(let loop ([l1 l1][l2 l2])
|
||||
(cond
|
||||
[(null? l1) #t]
|
||||
[(null? l2) #t]
|
||||
[(< (car l1) (car l2)) (loop (cdr l1) l2)]
|
||||
[(< (car l2) (car l1)) (loop l1 (cdr l2))]
|
||||
[else (loop (cdr l1) (cdr l2))])))
|
||||
|
||||
|
||||
(define (try n c)
|
||||
(define l1 (build-list n (λ (_) (random))))
|
||||
(define l2 (build-list n (λ (_) (random))))
|
||||
(time (for ([x (in-range c)])
|
||||
(n2-way l1 l2) (n2-way l1 l2) (n2-way l1 l2)
|
||||
(n2-way l1 l2) (n2-way l1 l2) (n2-way l1 l2)
|
||||
(n2-way l1 l2) (n2-way l1 l2) (n2-way l1 l2)
|
||||
(n2-way l1 l2) (n2-way l1 l2) (n2-way l1 l2)))
|
||||
(time (for ([x (in-range c)])
|
||||
(nlgn-way l1 l2) (nlgn-way l1 l2) (nlgn-way l1 l2)
|
||||
(nlgn-way l1 l2) (nlgn-way l1 l2) (nlgn-way l1 l2)
|
||||
(nlgn-way l1 l2) (nlgn-way l1 l2) (nlgn-way l1 l2)
|
||||
(nlgn-way l1 l2) (nlgn-way l1 l2) (nlgn-way l1 l2))))
|
||||
|
||||
|
||||
50
|
||||
(try 50 10000)
|
||||
60
|
||||
(try 60 10000)
|
||||
70
|
||||
(try 70 10000)
|
||||
80
|
||||
(try 80 10000)
|
||||
|#
|
||||
|
||||
(for/and ([this-name (in-list (names-sel this))]
|
||||
[this-ctc (in-list (ctcs-sel this))])
|
||||
(for/or ([that-name (in-list (names-sel that))]
|
||||
[that-ctc (in-list (ctcs-sel that))])
|
||||
(and (equal? this-name that-name)
|
||||
(contract-stronger? this-ctc that-ctc)))))
|
||||
|
||||
(define-struct class/c
|
||||
(methods method-contracts fields field-contracts inits init-contracts
|
||||
absents absent-fields
|
||||
|
|
@ -830,7 +941,7 @@
|
|||
(build-contract-property
|
||||
#:projection class/c-proj
|
||||
#:name build-class/c-name
|
||||
#:stronger (λ (this that) (equal? this that))
|
||||
#:stronger class/c-stronger
|
||||
#:first-order
|
||||
(λ (ctc)
|
||||
(λ (cls)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user