From 9e3a9d17d5770eca1bc5d5da09e859b0eef038fe Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Wed, 24 Sep 2014 10:40:26 -0500
Subject: [PATCH] add stronger to is-a?/c

---
 .../tests/racket/contract/stronger.rkt        | 14 ++++++
 .../racket/contract/private/object.rkt        | 46 ++++++++++++++-----
 2 files changed, 49 insertions(+), 11 deletions(-)

diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/contract/stronger.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/contract/stronger.rkt
index b46a31f849..9e595ea253 100644
--- a/pkgs/racket-pkgs/racket-test/tests/racket/contract/stronger.rkt
+++ b/pkgs/racket-pkgs/racket-test/tests/racket/contract/stronger.rkt
@@ -316,6 +316,20 @@
          (instanceof/c (class/c (m (-> any/c (<=/c 4)))))
          (instanceof/c (class/c (m (-> any/c (<=/c 3))))))
   
+  (ctest #t contract-stronger? (is-a?/c object%) (is-a?/c object%))
+  (ctest #t contract-stronger? (is-a?/c (class object% (super-new))) (is-a?/c object%))
+  (ctest #f contract-stronger? (is-a?/c object%) (is-a?/c (class object% (super-new))))
+  (contract-eval `(define one-interface<%> (interface ())))
+  (contract-eval `(define another-interface<%> (interface (one-interface<%>))))
+  (ctest #t contract-stronger? (is-a?/c another-interface<%>) (is-a?/c one-interface<%>))
+  (ctest #f contract-stronger? (is-a?/c one-interface<%>) (is-a?/c another-interface<%>))
+  (ctest #t contract-stronger? 
+         (is-a?/c (class* object% (one-interface<%>) (super-new)))
+         (is-a?/c one-interface<%>))
+  (ctest #f contract-stronger?
+         (is-a?/c one-interface<%>) 
+         (is-a?/c (class* object% (one-interface<%>) (super-new))))
+  
   ;; chances are, this predicate will accept "x", but
   ;; we don't want to consider it stronger, since it 
   ;; will not always accept "x".
diff --git a/racket/collects/racket/contract/private/object.rkt b/racket/collects/racket/contract/private/object.rkt
index f3d77a32fa..0390d03ed8 100644
--- a/racket/collects/racket/contract/private/object.rkt
+++ b/racket/collects/racket/contract/private/object.rkt
@@ -120,21 +120,45 @@
       (format "~s" '(or/c interface? class?))
       %/<%>)]))
 
+(struct is-a?-ctc (<%>)
+  #:property prop:custom-write custom-write-property-proc
+  #:property prop:flat-contract
+  (build-flat-contract-property
+   #:first-order
+   (λ (ctc)
+     (define <%> (is-a?-ctc-<%> ctc))
+     (λ (x) (is-a? x <%>)))
+   #:stronger
+   (λ (this that)
+     (define this-<%> (is-a?-ctc-<%> this))
+     (cond
+       [(is-a?-ctc? that)
+        (define that-<%> (is-a?-ctc-<%> that))
+        (cond
+          [(and (class? this-<%>) (class? that-<%>))
+           (subclass? this-<%> that-<%>)]
+          [(and (class? this-<%>) (interface? that-<%>))
+           (implementation? this-<%> that-<%>)]
+          [(and (interface? this-<%>) (interface? that-<%>))
+           (interface-extension? this-<%> that-<%>)]
+          [else #f])]
+       [else #f]))
+   #:name
+   (λ (ctc)
+     (define <%> (is-a?-ctc-<%> ctc))
+     (define name (object-name <%>))
+     (cond
+       [name `(is-a?/c ,name)]
+       [(class? <%>) `(is-a?/c unknown%)]
+       [else `(is-a?/c unknown<%>)]))))
+
+
 (define (is-a?/c <%>)
   (check-is-a?/c <%>)
-  (define name (object-name <%>))
-  (flat-named-contract
-   (cond
-     [name
-      `(is-a?/c ,name)]
-     [(class? <%>)
-      `(is-a?/c unknown%)]
-     [else `(is-a?/c unknown<%>)])
-   (lambda (x) (is-a? x <%>))))
-
+  (is-a?-ctc <%>))
+  
 (define mixin-contract (->i ([c% class?]) [res (c%) (subclass?/c c%)]))
 
-
 (define/opter (is-a?/c opt/i opt/info stx)
   (syntax-case stx ()
     [(_ cls)