Analysis rework (#488)

Author: jackfirth

default-recommendations/for-loop-shortcuts.rkt

@@ -24,7 +24,8 @@
          resyntax/private/identifier-naming
          resyntax/private/logger
          resyntax/private/syntax-traversal
-         syntax/parse)
+         syntax/parse
+         syntax/parse/define)
 
 
 ;@----------------------------------------------------------------------------------------------------
@@ -408,22 +409,25 @@ return just that result."
       [else
        loop-body:expr ...
        (cons loop-element:expr (loop2:id (:rest-by-any-name vs3:id)))]))
-  #:when (free-identifier=? #'loop #'loop2)
-  #:when (free-identifier=? #'vs #'vs2)
-  #:when (free-identifier=? #'vs #'vs3)
-  #:when (not
-          (for/or ([body-stx (in-list (cons #'loop-element (attribute loop-body)))])
-            (syntax-find-first body-stx
-              (~and (~var usage (expression-directly-enclosing (attribute vs)))
-                    (~not (:first-by-any-name _))))))
+  #:when (log-resyntax-rule-condition (free-identifier=? #'loop #'loop2))
+  #:when (log-resyntax-rule-condition (free-identifier=? #'vs #'vs2))
+  #:when (log-resyntax-rule-condition (free-identifier=? #'vs #'vs3))
+  #:when (log-resyntax-rule-condition
+          (not
+           (for/or ([body-stx (in-list (cons #'loop-element (attribute loop-body)))])
+             (syntax-find-first body-stx
+               (~and (~var usage (expression-directly-enclosing (attribute vs)))
+                     (~not (:first-by-any-name _)))))))
   #:cut
 
   #:with element-id (depluralize-id #'vs)
 
   #:with (modified-result-element modified-body ...)
   (for/list ([body-stx (cons #'loop-element (attribute loop-body))])
     (syntax-traverse body-stx
-      [(:first-by-any-name vs-usage:id) #:when (free-identifier=? #'vs-usage #'vs) #'element-id]))
+      [(:first-by-any-name vs-usage:id)
+       #:when (free-identifier=? (attribute vs-usage) (attribute vs))
+       (attribute element-id)]))
 
   (for/list ([element-id (in-list init-list)])
     modified-body ...
@@ -451,7 +455,7 @@ return just that result."
   #:with modified-element-condition
   (syntax-traverse (attribute element-condition)
     [(:first-by-any-name vs-usage:id)
-     #:when (free-identifier=? (attribute vs) (attribute vs-usage))
+     #:when (free-identifier=? (attribute vs-usage) (attribute vs))
      (attribute element-id)])
 
   (for/and ([element-id (in-list init-list)])
@@ -479,12 +483,11 @@ return just that result."
   #:with modified-element-condition
   (syntax-traverse (attribute element-condition)
     [(:first-by-any-name vs-usage:id)
-     #:when (free-identifier=? (attribute vs) (attribute vs-usage))
+     #:when (log-resyntax-rule-condition (free-identifier=? (attribute vs) (attribute vs-usage)))
      (attribute element-id)])
 
   (for/or ([element-id (in-list init-list)])
     modified-element-condition))
-  
 
 
 (define-refactoring-rule named-let-loop-to-for/first-in-vector
@@ -496,11 +499,11 @@ return just that result."
            (if condition:expr
                true-branch:expr
                (loop2:id (~or (add1 i4:id) (+ i4:id 1) (+ 1 i4:id)))))))
-  #:when (and (free-identifier=? #'loop1 #'loop2)
-              (free-identifier=? #'i1 #'i2)
-              (free-identifier=? #'i1 #'i3)
-              (free-identifier=? #'i1 #'i4)
-              (free-identifier=? #'vec1 #'vec2))
+  #:when (and (log-resyntax-rule-condition (free-identifier=? #'loop1 #'loop2))
+              (log-resyntax-rule-condition (free-identifier=? #'i1 #'i2))
+              (log-resyntax-rule-condition (free-identifier=? #'i1 #'i3))
+              (log-resyntax-rule-condition (free-identifier=? #'i1 #'i4))
+              (log-resyntax-rule-condition (free-identifier=? #'vec1 #'vec2)))
   (for/first ([x (in-vector vec1)] #:when condition)
     true-branch))
 

private/source.rkt

@@ -33,25 +33,28 @@
 
 
 (require guard
-         racket/file
-         racket/hash
          racket/match
          racket/path
          racket/port
+         racket/stream
          rebellion/base/comparator
          rebellion/base/immutable-string
+         rebellion/base/option
          rebellion/base/range
          rebellion/collection/list
          rebellion/collection/range-set
+         rebellion/collection/sorted-map
          rebellion/collection/vector/builder
          rebellion/streaming/reducer
          rebellion/streaming/transducer
          rebellion/type/record
          resyntax/private/fully-expanded-syntax
          resyntax/private/linemap
          resyntax/private/logger
+         resyntax/private/syntax-movement
          resyntax/private/syntax-neighbors
          resyntax/private/syntax-path
+         resyntax/private/syntax-traversal
          syntax/id-table
          syntax/modread
          syntax/parse)
@@ -137,30 +140,10 @@
     (define program-source-name (syntax-source program-stx))
     (define current-expand-observe (dynamic-require ''#%expobs 'current-expand-observe))
     (define original-visits (make-vector-builder))
-    (define expanded-originals-by-path (make-hash))
-
-    (define (add-all-original-subforms! stx)
-      (when (resyntax-should-analyze-syntax? stx #:as-visit? #false)
-        (hash-set! expanded-originals-by-path (syntax-original-path stx) stx))
-      (syntax-parse stx
-        [(subform ...) (for-each add-all-original-subforms! (attribute subform))]
-        [(subform ...+ . tail-form)
-         (for-each add-all-original-subforms! (attribute subform))
-         (add-all-original-subforms! #'tail-form)]
-        [_ (void)]))
-
-    (define (syntax-original-and-from-source? stx)
-      (and (syntax-original? stx)
-           ;; Some macros are able to bend hygiene and syntax properties in such a way that they
-           ;; introduce syntax objects into the program that are syntax-original?, but from a
-           ;; different file than the one being expanded. So in addition to checking for
-           ;; originality, we also check that they come from the same source as the main program
-           ;; syntax object. The (open ...) clause of the define-signature macro bends hygiene
-           ;; in this way, and is what originally motivated the addition of this check.
-           (equal? (syntax-source stx) program-source-name)))
+    (define most-recent-visits-by-original-path (make-hash))
 
     (define/guard (resyntax-should-analyze-syntax? stx #:as-visit? [as-visit? #true])
-      (guard (syntax-original-and-from-source? stx) #:else #false)
+      (guard (syntax-original-and-from-source? stx program-source-name) #:else #false)
       (guard as-visit? #:else #true)
       (define stx-lines (syntax-line-range stx #:linemap code-linemap))
       (define overlaps? (range-set-overlaps? lines stx-lines))
@@ -178,8 +161,12 @@
     (define/match (observe-event! sig val)
       [('visit (? syntax? visited))
        (when (resyntax-should-analyze-syntax? visited)
-         (vector-builder-add original-visits visited)
-         (add-all-original-subforms! visited))]
+         (vector-builder-add original-visits visited))
+       (for ([visit-subform (in-stream (syntax-search-everything visited))]
+             #:when (and (resyntax-should-analyze-syntax? visit-subform #:as-visit? #false)
+                         (syntax-has-original-path? visit-subform)))
+         (define path (syntax-original-path visit-subform))
+         (hash-set! most-recent-visits-by-original-path path visit-subform))]
       [(_ _) (void)])
 
     (define output-port (open-output-string))
@@ -195,39 +182,54 @@
     (namespace-require/expansion-time (extract-module-require-spec expanded))
 
     (define output (get-output-string output-port))
+    (define movement-table (syntax-movement-table expanded))
     (define binding-table (fully-expanded-syntax-binding-table expanded))
     (define original-binding-table-by-path
       (for*/fold ([table (hash)])
                  ([phase-table (in-hash-values binding-table)]
                   [(id uses) (in-free-id-table phase-table)]
-                  #:when (syntax-original-and-from-source? id)
+                  #:when (syntax-original-and-from-source? id program-source-name)
                   [use (in-list uses)])
         (hash-update table (syntax-original-path id) (λ (previous) (cons use previous)) '())))
+
+    (define expanded-with-properties
+      (syntax-traverse expanded
+        [id:id
+         #:do [(define path (syntax-original-path (attribute id)))]
+         #:when path
+         (define usages (hash-ref original-binding-table-by-path path '()))
+         (syntax-property this-syntax 'identifier-usages usages)]
+        #:parent-context-modifier values
+        #:parent-srcloc-modifier values
+        #:parent-props-modifier values))
 
-    (add-all-original-subforms! expanded)
-
-    (define/guard (add-usages stx)
-      (guard (identifier? stx) #:else stx)
-      (define usages (hash-ref original-binding-table-by-path (syntax-original-path stx) '()))
-      (syntax-property stx 'identifier-usages usages))
-
-    (define (enrich stx)
-      (define new-context
-        (add-usages
-         (or (hash-ref expanded-originals-by-path (syntax-original-path stx) #false) stx)))
-      (syntax-parse stx
-        [(subform ...)
-         (datum->syntax new-context
-                        (map enrich (attribute subform))
-                        new-context
-                        new-context)]
-        [(subform ...+ . tail-form)
-         (datum->syntax new-context
-                        (append (map enrich (attribute subform)) (enrich #'tail-form))
-                        new-context
-                        new-context)]
-        [_ new-context]))
-         
+    (define (enrich stx #:skip-root? [skip-root? #false])
+      (syntax-traverse stx
+        #:skip-root? skip-root?
+        [child
+         #:do [(define child-stx (attribute child))
+               (define orig-path (syntax-original-path child-stx))]
+         #:when (and orig-path (sorted-map-contains-key? movement-table orig-path))
+         #:do [(define expansion
+                 (transduce (sorted-map-get movement-table orig-path)
+                            (mapping (λ (p) (syntax-ref expanded-with-properties p)))
+                            (filtering syntax-original?)
+                            #:into into-first))]
+         #:when (present? expansion)
+         (match-define (present expanded-child) expansion)
+         (log-resyntax-debug "enriching ~a with scopes and properties from expansion" child-stx)
+         (enrich (datum->syntax expanded-child (syntax-e child-stx) child-stx expanded-child)
+                 #:skip-root? #true)]
+        [child
+         #:do [(define child-stx (attribute child))
+               (define orig-path (syntax-original-path child-stx))]
+         #:when (and orig-path (hash-has-key? most-recent-visits-by-original-path orig-path))
+         #:do [(define visit (hash-ref most-recent-visits-by-original-path orig-path))]
+         (log-resyntax-debug "enriching ~a with scopes from visit" child-stx)
+         (enrich (datum->syntax visit (syntax-e child-stx) child-stx child-stx) #:skip-root? #true)]
+        #:parent-context-modifier values
+        #:parent-srcloc-modifier values
+        #:parent-props-modifier values))
 
     (define visited
       (transduce (build-vector original-visits)
@@ -254,6 +256,17 @@
                           #:namespace ns)))
 
 
+(define (syntax-original-and-from-source? stx source-name)
+  (and (syntax-original? stx)
+       ;; Some macros are able to bend hygiene and syntax properties in such a way that they
+       ;; introduce syntax objects into the program that are syntax-original?, but from a
+       ;; different file than the one being expanded. So in addition to checking for
+       ;; originality, we also check that they come from the same source as the main program
+       ;; syntax object. The (open ...) clause of the define-signature macro bends hygiene
+       ;; in this way, and is what originally motivated the addition of this check.
+       (equal? (syntax-source stx) source-name)))
+
+
 (define (extract-module-require-spec mod-stx)
   (syntax-parse mod-stx
     [(_ name _ . _) `',(syntax-e #'name)]))

private/syntax-traversal.rkt

@@ -14,14 +14,16 @@
 
 (require (for-syntax racket/base
                      resyntax/private/more-syntax-parse-classes)
+         racket/match
          racket/sequence
          racket/stream
          syntax/parse
          syntax/parse/define)
 
 
 (module+ test
-  (require rackunit
+  (require racket/syntax-srcloc
+           rackunit
            (submod "..")))
 
 
@@ -130,43 +132,64 @@
     (check-false (syntax-find-first stx #:literals (cons) (cons _ _ _)))))
 
 
+(define (perform-syntax-traversal stx modifier
+                                  #:skip-root? [skip-root? #false]
+                                  #:parent-context-modifier [context-modifier* #false]
+                                  #:parent-srcloc-modifier [srcloc-modifier (λ (_) #'here)]
+                                  #:parent-props-modifier [props-modifier (λ (_) #false)])
+  (define context-modifier
+    (or context-modifier*
+        (let ([scope (make-syntax-introducer)])
+          (λ (stx) (scope stx 'add)))))
+  (let loop ([stx stx] [root? #true])
+    (define should-skip-because-root? (and skip-root? root?))
+    (define modified-stx (and (not should-skip-because-root?) (modifier stx)))
+    (match modified-stx
+      [(== stx) stx]
+      [(? syntax?) modified-stx]
+      [#false
+       (syntax-parse stx
+         [(child ...)
+          (define traversed-children
+            (for/list ([child-stx (in-list (attribute child))])
+              (loop child-stx #false)))
+          (define all-same?
+            (for/and ([traversed-child (in-list traversed-children)]
+                      [child-stx (in-list (attribute child))])
+              (equal? traversed-child child-stx)))
+          (if all-same?
+              stx
+              (datum->syntax (context-modifier stx)
+                             traversed-children
+                             (srcloc-modifier stx)
+                             (props-modifier stx)))]
+         [_ stx])])))
+
+
 (define-syntax-parse-rule
   (syntax-traverse (~var stx-expr (expr/c #'syntax?))
-    (~optional (~seq #:skip-root? skip-root?) #:defaults ([skip-root? #'#false]))
+    (~optional (~seq #:skip-root? skip-root?))
     option:syntax-parse-option ...
-    [clause-pattern directive:syntax-parse-pattern-directive ... clause-body:expr ...+] ...)
-  (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] [root? #true])
+    [clause-pattern directive:syntax-parse-pattern-directive ... clause-body:expr ...+] ...
+    (~optional (~seq #:parent-context-modifier context-modifier:expr))
+    (~optional (~seq #:parent-srcloc-modifier srcloc-modifier:expr))
+    (~optional (~seq #:parent-props-modifier props-modifier:expr)))
+    
 
-      (define (rewrap-datum datum)
-        (datum->syntax stx datum stx stx))
+  (let ()
 
+    (define (traversal-case stx)
       (syntax-parse stx
+        (~@ . option) ...
+        [clause-pattern (~@ . directive) ... clause-body ...]
+        ...
+        [_ #false]))
 
-        [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
-         (rewrap-datum
-          (for/list ([child (in-list (attribute part))])
-            (loop child #false)))]
-        [(part (... ...+) . tail-part)
-         #:cut
-         (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]))))
+    (perform-syntax-traversal stx-expr.c traversal-case
+                              (~? (~@ #:skip-root? skip-root?))
+                              (~? (~@ #:parent-context-modifier context-modifier))
+                              (~? (~@ #:parent-srcloc-modifier srcloc-modifier))
+                              (~? (~@ #:parent-props-modifier props-modifier)))))
 
 
 (module+ test
@@ -222,10 +245,11 @@
       (syntax-traverse stx
         [(_ id:id) (attribute id)]))
     (check-equal? (syntax->datum traversed-stx) '(1 2 b 3 4))
-    (check-true (syntax-original? traversed-stx))
+    (check-false (syntax-original? traversed-stx))
+    (check-not-equal? (syntax-srcloc traversed-stx) (syntax-srcloc 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? #'b*))
     (check-true (syntax-original? #'3*))
     (check-true (syntax-original? #'4*))))