Preserve metadata during syntax traversal (#489)

Author: jackfirth

default-recommendations/match-shortcuts-test.rkt

@@ -170,3 +170,31 @@ test: "match patterns using ? with a lambda cannot be simplified when under elli
      (list y*)]
     [_ 'no-match]))
 ------------------------------
+
+test: "match patterns using ? with a commented lambda can be simplified with #:when clauses"
+------------------------------
+(define (foo x)
+  (match x
+    [(? (λ (y) (< y
+                  10
+                  ; comment
+                  20)) y*)
+     (list y*)]
+    [_ 'no-match]))
+(foo 5)
+(foo 100)
+------------------------------
+------------------------------
+(define (foo x)
+  (match x
+    [y*
+     #:when (< y*
+               10
+               ; comment
+               20)
+     (list y*)]
+    [_ 'no-match]))
+(foo 5)
+(foo 100)
+------------------------------
+

private/syntax-replacement.rkt

@@ -32,6 +32,7 @@
          racket/match
          racket/pretty
          racket/sequence
+         racket/stream
          racket/string
          rebellion/base/comparator
          rebellion/collection/range-set
@@ -42,6 +43,7 @@
          resyntax/private/string-indent
          resyntax/private/string-replacement
          resyntax/private/syntax-neighbors
+         (only-in resyntax/private/syntax-traversal syntax-search-everything)
          syntax/parse
          syntax/parse/experimental/template
          (only-in rebellion/base/range closed-open-range)
@@ -71,7 +73,7 @@
     (guard (or focused? (not (syntax-property stx 'focus-replacement-on))) #:else
       (log-resyntax-debug "focusing in on ~a" stx)
       (list (focus (pieces stx #:focused? #true))))
-    (guard (not (syntax-original? stx)) #:else
+    (guard (not (syntax-completely-original? stx)) #:else
       (log-resyntax-debug "copying original syntax ~a" stx)
       (define start (sub1 (syntax-position stx)))
       (define end (+ start (syntax-span stx)))
@@ -298,3 +300,8 @@
 (define (syntax-source-range stx)
   (define start (sub1 (syntax-position stx)))
   (closed-open-range start (+ start (syntax-span stx)) #:comparator natural<=>))
+
+
+(define (syntax-completely-original? stx)
+  (for/and ([subform (in-stream (syntax-search-everything stx))])
+    (syntax-original? subform)))

private/syntax-traversal.rkt

@@ -8,13 +8,12 @@
          expression-directly-enclosing
          syntax-find-first
          syntax-search
+         syntax-search-everything
          syntax-traverse)
 
 
 (require (for-syntax racket/base
-                     resyntax/private/more-syntax-parse-classes
-                     syntax/parse)
-         racket/match
+                     resyntax/private/more-syntax-parse-classes)
          racket/sequence
          racket/stream
          syntax/parse
@@ -55,33 +54,43 @@
 
 
 (define-syntax-parse-rule
-  (syntax-search stx-expr option:syntax-parse-option ... clause:syntax-search-clause ...)
+  (syntax-search stx-expr
+    (~optional (~seq #:skip-root? skip-root?) #:defaults ([skip-root? #'#false]))
+    option:syntax-parse-option ...
+    clause:syntax-search-clause ...)
   #:declare stx-expr (expr/c #'syntax?)
-  (let ()
+  (let ([skip-root-id skip-root?])
     (define-syntax-class search-case
       #:attributes (output-stream)
       (~@ . option) ...
       (pattern clause.syntax-pattern (~@ . clause.directive) ...
         #:attr output-stream clause.output-stream)
       ...)
-    (let loop ([stx stx-expr.c])
+    (let loop ([stx stx-expr.c] [root? #true])
       (stream-lazy
        (syntax-parse stx
-         [(~var matched search-case) (attribute matched.output-stream)]
+         [child
+          #:when (not (and skip-root-id root?))
+          #:with (~var matched search-case) (attribute child)
+          (attribute matched.output-stream)]
          [(part (... ...))
           #:cut
           (apply stream-append
                  (for/list ([part-stx (in-list (attribute part))])
-                   (loop part-stx)))]
+                   (loop part-stx #false)))]
          [(part (... ...+) . tail-part)
           #:cut
           (stream-append (apply stream-append
                                 (for/list ([part-stx (in-list (attribute part))])
-                                  (loop part-stx)))
-                         (loop #'tail-part))]
+                                  (loop part-stx #false)))
+                         (loop #'tail-part #false))]
          [_ (stream)])))))
 
 
+(define (syntax-search-everything stx)
+  (stream-cons stx (syntax-search stx #:skip-root? #true [_ (syntax-search-everything this-syntax)])))
+
+
 (module+ test
   (test-case "syntax-search"
     (define stx
@@ -100,9 +109,9 @@
 
 
 (define-syntax-parse-rule (syntax-find-first stx-expr
-                                             option:syntax-parse-option ...
-                                             syntax-pattern
-                                             directive:syntax-parse-pattern-directive ...)
+                            option:syntax-parse-option ...
+                            syntax-pattern
+                            directive:syntax-parse-pattern-directive ...)
   (let ()
     (define results (syntax-search stx-expr (~@ . option) ... [syntax-pattern (~@ . directive) ...]))
     (and (not (stream-empty? results)) (stream-first results))))
@@ -123,27 +132,40 @@
 
 (define-syntax-parse-rule
   (syntax-traverse (~var stx-expr (expr/c #'syntax?))
+    (~optional (~seq #:skip-root? skip-root?) #:defaults ([skip-root? #'#false]))
     option:syntax-parse-option ...
     [clause-pattern directive:syntax-parse-pattern-directive ... clause-body:expr ...+] ...)
-  (let ()
+  (let ([skip-root-id skip-root?])
     (define-syntax-class traversal-case
       #:attributes (traversed)
       (~@ . option) ...
       (pattern clause-pattern (~@ . directive) ...
         #:attr traversed (let () clause-body ...)) ...)
-    (let loop ([stx stx-expr.c])
+    (let loop ([stx stx-expr.c] [root? #true])
+
+      (define (rewrap-datum datum)
+        (datum->syntax stx datum stx stx))
+
       (syntax-parse stx
-        [(~var matched traversal-case) (attribute matched.traversed)]
+
+        [child
+         #:when (not (and skip-root-id root?))
+         #:with (~var matched traversal-case) (attribute child)
+         (define case-scope (make-syntax-introducer))
+         (case-scope (attribute matched.traversed) 'add)]
 
         [(part (... ...))
          #:cut
-         #:with (traversed-part (... ...)) (map loop (attribute part))
-         #'(traversed-part (... ...))]
+         (rewrap-datum
+          (for/list ([child (in-list (attribute part))])
+            (loop child #false)))]
         [(part (... ...+) . tail-part)
          #:cut
-         #:with (traversed-part (... ...)) (map loop (attribute part))
-         #:with traversed-tail (loop #'tail-part)
-         #'(traversed-part (... ...) . traversed-tail)]
+         (define traversed-children
+           (for/list ([child (in-list (attribute part))])
+             (loop child #false)))
+         (define traversed-tail (loop #'tail-part #false))
+         (rewrap-datum (append traversed-children traversed-tail))]
         [_ stx]))))
 
 
@@ -156,14 +178,54 @@
             (cons a b))
           (cons c d)))
     (define actual
-      (syntax->datum
-       (syntax-traverse stx
-         #:literals (cons)
-         [(cons _ _) #'CONS-EXPRESSION])))
+      (syntax-traverse stx
+        #:literals (cons)
+        [(cons _ _) #'CONS-EXPRESSION]))
     (define expected
       '(define (foo)
          CONS-EXPRESSION
          (define (bar)
            CONS-EXPRESSION)
          CONS-EXPRESSION))
-    (check-equal? actual expected)))
+    (check-equal? (syntax->datum actual) expected))
+
+  (test-case "syntax-traverse #:skip-root? true"
+    (define stx #'(a b (c d) e))
+    (define actual
+      (syntax-traverse stx
+        #:skip-root? #true
+        [(_ ...) #'LIST]))
+    (check-equal? (syntax->datum actual) '(a b LIST e)))
+
+  (test-case "syntax-traverse #:skip-root? true doesn't execute directives on root"
+    (define stx #'(a b (c d) e))
+    (define execution-count 0)
+    (syntax-traverse stx
+      #:skip-root? #true
+      [(_ ...)
+       #:do [(set! execution-count (add1 execution-count))]
+       #'LIST])
+    (check-equal? execution-count 1))
+
+  (test-case "syntax-traverse #:skip-root? false"
+    (define stx #'(a b (c d) e))
+    (define actual
+      (syntax-traverse stx
+        #:skip-root? #false
+        [(_ ...) #'LIST]))
+    (check-equal? (syntax->datum actual) 'LIST))
+
+  (test-case "syntax-traverse originality"
+    (define stx (read-syntax #false (open-input-string "(1 2 (a b) 3 4)")))
+    (check-true (syntax-original? stx))
+    (define traversed-stx
+      (syntax-traverse stx
+        [(_ id:id) (attribute id)]))
+    (check-equal? (syntax->datum traversed-stx) '(1 2 b 3 4))
+    (check-true (syntax-original? traversed-stx))
+    (define/syntax-parse (1* 2* b* 3* 4*) traversed-stx)
+    (check-true (syntax-original? #'1*))
+    (check-true (syntax-original? #'2*))
+    (check-false (syntax-original? #'b*))
+    (check-true (syntax-original? #'3*))
+    (check-true (syntax-original? #'4*))))