#177

Committed 04 Nov 2025 01:14AM UTC coverage: 92.881% (-0.03%) from 92.914%

Build # #177

Build Type

Pull #712

cover

Committed by

Copilot

Commit Message

Document how to extend expander property preservation

Add a comment explaining how to add new expander properties to the
preservation list when needed.

Co-authored-by: jackfirth <8175575+jackfirth@users.noreply.github.com>

Pull Request Pull Request #712: Store visited paths instead of syntaxes in source-code-analysis

Run Details

30 of 31 new or added lines in 1 file covered. (96.77%)

10 existing lines in 1 file now uncovered.

14664 of 15788 relevant lines covered (92.88%)

0.93 hits per line

Source File
Press 'n' to go to next uncovered line, 'b' for previous

87.63

/private/syntax-property-bundle.rkt

#lang racket/base


(require racket/contract/base)


(provide
 (struct-out syntax-property-entry)
 (contract-out
  [syntax-property-bundle (-> syntax-property-entry? ... syntax-property-bundle?)]
  [syntax-property-bundle? (-> any/c boolean?)]
  [syntax-property-bundle-as-map (-> syntax-property-bundle? immutable-sorted-map?)]
  [syntax-property-bundle-entries (-> syntax-property-bundle? (sequence/c syntax-property-entry?))]
  [syntax-property-bundle-get-property
   (->* (syntax-property-bundle? syntax-path? any/c) (failure-result/c) any/c)]
  [syntax-property-bundle-get-immediate-properties
   (-> syntax-property-bundle? syntax-path? immutable-hash?)]
  [syntax-property-bundle-get-all-properties
   (-> syntax-property-bundle? syntax-path? syntax-property-bundle?)]
  [sequence->syntax-property-bundle (-> (sequence/c syntax-property-entry?) syntax-property-bundle?)]
  [into-syntax-property-bundle (reducer/c syntax-property-entry? syntax-property-bundle?)]
  [property-hashes-into-syntax-property-bundle
   (reducer/c (entry/c syntax-path? immutable-hash?) syntax-property-bundle?)]
  [syntax-add-all-properties (-> syntax? syntax-property-bundle? syntax?)]))


(require guard
         racket/match
         racket/mutability
         racket/sequence
         racket/stream
         rebellion/base/range
         rebellion/collection/entry
         (except-in rebellion/collection/hash mutable-hash? immutable-hash?)
         rebellion/collection/sorted-map
         rebellion/streaming/reducer
         rebellion/streaming/transducer
         resyntax/private/syntax-path)


(module+ test
  (require (submod "..")
           rackunit
           syntax/parse))


;@----------------------------------------------------------------------------------------------------


