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

Make equal? on classes and objects see through class contracts

Browse Source 
Making `equal?` do the right thing on classes turned out to be easy---it
just involved adding a straightforward `prop:equal+hash` property to the
`class` struct—but making it work properly for *objects* was the tricky
part. The trouble is that `equal?` on objects that don’t implement the
`equal<%>` interface is just ordinary structure equality, which can be
relevant if objects are inspectable. Writing `(inspect #f)` in a class
body is like making a struct `#:transparent`, and it has all the same
ramifications for equality.

The trouble is that `class/c` creates new wrapper classes, and every
class has its own struct type. Since the default behavior of `equal?` on
structs is to *never* be equal to structs of different types, even
subtypes, an object created from a contracted class can never be
`equal?` to an object created from the same class without contracts.

The solution is to add a `prop:equal+hash` property to `object%` itself
that emulates the default behavior of `equal?`, but sees through class
contract wrappers. Since struct type properties are inherited by
subtypes, this property will be present on all objects, and it only
needs to be attached once.

fixes #2279
This commit is contained in:
Alexis King 2019-04-04 14:53:23 -05:00
parent 47467a1dba
commit 1bf416a776
2 changed files with 189 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

151
pkgs/racket-test-core/tests/racket/object.rktl
View File

@ -1647,6 +1647,157 @@
(check #f #t)
(check #t #t))
;; ----------------------------------------
;; equal? on classes
(let ()
(define a%
(class object%
(init-field x)
(super-new)
(define/public (m) #f)))
; subclasses are never equal? to their superclasses
(define b%
(class a%
(super-new)))
(test #f equal? a% b%)
(test #f equal? b% a%)
; class contracts do not affect equality
(define/contract a%+c1
(class/c (init-field [x integer?])
[m (->m integer?)])
a%)
(test #t equal? a% a%+c1)
(test #t equal? a%+c1 a%)
(test #f equal? a%+c1 b%)
(test #f equal? b% a%+c1)
; still equal? even with different contracts
(define/contract a%+c2
(class/c (init-field [x string?])
[m (->m string?)])
a%)
(test #t equal? a%+c1 a%+c2)
(test #t equal? a%+c2 a%+c1))
;; ----------------------------------------
;; equal? on objects with (inspect #f)
(let ()
(define no-fields/opaque%
(class object%
(super-new)))
(test #f equal? (new no-fields/opaque%) (new no-fields/opaque%))
(define no-fields/transparent%
(class object%
(inspect #f)
(super-new)))
(test #t equal? (new no-fields/transparent%) (new no-fields/transparent%))
(define two-fields/transparent%
(class object%
(inspect #f)
(init-field a b)
(super-new)))
(test #t equal? (new two-fields/transparent% [a 1] [b 2]) (new two-fields/transparent% [a 1] [b 2]))
(test #f equal? (new two-fields/transparent% [a 2] [b 1]) (new two-fields/transparent% [a 1] [b 2]))
(test #f equal?
(new two-fields/transparent% [a #t] [b #t])
(new two-fields/transparent% [a #t] [b #f]))
(test #t equal?
(new two-fields/transparent% [a (list 1)] [b (list 2)])
(new two-fields/transparent% [a (list 1)] [b (list 2)]))
; having a transparent superclass doesn’t matter if you are opaque
(define no-new-fields/opaque%
(class two-fields/transparent%
(super-new)))
(test #f equal? (new no-new-fields/opaque% [a 1] [b 2]) (new no-new-fields/opaque% [a 1] [b 2]))
; transparent subclasses are equal? to other objects of the same class, but not of superclasses
(define no-new-fields/transparent%
(class two-fields/transparent%
(inspect #f)
(super-new)))
(test #t equal?
(new no-new-fields/transparent% [a 1] [b 2])
(new no-new-fields/transparent% [a 1] [b 2]))
(test #f equal?
(new no-new-fields/transparent% [a 2] [b 1])
(new no-new-fields/transparent% [a 1] [b 2]))
(test #f equal?
(new two-fields/transparent% [a 1] [b 2])
(new no-new-fields/transparent% [a 1] [b 2]))
(test #f equal?
(new no-new-fields/transparent% [a 1] [b 2])
(new two-fields/transparent% [a 1] [b 2]))
; transparent subclasses are only equal if all their fields are the same, including in superclasses
(define one-new-field%
(class two-fields/transparent%
(inspect #f)
(init-field c)
(super-new)))
(test #t equal? (new one-new-field% [a 1] [b 2] [c 3]) (new one-new-field% [a 1] [b 2] [c 3]))
(test #f equal?
(new one-new-field% [a #t] [b #t] [c #t])
(new one-new-field% [a #t] [b #t] [c #f]))
(test #f equal?
(new one-new-field% [a #t] [b #t] [c #t])
(new one-new-field% [a #f] [b #t] [c #t]))
; classes with opaque superclasses are never equal?, even if they are transparent
(define two-fields/opaque%
(class object%
(init-field a b)
(super-new)))
(define no-new-fields/parent-opaque%
(class two-fields/opaque%
(inspect #f)
(super-new)))
(define one-new-fields/parent-opaque%
(class two-fields/opaque%
(inspect #f)
(init-field c)
(super-new)))
(test #f equal?
(new no-new-fields/parent-opaque% [a 1] [b 2])
(new no-new-fields/parent-opaque% [a 1] [b 2]))
(test #f equal?
(new one-new-fields/parent-opaque% [a 1] [b 2] [c 3])
(new one-new-fields/parent-opaque% [a 1] [b 2] [c 3]))
; class contracts do not affect object equality
(define/contract two-fields/transparent%+c
(class/c (init-field [a integer?] [b (vectorof symbol?)]))
two-fields/transparent%)
(test #t equal?
(new two-fields/transparent% [a 1] [b (vector 'x)])
(new two-fields/transparent%+c [a 1] [b (vector 'x)]))
(test #f equal?
(new two-fields/transparent% [a 1] [b (vector 'x)])
(new two-fields/transparent%+c [a 2] [b (vector 'x)]))
(test #f equal?
(new two-fields/transparent% [a 1] [b (vector 'x)])
(new two-fields/transparent%+c [a 1] [b (vector 'y)]))
; object contracts do not affect object equality
(define/contract (make-two-fields/transparent%+c a b)
(-> integer? (vectorof symbol?) (object/c (field [a integer?] [b (vectorof symbol?)])))
(new two-fields/transparent% [a a] [b b]))
(test #t equal?
(new two-fields/transparent% [a 1] [b (vector 'x)])
(make-two-fields/transparent%+c 1 (vector 'x)))
(test #f equal?
(new two-fields/transparent% [a 1] [b (vector 'x)])
(make-two-fields/transparent%+c 2 (vector 'x)))
(test #f equal?
(new two-fields/transparent% [a 1] [b (vector 'x)])
(make-two-fields/transparent%+c 1 (vector 'y))))
;; ----------------------------------------
;; Implementing equal<%>

40
racket/collects/racket/private/class-internal.rkt
View File

@ -2074,7 +2074,11 @@
check-undef? ; objects need an unsafe-undefined guarding chaperone?
no-super-init?); #t => no super-init needed
#:inspector insp)
#:inspector insp
#:property prop:equal+hash
(list (λ (cls-a cls-b recur) (eq? (class-orig-cls cls-a) (class-orig-cls cls-b)))
(λ (cls recur) (eq-hash-code (class-orig-cls cls)))
(λ (cls recur) (eq-hash-code (class-orig-cls cls)))))
#|
@ -3267,6 +3271,32 @@ An example
(make-struct-type name type 0 0 #f props insp))
make-)
(define not-all-visible (gensym 'not-all-visible))
(define (inspectable-struct->vector v)
(define vec (struct->vector v not-all-visible))
(and (for/and ([elem (in-vector vec)])
(not (eq? elem not-all-visible)))
vec))
; Even though equality on objects is morally just struct equality, we have to reimplement it here
; because of the way class contracts work. Every time a class contract is applied, it creates a new
; class, which in turn creates a new struct. This breaks equal? on objects, since two structs of
; different types are never equal? (without a custom prop:equal+hash), even if one is a subtype of the
; other. Therefore, we need to emulate what the behavior of equal? would have been if class contracts
; didn’t create new struct types. (This can go away if class/c is ever rewritten to use chaperones.)
(define (object-equal? obj-a obj-b recur)
(and (equal? (object-ref obj-a) (object-ref obj-b))
(let ([vec-a (inspectable-struct->vector obj-a)])
(and vec-a (let ([vec-b (inspectable-struct->vector obj-b)])
(and vec-b (for/and ([elem-a (in-vector vec-a 1)]
[elem-b (in-vector vec-b 1)])
(recur elem-a elem-b))))))))
(define (object-hash-code obj recur)
(let ([vec (inspectable-struct->vector obj)])
(if vec
(recur (vector (object-ref obj) vec))
(eq-hash-code obj))))
(define object<%> ((make-naming-constructor struct:interface 'interface:object% #f)
'object% null #f null (make-immutable-hash) #f null))
(setup-all-implemented! object<%>)
@ -3307,7 +3337,13 @@ An example
(vector-set! (class-supers object%) 0 object%)
(set-class-orig-cls! object% object%)
(let*-values ([(struct:obj make-obj obj? -get -set!)
(make-struct-type 'object #f 0 0 #f (list (cons prop:object object%)) #f)])
(make-struct-type 'object #f 0 0 #f
(list (cons prop:object object%)
(cons prop:equal+hash
(list object-equal?
object-hash-code
object-hash-code)))
#f)])
(set-class-struct:object! object% struct:obj)
(set-class-make-object! object% make-obj))
(set-class-object?! object% object?) ; don't use struct pred; it wouldn't work with prim classes