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] + ...))))))) ; 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