From 1f1479c7be53a29571eedcde70c5a6cb4bda8773 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Wed, 24 Sep 2014 12:43:04 -0500
Subject: [PATCH] add stronger to implementation?/c and subclass?/c

also, bring down below 102 cols
---
 .../tests/racket/contract/stronger.rkt        |  9 ++++
 .../racket/contract/private/object.rkt        | 51 ++++++++++++-------
 2 files changed, 43 insertions(+), 17 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 9e595ea253..4e810aa9d3 100644
--- a/pkgs/racket-pkgs/racket-test/tests/racket/contract/stronger.rkt
+++ b/pkgs/racket-pkgs/racket-test/tests/racket/contract/stronger.rkt
@@ -330,6 +330,15 @@
          (is-a?/c one-interface<%>) 
          (is-a?/c (class* object% (one-interface<%>) (super-new))))
   
+  (ctest #t contract-stronger? (subclass?/c (class object% (super-new))) (subclass?/c object%))
+  (ctest #f contract-stronger? (subclass?/c object%) (subclass?/c (class object% (super-new))))
+  (ctest #t contract-stronger?
+         (implementation?/c another-interface<%>)
+         (implementation?/c one-interface<%>))
+  (ctest #f contract-stronger?
+         (implementation?/c one-interface<%>)
+         (implementation?/c another-interface<%>))
+  
   ;; 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 0390d03ed8..8ce589f349 100644
--- a/racket/collects/racket/contract/private/object.rkt
+++ b/racket/collects/racket/contract/private/object.rkt
@@ -71,10 +71,13 @@
      (with-syntax ([(((method-id method-ctc) ...)
                      ((field-id field-ctc) ...))
                     (parse-object-contract stx #'(spec ...))])
-       (with-syntax ([(method-name ...) (map (λ (x) (string->symbol (format "~a method" (syntax-e x)))) 
-                                             (syntax->list #'(method-id ...)))])
+       (with-syntax ([(method-name ...)
+                      (map (λ (x) (string->symbol (format "~a method" (syntax-e x))))
+                           (syntax->list #'(method-id ...)))])
          #'(build-object-contract '(method-id ...)
-                                  (syntax-parameterize ((making-a-method #t)) (list (let ([method-name method-ctc]) method-name) ...))
+                                  (syntax-parameterize
+                                   ((making-a-method #t))
+                                   (list (let ([method-name method-ctc]) method-name) ...))
                                   '(field-id ...)
                                   (list field-ctc ...))))]))
 
@@ -90,25 +93,39 @@
                    (apply and/c (map sub/impl?/c %/<%>s)))])
        [res (c%) (subclass?/c c%)]))
 
+(struct subclass/c (%)
+  #:property prop:custom-write custom-write-property-proc
+  #:property prop:flat-contract
+  (build-flat-contract-property
+   #:first-order (λ (ctc) (define % (subclass/c-% ctc)) (λ (x) (subclass? x %)))
+   #:stronger (λ (this that)
+                (cond
+                  [(subclass/c? that)
+                   (subclass? (subclass/c-% this) (subclass/c-% that))]
+                  [else #f]))
+   #:name (λ (ctc) `(subclass?/c ,(or (object-name (subclass/c-% ctc)) 'unknown%)))))
 (define (subclass?/c %)
   (unless (class? %)
-    (raise-argument-error 'subclass?/c
-                          "class?"
-                          %))
-  (define name (object-name %))
-  (flat-named-contract
-   `(subclass?/c ,(or name 'unknown%))
-   (lambda (x) (subclass? x %))))
+    (raise-argument-error 'subclass?/c "class?" %))
+  (subclass/c %))
 
+(struct implementation/c (<%>)
+  #:property prop:custom-write custom-write-property-proc
+  #:property prop:flat-contract
+  (build-flat-contract-property
+   #:first-order (λ (ctc) (define <%> (implementation/c-<%> ctc)) (λ (x) (implementation? x <%>)))
+   #:stronger (λ (this that)
+                (cond
+                  [(implementation/c? that)
+                   (interface-extension? (implementation/c-<%> this)
+                                         (implementation/c-<%> that))]
+                  [else #f]))
+   #:name (λ (ctc) `(implementation?/c ,(or (object-name (implementation/c-<%> ctc)) 'unknown<%>)))))
+            
 (define (implementation?/c <%>)
   (unless (interface? <%>)
-    (raise-argument-error 'implementation?/c
-                          "interface?"
-                          <%>))
-  (define name (object-name <%>))
-  (flat-named-contract
-   `(implementation?/c ,(or name 'unknown<%>))
-   (lambda (x) (implementation? x <%>))))
+    (raise-argument-error 'implementation?/c "interface?" <%>))
+  (implementation/c <%>))
 
 (define (sub/impl?/c %/<%>)
   (cond