Add support for warning-only refactoring rules

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)))
 

cli.rkt

@@ -300,18 +300,20 @@ For help on these, use 'analyze --help' or 'fix --help'."
     (match (resyntax-analyze-options-output-format options)
       [(== plain-text)
        (for ([result (in-list results)])
-         (define path
-           (file-source-path
-            (syntax-replacement-source (refactoring-result-syntax-replacement result))))
+         (define source (refactoring-result-source result))
+         (define path (file-source-path source))
          (define line (refactoring-result-original-line result))
          (define column (refactoring-result-original-column result))
          (printf "resyntax: ~a:~a:~a [~a]\n" path line column (refactoring-result-rule-name result))
          (printf "\n\n~a\n" (string-indent (refactoring-result-message result) #:amount 2))
          (define old-code (refactoring-result-original-code result))
          (define new-code (refactoring-result-new-code result))
-         (printf "\n\n~a\n\n\n~a\n\n\n"
-                 (string-indent (~a old-code) #:amount 2)
-                 (string-indent (~a new-code) #:amount 2)))]
+         (if new-code
+             (printf "\n\n~a\n\n\n~a\n\n\n"
+                     (string-indent (~a old-code) #:amount 2)
+                     (string-indent (~a new-code) #:amount 2))
+             (printf "\n\n~a\n\n\n"
+                     (string-indent (~a old-code) #:amount 2))))]
       [(== github-pull-request-review)
        (define req (refactoring-results->github-review results #:file-count (hash-count sources)))
        (write-json (github-review-request-jsexpr req))]))

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)]

private/github.rkt

@@ -93,11 +93,14 @@
 
 
 (define (refactoring-result->github-review-comment result)
-  (define path
-    (file-source-path (syntax-replacement-source (refactoring-result-syntax-replacement result))))
-  (define replacement (refactoring-result-line-replacement result))
-  (define body
-    (format #<<EOS
+  (cond
+    [(refactoring-result-has-fix? result)
+     ;; For results with fixes, generate a suggestion comment
+     (define path
+       (file-source-path (syntax-replacement-source (refactoring-result-syntax-replacement result))))
+     (define replacement (refactoring-result-line-replacement result))
+     (define body
+       (format #<<EOS
 **`~a`:** ~a
 
 ```suggestion
@@ -124,19 +127,35 @@
 </details>
 </details>
 EOS
-            (refactoring-result-rule-name result)
-            (refactoring-result-message result)
-            (line-replacement-new-text replacement)
-            (string-indent (pretty-format replacement) #:amount 2)
-            (string-indent (pretty-format (refactoring-result-syntax-replacement result))
-                           #:amount 2)))
-  (github-review-comment
-   #:path (first (git-path path))
-   #:body body
-   #:start-line (line-replacement-start-line replacement)
-   #:end-line (line-replacement-original-end-line replacement)
-   #:start-side "RIGHT"
-   #:end-side "RIGHT"))
+               (refactoring-result-rule-name result)
+               (refactoring-result-message result)
+               (line-replacement-new-text replacement)
+               (string-indent (pretty-format replacement) #:amount 2)
+               (string-indent (pretty-format (refactoring-result-syntax-replacement result))
+                              #:amount 2)))
+     (github-review-comment
+      #:path (first (git-path path))
+      #:body body
+      #:start-line (line-replacement-start-line replacement)
+      #:end-line (line-replacement-original-end-line replacement)
+      #:start-side "RIGHT"
+      #:end-side "RIGHT")]
+    [else
+     ;; For warning-only results, generate a comment without a suggestion
+     (define source (refactoring-result-source result))
+     (define path (file-source-path source))
+     (define line (refactoring-result-original-line result))
+     (define body
+       (format "**`~a`:** ~a"
+               (refactoring-result-rule-name result)
+               (refactoring-result-message result)))
+     (github-review-comment
+      #:path (first (git-path path))
+      #:body body
+      #:start-line line
+      #:end-line line
+      #:start-side "RIGHT"
+      #:end-side "RIGHT")]))
 
 
 (define branch-ref (getenv "GITHUB_REF"))