Add targeted rule suppression with resyntax-suppress

base.rkt

@@ -8,6 +8,7 @@
  ~replacement
  ~splicing-replacement
  ~focus-replacement-on
+ resyntax-suppress
  define-refactoring-suite
  define-refactoring-rule
  define-definition-context-refactoring-rule
@@ -23,7 +24,8 @@
          #:name (or/c interned-symbol? #false))
         refactoring-suite?)]
   [refactoring-suite-rules (-> refactoring-suite? (listof refactoring-rule?))]
-  [refactoring-suite-analyzers (-> refactoring-suite? (set/c expansion-analyzer?))]))
+  [refactoring-suite-analyzers (-> refactoring-suite? (set/c expansion-analyzer?))]
+  [syntax-suppresses-rule? (-> syntax? symbol? boolean?)]))
 
 
 (module+ private
@@ -108,6 +110,70 @@
     [(_ new-stx) (syntax-property #'new-stx 'focus-replacement-on #true)]))
 
 
+;; Suppression support
+(define-syntax (resyntax-suppress stx)
+  (syntax-parse stx
+    [(_ rule-id:id body:expr ...+)
+     (define rule-symbol (syntax-e #'rule-id))
+     ;; Helper to add suppression property to syntax with preservation
+     (define (add-suppression s)
+       (define existing (syntax-property s 'resyntax-suppressed-rules))
+       (syntax-property s 'resyntax-suppressed-rules
+                        (cons rule-symbol (or existing '()))
+                        #true)) ; #true means preserve during expansion
+     ;; Recursively add suppression to all syntax objects in the tree
+     (define (propagate-suppression s)
+       (cond
+         [(syntax? s)
+          (define updated (add-suppression s))
+          (define datum (syntax-e updated))
+          (cond
+            [(pair? datum)
+             (datum->syntax updated
+                            (cons (propagate-suppression (car datum))
+                                  (propagate-suppression (cdr datum)))
+                            updated
+                            updated)]
+            [(vector? datum)
+             (datum->syntax updated
+                            (for/vector ([elem (in-vector datum)])
+                              (propagate-suppression elem))
+                            updated
+                            updated)]
+            [(box? datum)
+             (datum->syntax updated
+                            (box (propagate-suppression (unbox datum)))
+                            updated
+                            updated)]
+            [(prefab-struct-key datum)
+             (datum->syntax updated
+                            (apply make-prefab-struct
+                                   (prefab-struct-key datum)
+                                   (map propagate-suppression (cdr (vector->list (struct->vector datum)))))
+                            updated
+                            updated)]
+            [else updated])]
+         [(pair? s)
+          (cons (propagate-suppression (car s))
+                (propagate-suppression (cdr s)))]
+         [(vector? s)
+          (for/vector ([elem (in-vector s)])
+            (propagate-suppression elem))]
+         [(box? s)
+          (box (propagate-suppression (unbox s)))]
+         [else s]))
+     ;; Apply to all body expressions
+     (define suppressed-bodies
+       (for/list ([b (in-list (attribute body))])
+         (propagate-suppression b)))
+     ;; Don't add suppression to the begin form itself, just return it
+     #`(begin #,@suppressed-bodies)]))
+
+(define (syntax-suppresses-rule? stx rule-name)
+  (define suppressed-rules (syntax-property stx 'resyntax-suppressed-rules))
+  (and suppressed-rules (member rule-name suppressed-rules) #t))
+
+
 (define-object-type refactoring-rule (transformer description uses-universal-tagged-syntax? analyzers)
   #:omit-root-binding
   #:constructor-name constructor:refactoring-rule)

main.rkt

@@ -374,56 +374,60 @@
 (define (refactoring-rules-refactor rules syntax #:comments comments #:analysis analysis)
 
   (define (refactor rule)
-    (with-handlers
-        ([exn:fail?
-          (λ (e)
-            (log-resyntax-error "~a: refactoring attempt failed\n  syntax:\n   ~a\n  cause:\n~a"
-                                (object-name rule)
-                                syntax
-                                (string-indent (exn-message e) #:amount 3))
-            absent)])
-      (guarded-block
-        (guard-match (present replacement)
-          (parameterize ([current-namespace (source-code-analysis-namespace analysis)])
-            (refactoring-rule-refactor rule syntax (source-code-analysis-code analysis)))
-          #:else absent)
-        (guard (syntax-replacement-introduces-incorrect-bindings? replacement) #:else
-          (define bad-ids (syntax-replacement-introduced-incorrect-identifiers replacement))
-          (define orig-stx (syntax-replacement-original-syntax replacement))
-          (define intro (syntax-replacement-introduction-scope replacement))
-          (log-resyntax-warning
-           (string-append
-            "~a: suggestion discarded because it introduces identifiers with incorrect bindings\n"
-            "  incorrect identifiers: ~a\n"
-            "  bindings in original context: ~a\n"
-            "  bindings in syntax replacement: ~a\n"
-            "  replaced syntax: ~a")
-           (object-name rule)
-           bad-ids
-           (for/list ([id (in-list bad-ids)])
-             (identifier-binding (datum->syntax orig-stx (syntax->datum id))))
-           (for/list ([id (in-list bad-ids)])
-             (identifier-binding (intro id 'remove)))
-           orig-stx)
-          absent)
-        (guard (syntax-replacement-preserves-comments? replacement comments) #:else
-          (log-resyntax-warning
-           (string-append "~a: suggestion discarded because it does not preserve all comments\n"
-                          "  dropped comment locations: ~v\n"
-                          "  original syntax:\n"
-                          "   ~v\n"
-                          "  replacement syntax:\n"
-                          "   ~v")
-           (object-name rule)
-           (syntax-replacement-dropped-comment-locations replacement comments)
-           (syntax-replacement-original-syntax replacement)
-           (syntax-replacement-new-syntax replacement))
-          absent)
-        (present
-         (refactoring-result
-          #:rule-name (object-name rule)
-          #:message (refactoring-rule-description rule)
-          #:syntax-replacement replacement)))))
+    (define rule-name (object-name rule))
+    ;; Check if this rule is suppressed for this syntax
+    (if (syntax-suppresses-rule? syntax rule-name)
+        absent
+        (with-handlers
+            ([exn:fail?
+              (λ (e)
+                (log-resyntax-error "~a: refactoring attempt failed\n  syntax:\n   ~a\n  cause:\n~a"
+                                    rule-name
+                                    syntax
+                                    (string-indent (exn-message e) #:amount 3))
+                absent)])
+          (guarded-block
+            (guard-match (present replacement)
+              (parameterize ([current-namespace (source-code-analysis-namespace analysis)])
+                (refactoring-rule-refactor rule syntax (source-code-analysis-code analysis)))
+              #:else absent)
+            (guard (syntax-replacement-introduces-incorrect-bindings? replacement) #:else
+              (define bad-ids (syntax-replacement-introduced-incorrect-identifiers replacement))
+              (define orig-stx (syntax-replacement-original-syntax replacement))
+              (define intro (syntax-replacement-introduction-scope replacement))
+              (log-resyntax-warning
+               (string-append
+                "~a: suggestion discarded because it introduces identifiers with incorrect bindings\n"
+                "  incorrect identifiers: ~a\n"
+                "  bindings in original context: ~a\n"
+                "  bindings in syntax replacement: ~a\n"
+                "  replaced syntax: ~a")
+               rule-name
+               bad-ids
+               (for/list ([id (in-list bad-ids)])
+                 (identifier-binding (datum->syntax orig-stx (syntax->datum id))))
+               (for/list ([id (in-list bad-ids)])
+                 (identifier-binding (intro id 'remove)))
+               orig-stx)
+              absent)
+            (guard (syntax-replacement-preserves-comments? replacement comments) #:else
+              (log-resyntax-warning
+               (string-append "~a: suggestion discarded because it does not preserve all comments\n"
+                              "  dropped comment locations: ~v\n"
+                              "  original syntax:\n"
+                              "   ~v\n"
+                              "  replacement syntax:\n"
+                              "   ~v")
+               rule-name
+               (syntax-replacement-dropped-comment-locations replacement comments)
+               (syntax-replacement-original-syntax replacement)
+               (syntax-replacement-new-syntax replacement))
+              absent)
+            (present
+             (refactoring-result
+              #:rule-name rule-name
+              #:message (refactoring-rule-description rule)
+              #:syntax-replacement replacement))))))
 
   (falsey->option
    (for*/first ([rule (in-list rules)]

main.scrbl

@@ -429,6 +429,38 @@ guide Resyntax's internal comment preservation system when the default behavior
  because such rules often touch only a small series of forms in a much larger definition context.}
 
 
+@subsection{Suppressing Specific Suggestions}
+
+@defform[(resyntax-suppress rule-id body ...+)]{
+ Suppresses the application of a specific @tech{refactoring rule} to the code in @racket[body]. The
+ @racket[rule-id] must be the name of a refactoring rule. This form is useful when a refactoring
+ suggestion makes sense generally, but is unhelpful in a specific context.
+
+ For example, suppose you have code that maintains visual symmetry by using similar comparisons with
+ zero:
+
+ @(racketblock
+   (and (= (- x y) 0)
+        (> (- x y) 0)
+        (< (- x y) 0)))
+
+ While Resyntax would normally suggest simplifying @racket[(> (- x y) 0)] to @racket[(> x y)], doing
+ so would break the visual pattern. You can suppress this specific suggestion while still allowing
+ other refactorings:
+
+ @(racketblock
+   (resyntax-suppress comparison-of-difference-and-zero-to-direct-comparison
+     (and (= (- x y) 0)
+          (> (- x y) 0)
+          (< (- x y) 0))))
+
+ The suppression applies to all code within the @racket[body] forms. Multiple expressions can be
+ suppressed together, and suppression works with nested forms.
+
+ Note that @racket[resyntax-suppress] must be @racket[require]d from @racket[resyntax/base] before
+ use.}
+
+
 @subsection{Resyntax's Default Rules}
 @defmodule[resyntax/default-recommendations]
 

test/suppression-comparison-test.rkt

@@ -0,0 +1,35 @@
+#lang resyntax/test
+
+
+require: resyntax/default-recommendations comparison-shortcuts
+
+
+header:
+------------------------------
+#lang racket/base
+(require resyntax/base)
+(define x 1)
+(define y 2)
+------------------------------
+
+
+no-change-test: "suppressing comparison rule prevents refactoring"
+------------------------------
+(resyntax-suppress comparison-of-difference-and-zero-to-direct-comparison
+  (> (- x y) 0))
+------------------------------
+
+
+test: "unsuppressed comparison is refactored"
+- (> (- x y) 0)
+- (> x y)
+
+
+no-change-test: "specific comparison in symmetrical context can be suppressed"
+------------------------------
+;; Example from the issue - maintaining visual symmetry
+(resyntax-suppress comparison-of-difference-and-zero-to-direct-comparison
+  (and (= (- x y) 0)
+       (> (- x y) 0)
+       (< (- x y) 0)))
+------------------------------

test/suppression-test.rkt

@@ -0,0 +1,68 @@
+#lang resyntax/test
+
+
+require: resyntax/default-recommendations boolean-shortcuts
+
+
+header:
+------------------------------
+#lang racket/base
+(require resyntax/base)
+------------------------------
+
+
+no-change-test: "suppressing a rule prevents its application"
+------------------------------
+(resyntax-suppress nested-and-to-flat-and
+  (and 1 (and 2 3)))
+------------------------------
+
+
+no-change-test: "suppressed nested or is not refactored"
+------------------------------
+(resyntax-suppress nested-or-to-flat-or
+  (or 1 (or 2 3)))
+------------------------------
+
+
+test: "unsuppressed nested or is refactored normally"
+- (or 1 (or 2 3))
+- (or 1 2 3)
+
+
+test: "suppression is specific to the rule name"
+------------------------------
+(resyntax-suppress nested-or-to-flat-or
+  (and 1 (and 2 3)))
+==============================
+(resyntax-suppress nested-or-to-flat-or
+  (and 1 2 3))
+------------------------------
+
+
+no-change-test: "multiple expressions can be suppressed in one form"
+------------------------------
+(resyntax-suppress nested-and-to-flat-and
+  (and 1 (and 2 3))
+  (and 4 (and 5 6)))
+------------------------------
+
+
+no-change-test: "suppression works with nested forms"
+------------------------------
+(resyntax-suppress nested-and-to-flat-and
+  (define x (and 1 (and 2 3)))
+  (define y (and 4 (and 5 6))))
+------------------------------
+
+
+test: "suppression outside a form doesn't affect it"
+------------------------------
+(resyntax-suppress nested-and-to-flat-and
+  (define x 1))
+(and 1 (and 2 3))
+==============================
+(resyntax-suppress nested-and-to-flat-and
+  (define x 1))
+(and 1 2 3)
+------------------------------