Fix implementation with binding check bypass

Author: jackfirth

default-recommendations/syntax-parse-shortcuts.rkt

@@ -9,8 +9,11 @@
   [syntax-parse-shortcuts refactoring-suite?]))
 
 
-(require rebellion/private/static-name
+(require (for-syntax racket/base
+                     syntax/parse)
+         rebellion/private/static-name
          resyntax/base
+         resyntax/private/more-syntax-parse-classes
          resyntax/private/syntax-traversal
          racket/stream
          syntax/parse
@@ -24,48 +27,22 @@
   #:description
   "This `define-syntax` macro with a single `syntax-parse` clause can be replaced with a simpler,
 equivalent `define-syntax-parse-rule` macro."
-  #:literals (define-syntax lambda)
+  #:literals (define-syntax lambda [syntax-parse syntax-parse #:phase 1] [syntax-id syntax #:phase 1])
 
   (define-syntax macro:id
-    (lambda (stx-var:id)
-      (syntax-parse-id:id parsed-stx:id
-        [(_ . pattern) body ...])))
+    (lambda (stx-id:id)
+      (syntax-parse stx-id2:id
+        [(_ pattern ...) directive:syntax-parse-pattern-directive ... (syntax-id last-form)])))
 
-  #:do [(define stx-id (attribute stx-var))
-        ;; Check if stx-var is referenced in the body using syntax-search
-        (define body-has-stx-ref?
-          (for/or ([body-part (in-list (attribute body))])
-            (not (stream-empty? 
-                  (syntax-search body-part
-                    [id:id #:when (free-identifier=? #'id stx-id)
-                     (stream this-syntax)])))))
-        ;; Replace references to stx-var with this-syntax and strip syntax wrapper
-        (define (replace-stx-with-this-syntax stx)
-          (syntax-parse stx
-            [id:id #:when (free-identifier=? #'id stx-id)
-             (datum->syntax #'here 'this-syntax stx)]
-            [(a . b)
-             (datum->syntax stx
-                            (cons (replace-stx-with-this-syntax #'a)
-                                  (replace-stx-with-this-syntax #'b))
-                            stx
-                            stx)]
-            [other #'other]))
-        (define (strip-syntax-wrapper stx)
-          (syntax-parse stx
-            #:literals (syntax)
-            [(syntax body) #'body]
-            [other #'other]))
-        (define new-body
-          (for/list ([body-part (in-list (attribute body))])
-            (strip-syntax-wrapper (replace-stx-with-this-syntax body-part))))]
-  
-  #:with (new-body-part ...) new-body
-  
-  #:when (and (free-identifier=? (attribute stx-var) (attribute parsed-stx))
-              (equal? (syntax-e (attribute syntax-parse-id)) 'syntax-parse))
+  #:when (free-identifier=? (attribute stx-id) (attribute stx-id2) 1)
+
+  #:with (new-body ...)
+  (syntax-traverse #'((~@ . directive) ... last-form)
+    [id-in-body:id
+     #:when (free-identifier=? (attribute id-in-body) (attribute stx-id) 1)
+     (syntax-property #'this-syntax 'skip-incorrect-binding-check? #true)])
 
-  (define-syntax-parse-rule (macro . pattern) new-body-part ...))
+  (define-syntax-parse-rule (macro pattern ...) new-body ...))
 
 
 (define-refactoring-rule define-syntax-parser-to-define-syntax-parse-rule-simple

private/syntax-replacement.rkt

@@ -360,7 +360,9 @@
     ;; Without the fix, the formatter would allow the code to exceed the line length limit.
     ;; With the fix, the formatter either keeps it on one line within the limit, or breaks it
     ;; across multiple lines if it cannot fit.
-    (define orig-line "      [`(,(and (or '+ '- '* '/ 'and 'or) op) ,as ..2 ,b) `(,op ,(loop `(,op ,@as) env) ,(loop b env))]")
+    (define orig-line
+      (string-append "      [`(,(and (or '+ '- '* '/ 'and 'or) op) ,as ..2 ,b)"
+                     " `(,op ,(loop `(,op ,@as) env) ,(loop b env))]"))
     (check-equal? (string-length orig-line) 102 "Original line should be 102 characters")
 
     ;; The quasiquote expression starts at position 57 and ends at position 101
@@ -370,9 +372,10 @@
     (define quasiquote-end 101) ; just before the final ]
 
     (define replacement
-      (string-replacement #:start quasiquote-start
-                          #:end quasiquote-end
-                          #:contents (list (inserted-string "(list op (loop `(,op ,@as) env) (loop b env))"))))
+      (string-replacement
+       #:start quasiquote-start
+       #:end quasiquote-end
+       #:contents (list (inserted-string "(list op (loop `(,op ,@as) env) (loop b env))"))))
 
     ;; Test with Racket's standard line width of 102
     (parameterize ([current-width 102])
@@ -383,7 +386,8 @@
       ;; If it's multi-line, each line should not exceed 102 characters
       (for ([line (in-list (string-split result "\n"))])
         (check-true (<= (string-length line) 102)
-                    (format "Line exceeds length limit: ~a chars (should be <= 102)" (string-length line)))))))
+                    (format "Line exceeds length limit: ~a chars (should be <= 102)"
+                            (string-length line)))))))
 
 
 (define (syntax-replacement-introduces-incorrect-bindings? replacement)
@@ -392,7 +396,8 @@
                                     #:introduction-scope intro)
     replacement)
   (for/and ([new-id (in-syntax-identifiers new)]
-            #:unless (bound-identifier=? new-id (intro new-id 'remove)))
+            #:unless (bound-identifier=? new-id (intro new-id 'remove))
+            #:unless (syntax-property new-id 'skip-incorrect-binding-check?))
     (free-identifier=? new-id (datum->syntax orig (syntax->datum new-id)))))
 
 
@@ -403,7 +408,8 @@
     replacement)
   (for/list ([new-id (in-syntax-identifiers new)]
              #:unless (bound-identifier=? new-id (intro new-id 'remove))
-             #:unless (free-identifier=? new-id (datum->syntax orig (syntax->datum new-id))))
+             #:unless (free-identifier=? new-id (datum->syntax orig (syntax->datum new-id)))
+             #:unless (syntax-property new-id 'skip-incorrect-binding-check?))
     new-id))