Skip to content

Commit a2a1778

Browse files
Copilotjackfirth
Copilot
and
jackfirth
committed
Add basic suppression functionality with tests
Co-authored-by: jackfirth <[email protected]>
1 parent 638e1e8 commit a2a1778

File tree

3 files changed

+161
-51
lines changed

3 files changed

+161
-51
lines changed

‎base.rkt‎

Lines changed: 67 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -8,6 +8,7 @@
88
~replacement
99
~splicing-replacement
1010
~focus-replacement-on
11+
resyntax-suppress
1112
define-refactoring-suite
1213
define-refactoring-rule
1314
define-definition-context-refactoring-rule
@@ -23,7 +24,8 @@
2324
#:name (or/c interned-symbol? #false))
2425
refactoring-suite?)]
2526
[refactoring-suite-rules (-> refactoring-suite? (listof refactoring-rule?))]
26-
[refactoring-suite-analyzers (-> refactoring-suite? (set/c expansion-analyzer?))]))
27+
[refactoring-suite-analyzers (-> refactoring-suite? (set/c expansion-analyzer?))]
28+
[syntax-suppresses-rule? (-> syntax? symbol? boolean?)]))
2729

2830

2931
(module+ private
@@ -108,6 +110,70 @@
108110
[(_ new-stx) (syntax-property #'new-stx 'focus-replacement-on #true)]))
109111

110112

113+
;; Suppression support
114+
(define-syntax (resyntax-suppress stx)
115+
(syntax-parse stx
116+
[(_ rule-id:id body:expr ...+)
117+
(define rule-symbol (syntax-e #'rule-id))
118+
;; Helper to add suppression property to syntax with preservation
119+
(define (add-suppression s)
120+
(define existing (syntax-property s 'resyntax-suppressed-rules))
121+
(syntax-property s 'resyntax-suppressed-rules
122+
(cons rule-symbol (or existing '()))
123+
#true)) ; #true means preserve during expansion
124+
;; Recursively add suppression to all syntax objects in the tree
125+
(define (propagate-suppression s)
126+
(cond
127+
[(syntax? s)
128+
(define updated (add-suppression s))
129+
(define datum (syntax-e updated))
130+
(cond
131+
[(pair? datum)
132+
(datum->syntax updated
133+
(cons (propagate-suppression (car datum))
134+
(propagate-suppression (cdr datum)))
135+
updated
136+
updated)]
137+
[(vector? datum)
138+
(datum->syntax updated
139+
(for/vector ([elem (in-vector datum)])
140+
(propagate-suppression elem))
141+
updated
142+
updated)]
143+
[(box? datum)
144+
(datum->syntax updated
145+
(box (propagate-suppression (unbox datum)))
146+
updated
147+
updated)]
148+
[(prefab-struct-key datum)
149+
(datum->syntax updated
150+
(apply make-prefab-struct
151+
(prefab-struct-key datum)
152+
(map propagate-suppression (cdr (vector->list (struct->vector datum)))))
153+
updated
154+
updated)]
155+
[else updated])]
156+
[(pair? s)
157+
(cons (propagate-suppression (car s))
158+
(propagate-suppression (cdr s)))]
159+
[(vector? s)
160+
(for/vector ([elem (in-vector s)])
161+
(propagate-suppression elem))]
162+
[(box? s)
163+
(box (propagate-suppression (unbox s)))]
164+
[else s]))
165+
;; Apply to all body expressions
166+
(define suppressed-bodies
167+
(for/list ([b (in-list (attribute body))])
168+
(propagate-suppression b)))
169+
;; Don't add suppression to the begin form itself, just return it
170+
#`(begin #,@suppressed-bodies)]))
171+
172+
(define (syntax-suppresses-rule? stx rule-name)
173+
(define suppressed-rules (syntax-property stx 'resyntax-suppressed-rules))
174+
(and suppressed-rules (member rule-name suppressed-rules) #t))
175+
176+
111177
(define-object-type refactoring-rule (transformer description uses-universal-tagged-syntax? analyzers)
112178
#:omit-root-binding
113179
#:constructor-name constructor:refactoring-rule)

‎main.rkt‎

Lines changed: 54 additions & 50 deletions
Original file line numberDiff line numberDiff line change
@@ -374,56 +374,60 @@
374374
(define (refactoring-rules-refactor rules syntax #:comments comments #:analysis analysis)
375375

376376
(define (refactor rule)
377-
(with-handlers
378-
([exn:fail?
379-
(λ (e)
380-
(log-resyntax-error "~a: refactoring attempt failed\n syntax:\n ~a\n cause:\n~a"
381-
(object-name rule)
382-
syntax
383-
(string-indent (exn-message e) #:amount 3))
384-
absent)])
385-
(guarded-block
386-
(guard-match (present replacement)
387-
(parameterize ([current-namespace (source-code-analysis-namespace analysis)])
388-
(refactoring-rule-refactor rule syntax (source-code-analysis-code analysis)))
389-
#:else absent)
390-
(guard (syntax-replacement-introduces-incorrect-bindings? replacement) #:else
391-
(define bad-ids (syntax-replacement-introduced-incorrect-identifiers replacement))
392-
(define orig-stx (syntax-replacement-original-syntax replacement))
393-
(define intro (syntax-replacement-introduction-scope replacement))
394-
(log-resyntax-warning
395-
(string-append
396-
"~a: suggestion discarded because it introduces identifiers with incorrect bindings\n"
397-
" incorrect identifiers: ~a\n"
398-
" bindings in original context: ~a\n"
399-
" bindings in syntax replacement: ~a\n"
400-
" replaced syntax: ~a")
401-
(object-name rule)
402-
bad-ids
403-
(for/list ([id (in-list bad-ids)])
404-
(identifier-binding (datum->syntax orig-stx (syntax->datum id))))
405-
(for/list ([id (in-list bad-ids)])
406-
(identifier-binding (intro id 'remove)))
407-
orig-stx)
408-
absent)
409-
(guard (syntax-replacement-preserves-comments? replacement comments) #:else
410-
(log-resyntax-warning
411-
(string-append "~a: suggestion discarded because it does not preserve all comments\n"
412-
" dropped comment locations: ~v\n"
413-
" original syntax:\n"
414-
" ~v\n"
415-
" replacement syntax:\n"
416-
" ~v")
417-
(object-name rule)
418-
(syntax-replacement-dropped-comment-locations replacement comments)
419-
(syntax-replacement-original-syntax replacement)
420-
(syntax-replacement-new-syntax replacement))
421-
absent)
422-
(present
423-
(refactoring-result
424-
#:rule-name (object-name rule)
425-
#:message (refactoring-rule-description rule)
426-
#:syntax-replacement replacement)))))
377+
(define rule-name (object-name rule))
378+
;; Check if this rule is suppressed for this syntax
379+
(if (syntax-suppresses-rule? syntax rule-name)
380+
absent
381+
(with-handlers
382+
([exn:fail?
383+
(λ (e)
384+
(log-resyntax-error "~a: refactoring attempt failed\n syntax:\n ~a\n cause:\n~a"
385+
rule-name
386+
syntax
387+
(string-indent (exn-message e) #:amount 3))
388+
absent)])
389+
(guarded-block
390+
(guard-match (present replacement)
391+
(parameterize ([current-namespace (source-code-analysis-namespace analysis)])
392+
(refactoring-rule-refactor rule syntax (source-code-analysis-code analysis)))
393+
#:else absent)
394+
(guard (syntax-replacement-introduces-incorrect-bindings? replacement) #:else
395+
(define bad-ids (syntax-replacement-introduced-incorrect-identifiers replacement))
396+
(define orig-stx (syntax-replacement-original-syntax replacement))
397+
(define intro (syntax-replacement-introduction-scope replacement))
398+
(log-resyntax-warning
399+
(string-append
400+
"~a: suggestion discarded because it introduces identifiers with incorrect bindings\n"
401+
" incorrect identifiers: ~a\n"
402+
" bindings in original context: ~a\n"
403+
" bindings in syntax replacement: ~a\n"
404+
" replaced syntax: ~a")
405+
rule-name
406+
bad-ids
407+
(for/list ([id (in-list bad-ids)])
408+
(identifier-binding (datum->syntax orig-stx (syntax->datum id))))
409+
(for/list ([id (in-list bad-ids)])
410+
(identifier-binding (intro id 'remove)))
411+
orig-stx)
412+
absent)
413+
(guard (syntax-replacement-preserves-comments? replacement comments) #:else
414+
(log-resyntax-warning
415+
(string-append "~a: suggestion discarded because it does not preserve all comments\n"
416+
" dropped comment locations: ~v\n"
417+
" original syntax:\n"
418+
" ~v\n"
419+
" replacement syntax:\n"
420+
" ~v")
421+
rule-name
422+
(syntax-replacement-dropped-comment-locations replacement comments)
423+
(syntax-replacement-original-syntax replacement)
424+
(syntax-replacement-new-syntax replacement))
425+
absent)
426+
(present
427+
(refactoring-result
428+
#:rule-name rule-name
429+
#:message (refactoring-rule-description rule)
430+
#:syntax-replacement replacement))))))
427431

428432
(falsey->option
429433
(for*/first ([rule (in-list rules)]

‎test/suppression-test.rkt‎

Lines changed: 40 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,40 @@
1+
#lang resyntax/test
2+
3+
4+
require: resyntax/default-recommendations boolean-shortcuts
5+
6+
7+
header:
8+
------------------------------
9+
#lang racket/base
10+
(require resyntax/base)
11+
------------------------------
12+
13+
14+
no-change-test: "suppressing a rule prevents its application"
15+
------------------------------
16+
(resyntax-suppress nested-and-to-flat-and
17+
(and 1 (and 2 3)))
18+
------------------------------
19+
20+
21+
no-change-test: "suppressed nested or is not refactored"
22+
------------------------------
23+
(resyntax-suppress nested-or-to-flat-or
24+
(or 1 (or 2 3)))
25+
------------------------------
26+
27+
28+
test: "unsuppressed nested or is refactored normally"
29+
- (or 1 (or 2 3))
30+
- (or 1 2 3)
31+
32+
33+
test: "suppression is specific to the rule name"
34+
------------------------------
35+
(resyntax-suppress nested-or-to-flat-or
36+
(and 1 (and 2 3)))
37+
==============================
38+
(resyntax-suppress nested-or-to-flat-or
39+
(and 1 2 3))
40+
------------------------------

0 commit comments

Comments
 (0)