(struct syntax-property-bundle (as-map)
  #:omit-define-syntaxes
  #:constructor-name constructor:syntax-property-bundle
  #:transparent)

(struct syntax-property-entry (path key value)
  #:guard (struct-guard/c syntax-path? any/c any/c)
  #:transparent)


(define into-syntax-property-bundle
  (into-transduced
   (mapping
    (λ (prop-entry)
      (match-define (syntax-property-entry path k v) prop-entry)
      (entry path (entry k v))))
   (grouping into-hash)
   #:into (reducer-map (into-sorted-map syntax-path<=>) #:range constructor:syntax-property-bundle)))


(define property-hashes-into-syntax-property-bundle
  (into-transduced
   (filtering-values (λ (prop-hash) (not (hash-empty? prop-hash))))
   #:into (reducer-map (into-sorted-map syntax-path<=>) #:range constructor:syntax-property-bundle)))


(define (sequence->syntax-property-bundle prop-entry-seq)
  (transduce prop-entry-seq #:into into-syntax-property-bundle))


(define (syntax-property-bundle . prop-entries)
  (sequence->syntax-property-bundle prop-entries))


(module+ test
  (define term-01-quoted-prop (syntax-property-entry (syntax-path (list 0 1)) 'quoted? #true))
  (define term-02-quoted-prop (syntax-property-entry (syntax-path (list 0 2)) 'quoted? #true))
  (define term-03-quoted-prop (syntax-property-entry (syntax-path (list 0 3)) 'quoted? #true))
  (test-case "syntax-property-bundle"
    (define actual
      (syntax-property-bundle term-01-quoted-prop term-02-quoted-prop term-03-quoted-prop))
    (define expected
      (constructor:syntax-property-bundle
       (sorted-map #:key-comparator syntax-path<=>
                   (syntax-path (list 0 1)) (hash 'quoted? #true)
                   (syntax-path (list 0 2)) (hash 'quoted? #true)
                   (syntax-path (list 0 3)) (hash 'quoted? #true))))
    (check-equal? actual expected))

  (test-case "sequence->syntax-property-bundle"
    (define actual
      (sequence->syntax-property-bundle
       (list term-03-quoted-prop term-01-quoted-prop term-02-quoted-prop)))
    (define expected
      (syntax-property-bundle term-01-quoted-prop term-02-quoted-prop term-03-quoted-prop))
    (check-equal? actual expected))

  (test-case "into-syntax-property-bundle"
    (define actual
      (transduce (vector term-01-quoted-prop term-02-quoted-prop term-03-quoted-prop)
                 #:into into-syntax-property-bundle))
    (define expected
      (syntax-property-bundle term-01-quoted-prop term-02-quoted-prop term-03-quoted-prop))
    (check-equal? actual expected))

  (test-case "property-hashes-into-syntax-property-bundle"
    (define prop-hashes
      (list (entry (syntax-path (list 0 1)) (hash 'foo 1))
                       (entry (syntax-path (list 0 2)) (hash 'bar 2 'baz 3))
                       (entry (syntax-path (list 0 3)) (hash))))

    (define actual (transduce prop-hashes #:into property-hashes-into-syntax-property-bundle))

    (define expected
      (syntax-property-bundle
       (syntax-property-entry (syntax-path (list 0 1)) 'foo 1)
       (syntax-property-entry (syntax-path (list 0 2)) 'bar 2)
       (syntax-property-entry (syntax-path (list 0 2)) 'baz 3)))
    (check-equal? actual expected)))


(define (syntax-property-bundle-get-property prop-bundle path key [failure-result #false])
  (define props-at-path (sorted-map-get (syntax-property-bundle-as-map prop-bundle) path (hash)))

  (define (fail)
    (raise-arguments-error
     'syntax-property-bundle-get-property
     "no property value for given key at given path"
     "path" path
     "property key" key
     "properties at path" props-at-path))

  (hash-ref props-at-path key (or failure-result fail)))


(module+ test
  (test-case "syntax-property-bundle-get-property"

    (test-case "bundle has entry for key and path"
      (define path (syntax-path (list 1 2 3)))
      (define props (syntax-property-bundle (syntax-property-entry path 'foo 42)))
      (check-equal? (syntax-property-bundle-get-property props path 'foo) 42))

    (test-case "empty bundle"
      (define path (syntax-path (list 1 2 3)))

      (define thrown
        (with-handlers ([any/c values])
          (syntax-property-bundle-get-property (syntax-property-bundle) path 'foo)
          #false))

      (check-pred exn:fail:contract? thrown)
      (check-regexp-match #rx"syntax-property-bundle-get-property:" (exn-message thrown))
      (check-regexp-match #rx"path:" (exn-message thrown))
      (check-regexp-match #rx"property key: 'foo" (exn-message thrown))
      (check-regexp-match #rx"properties at path: '#hash()" (exn-message thrown)))

    (test-case "empty bundle with failure value provided"
      (define path (syntax-path (list 1 2 3)))
      (define actual (syntax-property-bundle-get-property (syntax-property-bundle) path 'foo 42))
      (check-equal? actual 42))

    (test-case "empty bundle with failure thunk provided"
      (define path (syntax-path (list 1 2 3)))
      (define actual
        (syntax-property-bundle-get-property (syntax-property-bundle) path 'foo (λ () 42)))
      (check-equal? actual 42))))


(define (syntax-property-bundle-get-immediate-properties prop-bundle path)
  (sorted-map-get (syntax-property-bundle-as-map prop-bundle) path (hash)))


(module+ test
  (test-case "syntax-property-bundle-get-immediate-properties"

    (test-case "bundle has entry for path"
      (define path (syntax-path (list 1 2 3)))
      (define props
        (syntax-property-bundle
         (syntax-property-entry path 'foo 42)
         (syntax-property-entry path 'bar #true)
         (syntax-property-entry path 'baz #false)))

      (define actual (syntax-property-bundle-get-immediate-properties props path))

      (check-equal? actual (hash 'foo 42 'bar #true 'baz #false)))

    (test-case "empty bundle"
      (define path (syntax-path (list 1 2 3)))
      (define actual (syntax-property-bundle-get-immediate-properties (syntax-property-bundle) path))
      (check-equal? actual (hash)))))


(define/guard (syntax-property-bundle-get-all-properties prop-bundle path)
  (guard (nonempty-syntax-path? path) #:else prop-bundle)
  (define next-neighbor (syntax-path-next-neighbor path))
  (define path-range
    (if next-neighbor
        (closed-open-range path next-neighbor #:comparator syntax-path<=>)
        (at-least-range path)))
  (define submap (sorted-submap (syntax-property-bundle-as-map prop-bundle) path-range))
  (define new-map
    (transduce (in-sorted-map submap)
               (mapping-keys (λ (submap-path) (syntax-path-remove-prefix submap-path path)))
               #:into (into-sorted-map syntax-path<=>)))
  (constructor:syntax-property-bundle new-map))


(module+ test
  (test-case "syntax-property-bundle-get-all-properties"
    (void)))


(define (syntax-property-bundle-entries prop-bundle)
  (for*/stream ([e (in-sorted-map (syntax-property-bundle-as-map prop-bundle))]
                #:do [(match-define (entry path props) e)]
                [(k v) (in-hash props)])
    (syntax-property-entry path k v)))


(define (syntax-add-all-properties stx prop-bundle)
  (for/fold ([stx stx])
            ([e (in-sorted-map (syntax-property-bundle-as-map prop-bundle))])
    (match-define (entry path props) e)
    (syntax-add-properties-at stx path props)))


(define (syntax-add-properties-at stx path props)
  (define old-subform (syntax-ref stx path))
  (define new-subform
    (for/fold ([subform old-subform])
              ([(k v) (in-hash props)])
      (syntax-property subform k v)))
  (syntax-set stx path new-subform))


(module+ test
  (test-case "syntax-add-all-properties"
    (define stx #'(a (b c) d))
    (define props
      (syntax-property-bundle
       (syntax-property-entry empty-syntax-path 'size 3)
       (syntax-property-entry (syntax-path (list 0)) 'headphone-shaped? #false)
       (syntax-property-entry (syntax-path (list 1)) 'size 2)
       (syntax-property-entry (syntax-path (list 1 0)) 'headphone-shaped? #true)
       (syntax-property-entry (syntax-path (list 1 1)) 'headphone-shaped? #false)
       (syntax-property-entry (syntax-path (list 2)) 'headphone-shaped? #true)))

    (define stx-with-props (syntax-add-all-properties stx props))

    (check-equal? (syntax-property stx-with-props 'size) 3)
    (define/syntax-parse (a* bc* d*) stx-with-props)
    (check-equal? (syntax-property #'a* 'headphone-shaped?) #false)
    (check-equal? (syntax-property #'bc* 'size) 2)
    (check-equal? (syntax-property #'d* 'headphone-shaped?) #true)
    (define/syntax-parse (b* c*) #'bc*)
    (check-equal? (syntax-property #'b* 'headphone-shaped?) #true)
    (check-equal? (syntax-property #'c* 'headphone-shaped?) #false)))

1	#lang racket/base	1✔
2
3
4	(require racket/contract/base)	1✔
5
6
7	(provide	1✔
8	(struct-out syntax-property-entry)	1✔
9	(contract-out	1✔
10	[syntax-property-bundle (-> syntax-property-entry? ... syntax-property-bundle?)]	1✔
11	[syntax-property-bundle? (-> any/c boolean?)]	1✔
12	[syntax-property-bundle-as-map (-> syntax-property-bundle? immutable-sorted-map?)]	1✔
13	[syntax-property-bundle-entries (-> syntax-property-bundle? (sequence/c syntax-property-entry?))]	1✔
14	[syntax-property-bundle-get-property	1✔
15	(->* (syntax-property-bundle? syntax-path? any/c) (failure-result/c) any/c)]	1✔
16	[syntax-property-bundle-get-immediate-properties	1✔
17	(-> syntax-property-bundle? syntax-path? immutable-hash?)]	1✔
18	[syntax-property-bundle-get-all-properties	1✔
19	(-> syntax-property-bundle? syntax-path? syntax-property-bundle?)]	1✔
20	[sequence->syntax-property-bundle (-> (sequence/c syntax-property-entry?) syntax-property-bundle?)]	1✔
21	[into-syntax-property-bundle (reducer/c syntax-property-entry? syntax-property-bundle?)]	1✔
22	[property-hashes-into-syntax-property-bundle	1✔
23	(reducer/c (entry/c syntax-path? immutable-hash?) syntax-property-bundle?)]	1✔
24	[syntax-add-all-properties (-> syntax? syntax-property-bundle? syntax?)]))	1✔
25
26
27	(require guard	1✔
28	racket/match	1✔
29	racket/mutability	1✔
30	racket/sequence	1✔
31	racket/stream	1✔
32	rebellion/base/range	1✔
33	rebellion/collection/entry	1✔
34	(except-in rebellion/collection/hash mutable-hash? immutable-hash?)	1✔
35	rebellion/collection/sorted-map	1✔
36	rebellion/streaming/reducer	1✔
37	rebellion/streaming/transducer	1✔
38	resyntax/private/syntax-path)	1✔
39
40
41	(module+ test
42	(require (submod "..")
43	rackunit
44	syntax/parse))
45
46
47	;@----------------------------------------------------------------------------------------------------
48
49
50	(struct syntax-property-bundle (as-map)	1✔
51	#:omit-define-syntaxes	1✔
52	#:constructor-name constructor:syntax-property-bundle	1✔
53	#:transparent)	1✔
54
55	(struct syntax-property-entry (path key value)	1✔
56	#:guard (struct-guard/c syntax-path? any/c any/c)	1✔
57	#:transparent)	1✔
58
59
60	(define into-syntax-property-bundle	1✔
61	(into-transduced	1✔
62	(mapping	1✔
63	(λ (prop-entry)	1✔
64	(match-define (syntax-property-entry path k v) prop-entry)	1✔
65	(entry path (entry k v))))	1✔
66	(grouping into-hash)	1✔
67	#:into (reducer-map (into-sorted-map syntax-path<=>) #:range constructor:syntax-property-bundle)))	1✔
68
69
70	(define property-hashes-into-syntax-property-bundle	1✔
71	(into-transduced	1✔
72	(filtering-values (λ (prop-hash) (not (hash-empty? prop-hash))))	1✔
73	#:into (reducer-map (into-sorted-map syntax-path<=>) #:range constructor:syntax-property-bundle)))	1✔
74
75
76	(define (sequence->syntax-property-bundle prop-entry-seq)	1✔
77	(transduce prop-entry-seq #:into into-syntax-property-bundle))	1✔
78
79
80	(define (syntax-property-bundle . prop-entries)	1✔
81	(sequence->syntax-property-bundle prop-entries))	1✔
82
83
84	(module+ test
85	(define term-01-quoted-prop (syntax-property-entry (syntax-path (list 0 1)) 'quoted? #true))
86	(define term-02-quoted-prop (syntax-property-entry (syntax-path (list 0 2)) 'quoted? #true))
87	(define term-03-quoted-prop (syntax-property-entry (syntax-path (list 0 3)) 'quoted? #true))
88	(test-case "syntax-property-bundle"
89	(define actual
90	(syntax-property-bundle term-01-quoted-prop term-02-quoted-prop term-03-quoted-prop))
91	(define expected
92	(constructor:syntax-property-bundle
93	(sorted-map #:key-comparator syntax-path<=>
94	(syntax-path (list 0 1)) (hash 'quoted? #true)
95	(syntax-path (list 0 2)) (hash 'quoted? #true)
96	(syntax-path (list 0 3)) (hash 'quoted? #true))))
97	(check-equal? actual expected))
98
99	(test-case "sequence->syntax-property-bundle"
100	(define actual
101	(sequence->syntax-property-bundle
102	(list term-03-quoted-prop term-01-quoted-prop term-02-quoted-prop)))
103	(define expected
104	(syntax-property-bundle term-01-quoted-prop term-02-quoted-prop term-03-quoted-prop))
105	(check-equal? actual expected))
106
107	(test-case "into-syntax-property-bundle"
108	(define actual
109	(transduce (vector term-01-quoted-prop term-02-quoted-prop term-03-quoted-prop)
110	#:into into-syntax-property-bundle))
111	(define expected
112	(syntax-property-bundle term-01-quoted-prop term-02-quoted-prop term-03-quoted-prop))
113	(check-equal? actual expected))
114
115	(test-case "property-hashes-into-syntax-property-bundle"
116	(define prop-hashes
117	(list (entry (syntax-path (list 0 1)) (hash 'foo 1))
118	(entry (syntax-path (list 0 2)) (hash 'bar 2 'baz 3))
119	(entry (syntax-path (list 0 3)) (hash))))
120
121	(define actual (transduce prop-hashes #:into property-hashes-into-syntax-property-bundle))
122
123	(define expected
124	(syntax-property-bundle
125	(syntax-property-entry (syntax-path (list 0 1)) 'foo 1)
126	(syntax-property-entry (syntax-path (list 0 2)) 'bar 2)
127	(syntax-property-entry (syntax-path (list 0 2)) 'baz 3)))
128	(check-equal? actual expected)))
129
130
131	(define (syntax-property-bundle-get-property prop-bundle path key [failure-result #false])	1✔
132	(define props-at-path (sorted-map-get (syntax-property-bundle-as-map prop-bundle) path (hash)))	1✔
133
134	(define (fail)	1✔
135	(raise-arguments-error	1✔
136	'syntax-property-bundle-get-property	1✔
137	"no property value for given key at given path"	1✔
138	"path" path	1✔
139	"property key" key	1✔
140	"properties at path" props-at-path))	1✔
141
142	(hash-ref props-at-path key (or failure-result fail)))	1✔
143
144
145	(module+ test
146	(test-case "syntax-property-bundle-get-property"
147
148	(test-case "bundle has entry for key and path"
149	(define path (syntax-path (list 1 2 3)))
150	(define props (syntax-property-bundle (syntax-property-entry path 'foo 42)))
151	(check-equal? (syntax-property-bundle-get-property props path 'foo) 42))
152
153	(test-case "empty bundle"
154	(define path (syntax-path (list 1 2 3)))
155
156	(define thrown
157	(with-handlers ([any/c values])
158	(syntax-property-bundle-get-property (syntax-property-bundle) path 'foo)
159	#false))
160
161	(check-pred exn:fail:contract? thrown)
162	(check-regexp-match #rx"syntax-property-bundle-get-property:" (exn-message thrown))
163	(check-regexp-match #rx"path:" (exn-message thrown))
164	(check-regexp-match #rx"property key: 'foo" (exn-message thrown))
165	(check-regexp-match #rx"properties at path: '#hash()" (exn-message thrown)))
166
167	(test-case "empty bundle with failure value provided"
168	(define path (syntax-path (list 1 2 3)))
169	(define actual (syntax-property-bundle-get-property (syntax-property-bundle) path 'foo 42))
170	(check-equal? actual 42))
171
172	(test-case "empty bundle with failure thunk provided"
173	(define path (syntax-path (list 1 2 3)))
174	(define actual
175	(syntax-property-bundle-get-property (syntax-property-bundle) path 'foo (λ () 42)))
176	(check-equal? actual 42))))
177
178
179	(define (syntax-property-bundle-get-immediate-properties prop-bundle path)	1✔
180	(sorted-map-get (syntax-property-bundle-as-map prop-bundle) path (hash)))	1✔
181
182
183	(module+ test
184	(test-case "syntax-property-bundle-get-immediate-properties"
185
186	(test-case "bundle has entry for path"
187	(define path (syntax-path (list 1 2 3)))
188	(define props
189	(syntax-property-bundle
190	(syntax-property-entry path 'foo 42)
191	(syntax-property-entry path 'bar #true)
192	(syntax-property-entry path 'baz #false)))
193
194	(define actual (syntax-property-bundle-get-immediate-properties props path))
195
196	(check-equal? actual (hash 'foo 42 'bar #true 'baz #false)))
197
198	(test-case "empty bundle"
199	(define path (syntax-path (list 1 2 3)))
200	(define actual (syntax-property-bundle-get-immediate-properties (syntax-property-bundle) path))
201	(check-equal? actual (hash)))))
202
203
204	(define/guard (syntax-property-bundle-get-all-properties prop-bundle path)	1✔
205	(guard (nonempty-syntax-path? path) #:else prop-bundle)	×
UNCOV 206	(define next-neighbor (syntax-path-next-neighbor path))	×
UNCOV 207	(define path-range	×
UNCOV 208	(if next-neighbor	×
UNCOV 209	(closed-open-range path next-neighbor #:comparator syntax-path<=>)	×
210	(at-least-range path)))	×
UNCOV 211	(define submap (sorted-submap (syntax-property-bundle-as-map prop-bundle) path-range))	×
UNCOV 212	(define new-map	×
UNCOV 213	(transduce (in-sorted-map submap)	×
UNCOV 214	(mapping-keys (λ (submap-path) (syntax-path-remove-prefix submap-path path)))	×
UNCOV 215	#:into (into-sorted-map syntax-path<=>)))	×
UNCOV 216	(constructor:syntax-property-bundle new-map))	×
217
218
219	(module+ test
220	(test-case "syntax-property-bundle-get-all-properties"
221	(void)))
222
223
224	(define (syntax-property-bundle-entries prop-bundle)	1✔
225	(for*/stream ([e (in-sorted-map (syntax-property-bundle-as-map prop-bundle))]	1✔
226	#:do [(match-define (entry path props) e)]	1✔
227	[(k v) (in-hash props)])	1✔
228	(syntax-property-entry path k v)))	1✔
229
230
231	(define (syntax-add-all-properties stx prop-bundle)	1✔
232	(for/fold ([stx stx])	1✔
233	([e (in-sorted-map (syntax-property-bundle-as-map prop-bundle))])	1✔
234	(match-define (entry path props) e)	1✔
235	(syntax-add-properties-at stx path props)))	1✔
236
237
238	(define (syntax-add-properties-at stx path props)	1✔
239	(define old-subform (syntax-ref stx path))	1✔
240	(define new-subform	1✔
241	(for/fold ([subform old-subform])	1✔
242	([(k v) (in-hash props)])	1✔
243	(syntax-property subform k v)))	1✔
244	(syntax-set stx path new-subform))	1✔
245
246
247	(module+ test
248	(test-case "syntax-add-all-properties"
249	(define stx #'(a (b c) d))
250	(define props
251	(syntax-property-bundle
252	(syntax-property-entry empty-syntax-path 'size 3)
253	(syntax-property-entry (syntax-path (list 0)) 'headphone-shaped? #false)
254	(syntax-property-entry (syntax-path (list 1)) 'size 2)
255	(syntax-property-entry (syntax-path (list 1 0)) 'headphone-shaped? #true)
256	(syntax-property-entry (syntax-path (list 1 1)) 'headphone-shaped? #false)
257	(syntax-property-entry (syntax-path (list 2)) 'headphone-shaped? #true)))
258
259	(define stx-with-props (syntax-add-all-properties stx props))
260
261	(check-equal? (syntax-property stx-with-props 'size) 3)
262	(define/syntax-parse (a* bc* d*) stx-with-props)
263	(check-equal? (syntax-property #'a* 'headphone-shaped?) #false)
264	(check-equal? (syntax-property #'bc* 'size) 2)
265	(check-equal? (syntax-property #'d* 'headphone-shaped?) #true)
266	(define/syntax-parse (b* c) #'bc)
267	(check-equal? (syntax-property #'b* 'headphone-shaped?) #true)
268	(check-equal? (syntax-property #'c* 'headphone-shaped?) #false)))

jackfirth / resyntax / #177

Source File Press 'n' to go to next uncovered line, 'b' for previous

Source File
Press 'n' to go to next uncovered line, 'b' for previous