commit 9814513b479407e4dffb8e18a71fc8d20b164bd8
parent 72261decc4f6a59293d0a82b441a9caf6433ae1d
Author: Georges Dupéron <georges.duperon@gmail.com>
Date: Mon, 6 Feb 2017 06:55:29 +0100
More cleanup
Diffstat:
5 files changed, 51 insertions(+), 48 deletions(-)
diff --git 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[<to-bits>
- ; 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 => 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
(define-for-syntax (to-bits n)
(reverse
diff --git 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
@@ -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
@@ -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))))])]
+ |<gen:equal+hash free-id-tree=?>|)]
+
+Instances of @racket[invariant-info] are compared pointwise with
+@racket[free-id-tree=?]:
+
+@chunk[|<gen:equal+hash free-id-tree=?>|
+ [(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))))])]
+ |<gen:equal+hash free-id-tree=?>|)]
+
+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]
...)))))))
- ;<hash-set/c>
<printer>
<field-info>
diff --git a/traversal.hl.rkt b/traversal.hl.rkt
@@ -310,14 +310,19 @@ not expressed syntactically using the @racket[Foo] identifier.
@CHUNK[<f-cases>
[(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) <f-list-car>]
+ [(result-y* acc-y*) <f-list-cdr>])
(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[<f-list-car>
+ ((!replace-in-instance X . rec-args) (car v) acc)]
+
+@chunk[<f-list-cdr>
+ ((!replace-in-instance (List Y …) . rec-args) (cdr v) acc-x)]
+
@CHUNK[<type-cases>
[(U _Xⱼ …)
#'(U (!replace-in-type _Xⱼ . rec-args) …)]]
