add a proper stronger implementation based for recursive-contract

Following _Subtyping Recursive Types_ by Roberto M. Amadio and Luca Cardelli

pkgs/racket-pkgs/racket-test/tests/racket/contract/stronger.rkt

@@ -14,10 +14,22 @@
   (ctest #f contract-stronger? (>=/c 2) (>=/c 3))
   (ctest #f contract-stronger? (<=/c 3) (<=/c 2))
   (ctest #t contract-stronger? (<=/c 2) (<=/c 3))
-  (ctest #f contract-stronger? (recursive-contract (<=/c 2)) (recursive-contract (<=/c 3)))
+  (ctest #t contract-stronger? (recursive-contract (<=/c 2)) (recursive-contract (<=/c 3)))
   (ctest #f contract-stronger? (recursive-contract (<=/c 3)) (recursive-contract (<=/c 2)))
   (let ([f (contract-eval '(λ (x) (recursive-contract (<=/c x))))])
     (test #t (contract-eval 'contract-stronger?) (contract-eval `(,f 1)) (contract-eval `(,f 1))))
+  (ctest #t contract-stronger?
+         (letrec ([c (recursive-contract (-> (<=/c 5) c))]) c)
+         (letrec ([c (recursive-contract (-> (<=/c 3) c))]) c))
+  (ctest #t contract-stronger?
+         (letrec ([c (recursive-contract (-> (<=/c 3) c))]) c)
+         (letrec ([c (recursive-contract (-> (<=/c 1) c))]) c))
+  (ctest #t contract-stronger?
+         (letrec ([c (recursive-contract (-> (<=/c 3) c))]) c)
+         (letrec ([c (recursive-contract (-> (<=/c 1) (-> (<=/c 1) c)))]) c))
+  (ctest #t contract-stronger?
+         (letrec ([c (recursive-contract (-> (<=/c 1) (-> (<=/c 1) c)))]) c)
+         (letrec ([c (recursive-contract (-> (<=/c 1) (-> (<=/c 1) (-> (<=/c 1) c))))]) c))
   (ctest #t contract-stronger? (-> integer? integer?) (-> integer? integer?))
   (ctest #f contract-stronger? (-> boolean? boolean?) (-> integer? integer?))
   (ctest #t contract-stronger? (-> (>=/c 3) (>=/c 3)) (-> (>=/c 4) (>=/c 3)))

racket/collects/racket/contract/private/base.rkt

@@ -174,16 +174,18 @@
        (λ (val)
          ((f blame-known) val)))]))
   
-(define (recursive-contract-stronger this that)
-  (and (recursive-contract? that)
-       (procedure-closure-contents-eq? (recursive-contract-thunk this)
-                                       (recursive-contract-thunk that))))
+(define (recursive-contract-stronger this that) (equal? this that))
+
+(define trail (make-parameter #f))
 
 (define ((recursive-contract-first-order ctc) val)
   (contract-first-order-passes? (force-recursive-contract ctc)
                                 val))
 
-(struct recursive-contract ([name #:mutable] thunk [ctc #:mutable] list-contract?))
+(struct recursive-contract ([name #:mutable] thunk [ctc #:mutable] list-contract?)
+  #:property prop:recursive-contract (λ (this)
+                                       (force-recursive-contract this)
+                                       (recursive-contract-ctc this)))
 
 (struct flat-recursive-contract recursive-contract ()
   #:property prop:custom-write custom-write-property-proc

racket/collects/racket/contract/private/prop.rkt

@@ -42,7 +42,16 @@
          
          prop:orc-contract
          prop:orc-contract?
-         prop:orc-contract-get-subcontracts)
+         prop:orc-contract-get-subcontracts
+         
+         prop:recursive-contract
+         prop:recursive-contract?
+         prop:recursive-contract-unroll
+         
+         prop:arrow-contract 
+         prop:arrow-contract?
+         prop:arrow-contract-get-info
+         (struct-out arrow-contract-info))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;
@@ -97,9 +106,28 @@
   (and get-projection 
        (get-projection c)))
 
+(define trail (make-parameter #f))
 (define (contract-struct-stronger? a b)
   (define prop (contract-struct-property a))
   (define stronger? (contract-property-stronger prop))
+  (cond
+    [(let ([tc (trail)])
+       (and tc
+            (ormap (λ (pr) (and (equal? (car pr) a) (equal? (cdr pr) b)))
+                   (unbox tc))))
+     #t]
+    [(or (prop:recursive-contract? a) (prop:recursive-contract? b))
+     (parameterize ([trail (or (trail) (box '()))])
+       (define trail-b (trail))
+       (define trail-c (unbox trail-b))
+       (set-box! trail-b (cons (cons a b) trail-c))
+       (contract-struct-stronger? (if (prop:recursive-contract? a)
+                                      ((prop:recursive-contract-unroll a) a)
+                                      a)
+                                  (if (prop:recursive-contract? b)
+                                      ((prop:recursive-contract-unroll b) b)
+                                      b)))]
+    [else
      (let loop ([b b])
        (cond
          [(stronger? a b) #t]
@@ -107,7 +135,7 @@
           (define sub-contracts ((prop:orc-contract-get-subcontracts b) b))
           (for/or ([sub-contract (in-list sub-contracts)])
             (loop sub-contract))]
-      [else #f])))
+         [else #f]))]))
 
 (define (contract-struct-generate c)
   (define prop (contract-struct-property c))
@@ -446,3 +474,22 @@
 ;; returns a list of contracts that were the original arguments to the or/c
 (define-values (prop:orc-contract prop:orc-contract? prop:orc-contract-get-subcontracts)
   (make-struct-type-property 'prop:orc-contract))
+
+;; property should be bound to a function that accepts the contract
+;; and returns a new contract, after unrolling one time
+(define-values (prop:recursive-contract
+                prop:recursive-contract?
+                prop:recursive-contract-unroll)
+  (make-struct-type-property 'prop:recursive-contract))
+
+;; get-info : (-> ctc arrow-contract-info?)
+(define-values (prop:arrow-contract prop:arrow-contract? prop:arrow-contract-get-info)
+  (make-struct-type-property 'prop:arrow-contract))
+
+;; chaperone-procedure : 
+;;   (-> any/c[val] blame? procedure[suitable for second argument to chaperone-procedure])
+;; check-first-order : any/c[val] blame? -> void? 
+;;     raises a blame error if val doesn't satisfy the first-order checks for the function
+;; accepts-arglist : (-> (listof keyword?)[sorted by keyword<?] exact-nonnegative-integer? boolean?)
+(struct arrow-contract-info (chaperone-procedure check-first-order accepts-arglist)
+  #:transparent)