diff --git a/flexible-with-utils.hl.rkt b/flexible-with-utils.hl.rkt index aa5162d..ae0f3e7 100644 --- a/flexible-with-utils.hl.rkt +++ b/flexible-with-utils.hl.rkt @@ -38,21 +38,20 @@ @defproc[(to-bits [n exact-nonnegative-integer?]) (listof boolean?)]{} @CHUNK[ - ; 1 => 1 - ; 2 3 => 10 11 - ;4 5 6 7 => 100 101 110 111 - ;89 ab cd ef => 1000 1001 1010 1011 1100 1101 1110 1111 + ;; 1 => 1 + ;; 2 3 => 10 11 + ;; 4 5 6 7 => 100 101 110 111 + ;; 89 ab cd ef => 1000 1001 1010 1011 1100 1101 1110 1111 - ; 1 => "" - ; 2 3 => 0 1 - ;4 5 6 7 => 00 01 10 11 - ;89 ab cd ef => 000 001 010 011 100 101 110 111 - - ; 0 => 0 - ; 1 2 => 1 10 - ;3 4 5 6 => 11 100 101 110 - ;78 9a bc de => 111 1000 1001 1010 1011 1100 1101 1110 + ;; 1 => ε + ;; 2 3 => 0 1 + ;; 4 5 6 7 => 00 01 10 11 + ;; 89 ab cd ef => 000 001 010 011 100 101 110 111 + ;; 0 => 0 + ;; 1 2 => 1 10 + ;; 3 4 5 6 => 11 100 101 110 + ;; 78 9a bc de => 111 1000 1001 1010 1011 1100 1101 1110 (define-for-syntax (to-bits n) (reverse diff --git a/flexible-with.hl.rkt b/flexible-with.hl.rkt index 9ca5e05..8d64c23 100644 --- a/flexible-with.hl.rkt +++ b/flexible-with.hl.rkt @@ -317,7 +317,8 @@ interesting subparts of the trees (those where there are fields). #`(begin (define-type-expander bt-fields-id (bt-fields-type #'#,(syntax-local-introduce #'(field …)))) - #,@(map #λ(define-replace-in-tree low-names names rm-names ∀-types % (floor-log2 %)) + #,@(map #λ(define-replace-in-tree low-names + names rm-names ∀-types % (floor-log2 %)) (range 1 (add1 total-nb-functions))) #;#,@(map #λ(define-remove-in-tree rm-names ∀-types % (floor-log2 %)) (range 1 (add1 total-nb-functions))) diff --git a/free-identifier-tree-equal.rkt b/free-identifier-tree-equal.rkt index 1eac8b2..7576983 100644 --- a/free-identifier-tree-equal.rkt +++ b/free-identifier-tree-equal.rkt @@ -32,12 +32,13 @@ (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?) + (->* {isyntax/c isyntax/c} + {(-> isyntax/c isyntax/c boolean?)} + boolean?) (define (rec=? a b) (free-id-tree=? a b r)) (cond [(identifier? a) (and (identifier? b) @@ -60,23 +61,28 @@ (and (equal? a-key b-key) (rec=? (struct->list a) (struct->list b)))))] + [(struct? a) + (rec=? (vector->immutable-vector (struct->vector a)))] [(null? a) (null? b)] [else (equal? a b)])) -(define/contract ((free-id-tree-hash hc) a) - (-> (-> any/c fixnum?) (-> isyntax/c fixnum?)) +(define/contract ((free-id-tree-hash default-hc) a [hc default-hc]) + (-> (-> any/c fixnum?) (-> isyntax/c (-> isyntax/c fixnum?) 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 (map rec-hash (vector->list a))))] + [(vector? a) (hc (vector->immutable-vector + (list->vector (map rec-hash (vector->list a)))))] [(box? a) (hc (box (rec-hash (unbox a))))] [(prefab-struct-key a) => (λ (a-key) (hc (apply make-prefab-struct a-key (rec-hash (struct->list a)))))] + [(struct? a) + (rec-hash (vector->immutable-vector (struct->vector a)))] [else (hc a)])) (define free-id-tree-hash-code diff --git a/graph-info.hl.rkt b/graph-info.hl.rkt index 06f5589..7e25039 100644 --- a/graph-info.hl.rkt +++ b/graph-info.hl.rkt @@ -178,15 +178,15 @@ A field has a type. [(define write-proc (struct-printer 'invariant-info))] #: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))))])] + ||)] + +Instances of @racket[invariant-info] are compared pointwise with +@racket[free-id-tree=?]: + +@chunk[|| + [(define equal-proc free-id-tree=?) + (define hash-proc free-id-tree-hash-code) + (define hash2-proc free-id-tree-secondary-hash-code)]] @section{Dependent invariant information} @@ -203,15 +203,10 @@ which relate the old and the new graph in a graph transformation. [(define write-proc (struct-printer 'dependent-invariant-info))] #: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))))])] + ||)] + +Instances of @racket[dependent-invariant-info] are compared pointwise with +@racket[free-id-tree=?], like @racket[invariant-info]. @section{Mapping information} @@ -314,8 +309,6 @@ data. {~seq #:property _ _}) ...))) #:with name/c (format-id #'name "~a/c" #'name) - ;(quasisyntax/loc (stx-car this-syntax) - ; #, (template (begin (struct name (?? parent) (field ...) @@ -335,7 +328,6 @@ data. [field contract] ...))))))) - ; diff --git a/traversal.hl.rkt b/traversal.hl.rkt index 99f577d..01eff8e 100644 --- a/traversal.hl.rkt +++ b/traversal.hl.rkt @@ -310,14 +310,19 @@ not expressed syntactically using the @racket[Foo] identifier. @CHUNK[ [(List X Y …) - #'(let*-values ([(result-x acc-x) ((!replace-in-instance X . rec-args) - (car v) - acc)] - [(result-y* acc-y*) ((!replace-in-instance (List Y …) . rec-args) - (cdr v) - acc-x)]) + #'(let*-values ([(result-x acc-x) ] + [(result-y* acc-y*) ]) (values (cons result-x result-y*) acc-y*))]] +where the replacement is applied to the @racket[car], and to the @racket[cdr] +as a whole (i.e. by recursion on the whole remaining list of types): + +@chunk[ + ((!replace-in-instance X . rec-args) (car v) acc)] + +@chunk[ + ((!replace-in-instance (List Y …) . rec-args) (cdr v) acc-x)] + @CHUNK[ [(U _Xⱼ …) #'(U (!replace-in-type _Xⱼ . rec-args) …)]]