Add #:suggested-fixes option to refactoring rules and support warning-only results

Co-authored-by: jackfirth <[email protected]>

Author: Copilot

base.rkt

@@ -15,6 +15,7 @@
   [refactoring-rule? (-> any/c boolean?)]
   [refactoring-rule-description (-> refactoring-rule? immutable-string?)]
   [refactoring-rule-analyzers (-> refactoring-rule? (set/c expansion-analyzer?))]
+  [refactoring-rule-suggested-fixes (-> refactoring-rule? (or/c 'none 'one))]
   [refactoring-suite? (-> any/c boolean?)]
   [refactoring-suite
    (->* ()
@@ -108,7 +109,7 @@
     [(_ new-stx) (syntax-property #'new-stx 'focus-replacement-on #true)]))
 
 
-(define-object-type refactoring-rule (transformer description uses-universal-tagged-syntax? analyzers)
+(define-object-type refactoring-rule (transformer description uses-universal-tagged-syntax? analyzers suggested-fixes)
   #:omit-root-binding
   #:constructor-name constructor:refactoring-rule)
 
@@ -140,12 +141,14 @@
     #:description description
     (~optional (~seq #:uses-universal-tagged-syntax? uses-universal-tagged-syntax?))
     (~optional (~seq #:analyzers analyzers))
+    (~optional (~seq #:suggested-fixes suggested-fixes))
     parse-option:syntax-parse-option ...
     pattern
     pattern-directive:syntax-parse-pattern-directive ...
     replacement)
   #:declare description (expr/c #'string?)
   #:declare analyzers (expr/c #'(sequence/c expansion-analyzer?))
+  #:declare suggested-fixes (expr/c #'(or/c 'none 'one))
 
   #:attr partial-match-log-statement
   (and (not (empty? (attribute pattern-directive)))
@@ -162,6 +165,7 @@
      #:description (string->immutable-string description.c)
      #:uses-universal-tagged-syntax? (~? uses-universal-tagged-syntax? #false)
      #:analyzers (for/set ([analyzer (~? analyzers.c '())]) analyzer)
+     #:suggested-fixes (~? suggested-fixes.c 'one)
      #:transformer
      (λ (stx)
        (syntax-parse stx
@@ -176,6 +180,7 @@
   (define-definition-context-refactoring-rule id:id
     #:description (~var description (expr/c #'string?))
     (~optional (~seq #:analyzers (~var analyzers (expr/c #'(sequence/c expansion-analyzer?)))))
+    (~optional (~seq #:suggested-fixes (~var suggested-fixes (expr/c #'(or/c 'none 'one)))))
     parse-option:syntax-parse-option ...
     splicing-pattern
     pattern-directive:syntax-parse-pattern-directive ...
@@ -229,6 +234,7 @@
     (define-refactoring-rule id
       #:description description
       (~? (~@ #:analyzers analyzers))
+      (~? (~@ #:suggested-fixes suggested-fixes))
       (~var expression expression-matching-id)
       expression.refactored)))
 

main.rkt

@@ -382,48 +382,65 @@
                                 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)))))
+      ;; Check if this is a warning-only rule
+      (cond
+        [(eq? (refactoring-rule-suggested-fixes rule) 'none)
+         ;; For warning-only rules, try to match the pattern
+         (define match-result
+           (parameterize ([current-namespace (source-code-analysis-namespace analysis)])
+             (refactoring-rule-refactor rule syntax (source-code-analysis-code analysis))))
+         ;; If pattern matched, create a warning result
+         (option-map match-result
+                     (λ (_)
+                       (warning-result
+                        #:rule-name (object-name rule)
+                        #:message (refactoring-rule-description rule)
+                        #:source (source-code-analysis-code analysis)
+                        #:original-syntax syntax)))]
+        [else
+         ;; For rules with fixes, validate and create a regular refactoring result
+         (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)))])))
 
   (falsey->option
    (for*/first ([rule (in-list rules)]