From 98d06571411dbc5dd2ab20fdb6310756423e7563 Mon Sep 17 00:00:00 2001
From: Asumu Takikawa <asumu@ccs.neu.edu>
Date: Thu, 21 Jul 2016 11:14:05 -0400
Subject: [PATCH] Fix contracts for structs with the same name (PR 15330)
 (#410)

Fix contracts for structs with the same name

Closes PR 15330
---
 .../static-contracts/combinators/simple.rkt   | 20 ++++++++++----
 typed-racket-test/succeed/pr15330.rkt         | 22 +++++++++++++++
 .../static-contract-equality-tests.rkt        | 27 +++++++++++++++++++
 3 files changed, 64 insertions(+), 5 deletions(-)
 create mode 100644 typed-racket-test/succeed/pr15330.rkt
 create mode 100644 typed-racket-test/unit-tests/static-contract-equality-tests.rkt

diff --git a/typed-racket-lib/typed-racket/static-contracts/combinators/simple.rkt b/typed-racket-lib/typed-racket/static-contracts/combinators/simple.rkt
index b2e0ad06..7a57fb28 100644
--- a/typed-racket-lib/typed-racket/static-contracts/combinators/simple.rkt
+++ b/typed-racket-lib/typed-racket/static-contracts/combinators/simple.rkt
@@ -30,16 +30,26 @@
   (display close port))
 
 
+;; check equality of two syntax objects by structural traversal
+;; where identifiers are compared by free-identifier=?
+;;
+;; Note: does not handle cycles but there shouldn't be any
+(define (stx-equal? s1 s2)
+  (cond [(and (identifier? s1) (identifier? s2))
+         (free-identifier=? s1 s2)]
+        [else
+         (if (and (syntax? s1) (syntax? s2))
+             (equal?/recur (syntax-e s1) (syntax-e s2) stx-equal?)
+             (equal?/recur s1 s2 stx-equal?))]))
 
 (struct simple-contract static-contract (syntax kind name)
         #:transparent
         #:methods gen:equal+hash
          [(define (equal-proc s1 s2 recur)
-            (and ;; only check s-expression equality because it's
-                 ;; unlikely that TR will compile contracts that are
-                 ;; s-exp equal but aren't actually the same contract
-                 (recur (syntax->datum (simple-contract-syntax s1))
-                        (syntax->datum (simple-contract-syntax s2)))
+            (and ;; have to make sure identifiers are compared by free-id=?
+                 ;; because of struct predicates, opaque, etc.
+                 (stx-equal? (simple-contract-syntax s1)
+                             (simple-contract-syntax s2))
                  (recur (simple-contract-kind s1)
                         (simple-contract-kind s2))
                  (recur (simple-contract-name s1)
diff --git a/typed-racket-test/succeed/pr15330.rkt b/typed-racket-test/succeed/pr15330.rkt
new file mode 100644
index 00000000..d168f687
--- /dev/null
+++ b/typed-racket-test/succeed/pr15330.rkt
@@ -0,0 +1,22 @@
+#lang racket/base
+
+;; Test for PR 15330
+;;
+;; Make sure struct contracts with the same name bound in different
+;; places will work correctly
+
+(module base typed/racket/base
+ 
+  (provide (struct-out Record))
+  (struct Record ([id : Integer]) #:transparent))
+
+(module yy typed/racket/base
+ 
+  (require (prefix-in roles: (submod ".." base)))
+  (provide (struct-out Record))
+  (struct Record ([subrec : roles:Record]) #:transparent))
+
+(require (prefix-in role: 'yy)
+         (prefix-in roles: 'base))
+         
+(role:Record-subrec (role:Record (roles:Record 0)))
diff --git a/typed-racket-test/unit-tests/static-contract-equality-tests.rkt b/typed-racket-test/unit-tests/static-contract-equality-tests.rkt
new file mode 100644
index 00000000..6137f278
--- /dev/null
+++ b/typed-racket-test/unit-tests/static-contract-equality-tests.rkt
@@ -0,0 +1,27 @@
+#lang racket/base
+
+;; Tests for equality predicates on static contract values
+
+(require rackunit
+         typed-racket/static-contracts/combinators)
+
+;; these should be equal for optimizations to kick in
+(check-equal? (flat/sc #'(quote 3)) (flat/sc #'(quote 3)))
+(check-equal? (flat/sc #'(lambda (x) (integer? x)))
+              (flat/sc #'(lambda (x) (integer? x))))
+
+(define (make-stx id)
+  #`(lambda (x) (#,id x)))
+(define foo-stx-1 (make-stx #'foo?))
+(define foo-stx-2 (make-stx #'foo?))
+
+(parameterize ([current-namespace (make-base-namespace)])
+  (eval #'(struct foo (x)))
+  (define foo-stx-3 (make-stx (expand #'foo?)))
+  (define foo-stx-4 (make-stx (expand #'foo?)))
+
+  (check-equal? (flat/sc foo-stx-1) (flat/sc foo-stx-2))
+  (check-equal? (flat/sc foo-stx-3) (flat/sc foo-stx-4))
+
+  ;; these shouldn't be equal because bindings are different
+  (check-not-equal? (flat/sc foo-stx-1) (flat/sc foo-stx-3)))