Add comment-only-test statement for testing warning-only rules

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

Author: Copilot

test-warning-suite.rkt

@@ -0,0 +1,16 @@
+#lang racket/base
+
+(require resyntax/base)
+
+(provide test-warning-suite)
+
+;; Define a warning-only rule that matches any (equal? x y)
+(define-refactoring-rule test-warning-rule
+  #:description "Test warning rule for equal?"
+  #:suggested-fixes 'none
+  #:literals (equal?)
+  (equal? x y)
+  (void))
+
+(define test-warning-suite
+  (refactoring-suite #:rules (list test-warning-rule)))

test.rkt

@@ -8,7 +8,8 @@
          header
          test
          no-change-test
-         analysis-test)
+         analysis-test
+         comment-only-test)
 
 
 (require (for-syntax racket/base
@@ -228,6 +229,25 @@
                                       'expected-value)))]))))
 
 
+(define-syntax comment-only-test
+  (statement-transformer
+   (λ (stx)
+     (syntax-parse stx
+       #:track-literals
+       #:datum-literals (option @within @inspect @assertMatch)
+       [(#:statement _ name:str
+         code:literal-code
+         (~seq (#:option #:within context-block:literal-code) ...
+               (#:option #:inspect target-block:literal-code)
+               (#:option #:assertMatch rule-name:id)))
+        #`(test-case 'name
+            #,(syntax/loc this-syntax
+                (check-suite-comment-only code
+                                          (list context-block ...)
+                                          target-block
+                                          'rule-name)))]))))
+
+
 ;; Helper function to check if any require: statements are present
 (begin-for-syntax
   (define (has-require-statements? body-stxs)
@@ -400,7 +420,7 @@
 
   (define (add-uts-properties stx)
     (syntax-traverse stx
-      #:datum-literals (require header test no-change-test analysis-test)
+      #:datum-literals (require header test no-change-test analysis-test comment-only-test)
 
       [:id
        (define as-string (symbol->string (syntax-e this-syntax)))
@@ -425,7 +445,7 @@
                (add-uts-properties (attribute code))))
        (datum->syntax #false new-datum this-syntax this-syntax)]
 
-      [((~and tag #:statement) (~and test-id (~or test no-change-test analysis-test)) arg ...)
+      [((~and tag #:statement) (~and test-id (~or test no-change-test analysis-test comment-only-test)) arg ...)
        (define separators (append (list "" ": " "\n") (make-list (length (attribute arg)) "")))
        (define tag-with-prop (syntax-property (attribute tag) 'uts-separators separators))
        (define new-datum

test/comment-only-test-demo.rkt

@@ -0,0 +1,15 @@
+#lang resyntax/test
+
+
+require: resyntax/test-warning-suite test-warning-suite
+
+
+comment-only-test: "warning-only rule should produce a comment"
+--------------------
+#lang racket/base
+
+(define a 5)
+(equal? a a)
+--------------------
+@inspect - (equal? a a)
+@assertMatch test-warning-rule

test/private/rackunit.rkt

@@ -12,7 +12,8 @@
          add-suite-under-test!
          check-suite-refactors
          check-suite-does-not-refactor
-         check-suite-analysis)
+         check-suite-analysis
+         check-suite-comment-only)
 
 
 (require racket/logging
@@ -312,6 +313,47 @@
       (fail-check "analysis assigned an incorrect value for the given syntax property key"))))
 
 
+(define-check (check-suite-comment-only program context-list target rule-name)
+  (define suite (current-suite-under-test))
+  (set! program (code-block-append (current-header) program))
+  (define program-src (string-source (code-block-raw-string program)))
+  (define-values (call-with-logs-captured build-logs-info) (make-log-capture-utilities))
+
+  (define result-set
+    (call-with-logs-captured
+     (λ () (resyntax-analyze program-src
+                            #:suite suite
+                            #:timeout-ms (current-analyzer-timeout-millis)))))
+
+  (define results (refactoring-result-set-results result-set))
+
+  ;; Find target location
+  (define target-src (string-source (string-trim (code-block-raw-string target))))
+  (define context-src-list
+    (for/list ([ctx (in-list context-list)])
+      (string-source (string-trim (code-block-raw-string ctx)))))
+
+  ;; Try to find a result that matches the target location and rule name
+  (define matching-results
+    (for/list ([result (in-list results)]
+               #:when (and (equal? (refactoring-result-rule-name result) rule-name)
+                          (not (refactoring-result-has-fix? result))))
+      result))
+
+  (with-check-info (['logs (build-logs-info)]
+                    ['program (string-block-info (string-source-contents program-src))]
+                    ['target (string-block-info (string-source-contents target-src))]
+                    ['rule-name rule-name])
+    (when (empty? matching-results)
+      (fail-check "no warning-only result found for the specified rule"))
+    
+    (when (> (length matching-results) 1)
+      (fail-check (format "found ~a warning-only results, expected exactly 1" (length matching-results))))
+    
+    ;; Success - we found exactly one matching warning-only result
+    (void)))
+
+
 (define (source-find-path-of src target-src #:contexts [context-srcs '()])
   (define stx (syntax-label-paths (source-read-syntax src) 'source-path))
   (define target-as-string (string-source-contents target-src))