suzanne.soy/phc-graph
1
0
Fork 0
Code Issues 24 Pull Requests Actions Packages Projects Releases Wiki Activity

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

Browse Source
This commit is contained in:
Georges Dupéron 2017-01-20 16:04:40 +01:00
parent d2f93d9ae6
commit 4589fdff69
3 changed files with 84 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

37
free-identifier-tree-equal.rkt
View File

@ -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)

70
graph-info.hl.rkt
View File

@ -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>

18
test/test-graph-type.rkt
View File

@ -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))
(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))))