From 4589fdff69eeb5e31ac8219552006d0113492670 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= <georges.duperon@gmail.com>
Date: Fri, 20 Jan 2017 16:04:40 +0100
Subject: [PATCH] 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 | 37 ++++++++++++++----
graph-info.hl.rkt | 70 +++++++++++++++++++++-------------
test/test-graph-type.rkt | 18 +++++----
3 files changed, 84 insertions(+), 41 deletions(-)
diff --git a/free-identifier-tree-equal.rkt b/free-identifier-tree-equal.rkt
index 1d6e74a..1eac8b2 100644
--- a/free-identifier-tree-equal.rkt
+++ b/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)
- (define rec=? free-id-tree=?)
+;; Contract:
+;; 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"
- a))]))
+ [else (equal? a b)]))
-(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)
diff --git a/graph-info.hl.rkt b/graph-info.hl.rkt
index 6a6c450..b4514b9 100644
--- a/graph-info.hl.rkt
+++ b/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
- {~literal gen:custom-write}
- _)
- (~maybe #:property
- {~literal prop:custom-print-quotable}
- _)))
- {~optional {~and prefab #:prefab}})
+ (~seq (~or {~seq #:methods _ _}
+ {~seq #:property _ _})
+ ...)))
#:with name/c (format-id #'name "~a/c" #'name)
;(quasisyntax/loc (stx-car this-syntax)
; #,
(template
- (begin
- (struct name (?? parent) (field ...)
- (?? transparent)
- methods+props ...
- (?? prefab))
- (define name/c
- (struct/c name
- (?? (?@ parent-contract ...))
- contract ...))
- (module+ test
- (require rackunit)
- (check-pred flat-contract? name/c))
- (provide name/c
- (contract-out (struct (?? (name parent) name)
- ((?? (?@ [parent-field parent-contract]
- ...))
- [field contract]
- ...)))))))
+ (begin
+ (struct name (?? parent) (field ...)
+ (?? transparent)
+ methods+props ...)
+ (define name/c
+ (struct/c name
+ (?? (?@ parent-contract ...))
+ contract ...))
+ (module+ test
+ (require rackunit)
+ (check-pred flat-contract? name/c))
+ (provide name/c
+ (contract-out (struct (?? (name parent) name)
+ ((?? (?@ [parent-field parent-contract]
+ ...))
+ [field contract]
+ ...)))))))
;<hash-set/c>
<printer>
diff --git a/test/test-graph-type.rkt b/test/test-graph-type.rkt
index fef0e84..c35060d 100644
--- a/test/test-graph-type.rkt
+++ b/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
- (require (for-syntax racket/pretty))
- (define-syntax (debg _stx)
- (parameterize ([pretty-print-columns 188])
- (pretty-print (syntax-local-value #'g1)))
- #'(void))
- (debg))
\ No newline at end of file
+(module* test racket/base
+ (require (for-syntax racket/pretty)
+ (submod ".."))
+ (eval #'(begin
+ (define-syntax (dbg _stx)
+ (parameterize ([pretty-print-columns 188])
+ (pretty-print (syntax-local-value #'g1)))
+ #'(void))
+ (dbg))))
\ No newline at end of file