From ff2956d031f9ccea840d56c37d4011e826c873dd Mon Sep 17 00:00:00 2001
From: Daniel Feltey <dfeltey@gmail.com>
Date: Wed, 25 Apr 2018 15:17:01 -0500
Subject: [PATCH] Improve contract-stronger for object/c-opaque

This changes `contract-stronger?` to recognize that if two contracts
both restrict the same field or method to not be callable, then they
are equally strong.
---
 .../typed-racket/utils/opaque-object.rkt      | 16 +++++++-
 .../succeed/opaque-object-stronger.rkt        | 40 ++++++++++++++++++-
 2 files changed, 53 insertions(+), 3 deletions(-)

diff --git a/typed-racket-lib/typed-racket/utils/opaque-object.rkt b/typed-racket-lib/typed-racket/utils/opaque-object.rkt
index c8e2deeb5..c66ae47cc 100644
--- a/typed-racket-lib/typed-racket/utils/opaque-object.rkt
+++ b/typed-racket-lib/typed-racket/utils/opaque-object.rkt
@@ -39,6 +39,10 @@
 
 (provide object/c-opaque)
 
+(module+ for-testing
+  (provide restrict-typed->/c
+           restrict-typed-field/c))
+
 ;; projection for base-object/c-opaque
 (define ((object/c-opaque-late-neg-proj ctc) blame)
   (λ (obj neg-party)
@@ -172,7 +176,11 @@
         #:property prop:chaperone-contract
         (build-chaperone-contract-property
          #:name restrict-typed->-name
-         #:stronger equal?
+         #:stronger
+         (λ (this that)
+           (define this-name (restrict-typed->/c-name this))
+           (define that-name (restrict-typed->/c-name that))
+           (eq? this-name that-name))
          #:late-neg-projection restrict-typed->-late-neg-projection))
 
 (define (restrict-typed-field-late-neg-proj ctc)
@@ -198,5 +206,9 @@
         #:property prop:flat-contract
         (build-flat-contract-property
          #:name restrict-typed-field-name
-         #:stronger equal?
+         #:stronger
+         (λ (this that)
+           (define this-name (restrict-typed-field/c-name this))
+           (define that-name (restrict-typed-field/c-name that))
+           (eq? this-name that-name))
          #:late-neg-projection restrict-typed-field-late-neg-proj))
diff --git a/typed-racket-test/succeed/opaque-object-stronger.rkt b/typed-racket-test/succeed/opaque-object-stronger.rkt
index 6c83661e5..dcba8df6a 100644
--- a/typed-racket-test/succeed/opaque-object-stronger.rkt
+++ b/typed-racket-test/succeed/opaque-object-stronger.rkt
@@ -1,5 +1,6 @@
 #lang racket
-(require typed-racket/utils/opaque-object)
+(require typed-racket/utils/opaque-object
+         (submod typed-racket/utils/opaque-object for-testing))
 
 ;; --------------------------------------------------------------------------------------------------
 ;; test helpers
@@ -184,3 +185,40 @@
       (m1 (->m any/c any/c any/c))))
 
 )
+
+(let () ;; restrict-typed->/c and restrict-typed-field/c
+    (test-stronger?
+     (restrict-typed->/c 'foo)
+     (restrict-typed->/c 'foo))
+
+    (test-not-stronger?
+     (restrict-typed->/c 'foo)
+     (restrict-typed->/c 'bar))
+
+    (test-stronger?
+     (restrict-typed-field/c 'foo)
+     (restrict-typed-field/c 'foo))
+
+  (test-not-stronger?
+     (restrict-typed-field/c 'foo)
+     (restrict-typed-field/c 'bar))
+)
+
+(let ()
+  (define ctc
+    (object/c-opaque
+     (mtd (->m any/c any/c))))
+  (define (make-obj)
+    (new
+     (class object%
+       (super-new)
+       (define/public (mtd x) x)
+       (define/public (guts) #f))))
+  (define c1
+    (value-contract
+     (contract ctc (make-obj) 'p 'n)))
+  (define c2
+    (value-contract
+     (contract ctc (make-obj) 'p 'n)))
+  (test-stronger? c1 c2)
+  (test-stronger? c2 c1))