Closes FB case 169 invariant-info should override equality because it is used in a set-equal? and contains syntax objects

free-identifier-tree-equal.rkt

@@ -1,6 +1,8 @@
 #lang racket
 
-(require racket/struct)
+(require racket/struct
+         ;; TODO: move delay-pure/private/immutable-struct to a separate package
+         delay-pure/private/immutable-struct) ;; for immutable-struct? below.
 
 (provide free-id-tree=?
          free-id-tree-hash-code
@@ -14,8 +16,29 @@
          make-mutable-free-id-tree-table
          make-weak-free-id-tree-table)
 
-(define (free-id-tree=? a b)
+;; Contract:
-  (define rec=? free-id-tree=?)
+;; TODO: move to tr-immutable
+(define isyntax/c
+  (flat-rec-contract isyntax
+                     (or/c boolean?
+                           char?
+                           number?
+                           keyword?
+                           null?
+                           (and/c string? immutable?)
+                           symbol?
+                           (box/c isyntax #:immutable #t)
+                           (cons/c isyntax isyntax)
+                           (vectorof isyntax #:immutable #t)
+                           (syntax/c isyntax)
+                           (and/c immutable-struct?
+                                  prefab-struct-key
+                                  (λ (v)
+                                    (andmap isyntax/c (struct->list v)))))))
+
+(define/contract (free-id-tree=? a b [r equal?])
+  (-> isyntax/c isyntax/c boolean?)
+  (define (rec=? a b) (free-id-tree=? a b r))
   (cond
     [(identifier? a) (and (identifier? b)
                           (free-identifier=? a b))]
@@ -38,17 +61,17 @@
                  (rec=? (struct->list a)
                         (struct->list b)))))]
     [(null? a) (null? b)]
-    [else (error (format "Unexpected value for free-id-tree=? : ~a"
+    [else (equal? a b)]))
-                         a))]))
 
-(define ((free-id-tree-hash hc) a)
+(define/contract ((free-id-tree-hash hc) a)
+  (-> (-> any/c fixnum?) (-> isyntax/c fixnum?))
   (define rec-hash (free-id-tree-hash hc))
   (cond
     [(identifier? a) (hc (syntax-e #'a))]
     [(syntax? a) (rec-hash (syntax-e a))]
     [(pair? a) (hc (cons (rec-hash (car a))
                          (rec-hash (cdr a))))]
-    [(vector? a) (hc (list->vector (rec-hash (vector->list a))))]
+    [(vector? a) (hc (list->vector (map rec-hash (vector->list a))))]
     [(box? a) (hc (box (rec-hash (unbox a))))]
     [(prefab-struct-key a)
      => (λ (a-key)

graph-info.hl.rkt

@@ -176,7 +176,17 @@ A field has a type.
          #:transparent
          #:methods gen:custom-write
          [(define write-proc (struct-printer 'invariant-info))]
-         #:property prop:custom-print-quotable 'never)]
+         #:property prop:custom-print-quotable 'never
+         #:methods gen:equal+hash
+         [(define (equal-proc a b r)
+            (free-id-tree=? (vector->immutable-vector (struct->vector a))
+                            (vector->immutable-vector (struct->vector b))))
+          (define (hash-proc a r)
+            (free-id-tree-hash-code
+             (vector->immutable-vector (struct->vector a))))
+          (define (hash2-proc a r)
+            (free-id-tree-secondary-hash-code
+             (vector->immutable-vector (struct->vector a))))])]
 
 @section{Dependent invariant information}
 
@@ -191,7 +201,17 @@ which relate the old and the new graph in a graph transformation.
          #:transparent
          #:methods gen:custom-write
          [(define write-proc (struct-printer 'dependent-invariant-info))]
-         #:property prop:custom-print-quotable 'never)]
+         #:property prop:custom-print-quotable 'never
+         #:methods gen:equal+hash
+         [(define (equal-proc a b r)
+            (free-id-tree=? (vector->immutable-vector (struct->vector a))
+                            (vector->immutable-vector (struct->vector b))))
+          (define (hash-proc a r)
+            (free-id-tree-hash-code
+             (vector->immutable-vector (struct->vector a))))
+          (define (hash2-proc a r)
+            (free-id-tree-secondary-hash-code
+             (vector->immutable-vector (struct->vector a))))])]
 
 @section{Mapping information}
 
@@ -278,6 +298,7 @@ data.
                 type-expander/expander
                 racket/struct
                 mzlib/pconvert
+                "free-identifier-tree-equal.rkt"
                 (for-syntax phc-toolkit/untyped
                             syntax/parse
                             syntax/parse/experimental/template
@@ -289,35 +310,30 @@ data.
              ([field contract] ...)
              {~optional {~and transparent #:transparent}}
              (~and {~seq methods+props ...}
-                   (~seq (~maybe #:methods
+                   (~seq (~or {~seq #:methods _ _}
-                                 {~literal gen:custom-write}
+                              {~seq #:property _ _})
-                                 _)
+                         ...)))
-                         (~maybe #:property
-                                 {~literal prop:custom-print-quotable}
-                                 _)))
-             {~optional {~and prefab #:prefab}})
          #:with name/c (format-id #'name "~a/c" #'name)
          ;(quasisyntax/loc (stx-car this-syntax)
          ;  #,
          (template
-              (begin
+          (begin
-                (struct name (?? parent) (field ...)
+            (struct name (?? parent) (field ...)
-                  (?? transparent)
+              (?? transparent)
-                  methods+props ...
+              methods+props ...)
-                  (?? prefab))
+            (define name/c
-                (define name/c
+              (struct/c name
-                  (struct/c name
+                        (?? (?@ parent-contract ...))
-                            (?? (?@ parent-contract ...))
+                        contract ...))
-                            contract ...))
+            (module+ test
-                (module+ test
+              (require rackunit)
-                  (require rackunit)
+              (check-pred flat-contract? name/c))
-                  (check-pred flat-contract? name/c))
+            (provide name/c
-                (provide name/c
+                     (contract-out (struct (?? (name parent) name)
-                         (contract-out (struct (?? (name parent) name)
+                                     ((?? (?@ [parent-field parent-contract]
-                                         ((?? (?@ [parent-field parent-contract]
+                                              ...))
-                                                  ...))
+                                      [field contract]
-                                          [field contract]
+                                      ...)))))))
-                                          ...)))))))
 
        ;<hash-set/c>
        <printer>

test/test-graph-type.rkt

@@ -4,6 +4,8 @@
          (lib "phc-graph/graph-type.hl.rkt"))
 (adt-init)
 
+(provide g1)
+
 (define-graph-type g1
   [City [name : String]
         [streets : (Listof Street)]
@@ -15,10 +17,12 @@
   #:invariant City.citizens._ ∈ City.streets._.houses._.owner
   #:invariant City.citizens._ ∋ City.streets._.houses._.owner)
 
-(begin
+(module* test racket/base
-  (require (for-syntax racket/pretty))
+  (require (for-syntax racket/pretty)
-  (define-syntax (debg _stx)
+           (submod ".."))
-    (parameterize ([pretty-print-columns 188])
+  (eval #'(begin
-      (pretty-print (syntax-local-value #'g1)))
+            (define-syntax (dbg _stx)
-    #'(void))
+              (parameterize ([pretty-print-columns 188])
-  (debg))
+                (pretty-print (syntax-local-value #'g1)))
+              #'(void))
+            (dbg))))