Automatically infer original splices (#243)

This removes the need for the `ORIGINAL-SPLICE` markup in syntax replacements by automatically detecting when a sequence of subforms in a replacement are left untouched. This commit removes some uses of `ORIGINAL-SPLICE` to validate the implementation, but not all.

default-recommendations/conditional-shortcuts.rkt

@@ -195,11 +195,9 @@
        (~and else-expr:if-arm (~not (void))))
    #:when (or (attribute then-expr.uses-begin?) (attribute else-expr.uses-begin?))
    #:with (true-branch ...)
-   (if (or (multiline-syntax? #'condition)
-           (multiline-syntax? #'then-expr)
-           (attribute then-expr.uses-begin?))
+   (if (attribute then-expr.uses-begin?)
        #'([condition (ORIGINAL-GAP condition then-expr) then-expr.refactored ...])
-       #'((ORIGINAL-GAP condition then-expr) [condition then-expr.refactored ...]))
+       #'([condition then-expr.refactored ...]))
    #:with (false-branch ...)
    (if (attribute else-expr.uses-begin?)
        #'([else (ORIGINAL-GAP then-expr else-expr) else-expr.refactored ...])
@@ -218,11 +216,9 @@
        (~and else-expr:if-arm (~not (void))))
    #:when (or (attribute then-expr.uses-let?) (attribute else-expr.uses-let?))
    #:with (true-branch ...)
-   (if (or (multiline-syntax? #'condition)
-           (multiline-syntax? #'then-expr)
-           (attribute then-expr.uses-let?))
+   (if (attribute then-expr.uses-let?)
        #'([condition (ORIGINAL-GAP condition then-expr) then-expr.refactored ...])
-       #'((ORIGINAL-GAP condition then-expr) [condition then-expr.refactored ...]))
+       #'([condition then-expr.refactored ...]))
    #:with (false-branch ...)
    (if (attribute else-expr.uses-let?)
        #'([else (ORIGINAL-GAP then-expr else-expr) else-expr.refactored ...])

default-recommendations/gap-preservation-test.rkt

@@ -0,0 +1,67 @@
+#lang resyntax/testing/refactoring-test
+
+
+require: resyntax/default-recommendations/gap-preservation gap-preservation-rules
+
+
+header:
+- #lang racket/base
+
+
+test: "comments preserved in splice when form inserted at front"
+-----------------------------------
+(define (code insert-foo-first a b)
+  (insert-foo-first a
+                    ; comment
+                    b))
+-----------------------------------
+-----------------------------------
+(define (code insert-foo-first a b)
+  ("foo" a
+         ; comment
+         b))
+-----------------------------------
+
+
+test: "later comments preserved in splice when form inserted after first"
+-----------------------------------
+(define (code insert-foo-second a b c)
+  (insert-foo-second a
+                     b
+                     ; preserved comment
+                     c))
+-----------------------------------
+-----------------------------------
+(define (code insert-foo-second a b c)
+  (a "foo"
+     b
+     ; preserved comment
+     c))
+-----------------------------------
+
+
+test: "not refactorable when comment dropped due to inserted form"
+-----------------------------------
+(define (code insert-foo-second a b c)
+  (insert-foo-second a
+                     ; dropped comment
+                     b
+                     c))
+-----------------------------------
+
+
+test: "comments preserved in splice when form inserted at end"
+-----------------------------------
+(define (code insert-foo-last a b c)
+  (insert-foo-last a
+                   b
+                   ; comment
+                   c))
+-----------------------------------
+-----------------------------------
+(define (code insert-foo-last a b c)
+  (a b
+     ; comment
+     c
+     "foo"))
+-----------------------------------

default-recommendations/gap-preservation.rkt

@@ -0,0 +1,67 @@
+#lang racket/base
+
+
+;; These aren't real refactoring rules. They're only used for testing Resyntax. Specifically, they're
+;; used to test that Resyntax properly preserves comments in between sequences of forms that are left
+;; unchanged by a refactoring rule, even when forms before and after that sequence are changed. See
+;; the accompanying tests in gap-preservation-test.rkt for examples.
+
+
+(require racket/contract/base)
+
+
+(provide
+ (contract-out
+  [gap-preservation-rules refactoring-suite?]))
+
+
+(require (for-syntax racket/base)
+         racket/list
+         rebellion/private/static-name
+         resyntax/default-recommendations/private/boolean
+         resyntax/default-recommendations/private/definition-context
+         resyntax/default-recommendations/private/exception
+         resyntax/default-recommendations/private/let-binding
+         resyntax/default-recommendations/private/metafunction
+         resyntax/default-recommendations/private/syntax-lines
+         resyntax/refactoring-rule
+         resyntax/refactoring-suite
+         resyntax/private/syntax-replacement
+         syntax/parse)
+
+
+;@----------------------------------------------------------------------------------------------------
+
+
+(define-refactoring-rule suggest-inserting-foo-first
+  #:description "This refactoring rule is for testing Resyntax, ignore its suggestions."
+  #:datum-literals (insert-foo-first)
+  [(insert-foo-first a ...) ("foo" a ...)])
+
+
+(define-refactoring-rule suggest-inserting-foo-second
+  #:description "This refactoring rule is for testing Resyntax, ignore its suggestions."
+  #:datum-literals (insert-foo-second)
+  [(insert-foo-second a0 a ...) (a0 "foo" a ...)])
+
+
+(define-refactoring-rule suggest-inserting-foo-last
+  #:description "This refactoring rule is for testing Resyntax, ignore its suggestions."
+  #:datum-literals (insert-foo-last)
+  [(insert-foo-last a ...) (a ... "foo")])
+
+
+(define-refactoring-rule suggest-inserting-foo-first-and-last
+  #:description "This refactoring rule is for testing Resyntax, ignore its suggestions."
+  #:datum-literals (insert-foo-first-and-last)
+  [(insert-foo-first-and-last a ...) ("foo" a ... "foo")])
+
+
+(define gap-preservation-rules
+  (refactoring-suite
+   #:name (name gap-preservation-rules)
+   #:rules
+   (list suggest-inserting-foo-first
+         suggest-inserting-foo-second
+         suggest-inserting-foo-last
+         suggest-inserting-foo-first-and-last)))

default-recommendations/let-binding-suggestions-comment-test.rkt

@@ -25,14 +25,21 @@ test: "let binding with commented right-hand-side expression"
 ------------------------------
 
 
-test: "let binding with commented body not refactorable (yet)"
+test: "let binding with commented body refactorable"
 ------------------------------
 (define (f)
   (let ([x 1])
     (void)
     ;; Comment
     1))
 ------------------------------
+------------------------------
+(define (f)
+  (define x 1)
+  (void)
+  ;; Comment
+  1)
+------------------------------
 
 
 test: "let binding with comments before let form not refactorable (yet)"

private/string-replacement.rkt

@@ -25,6 +25,7 @@
   [string-replacement-new-span (-> string-replacement? natural?)]
   [string-replacement-contents
    (-> string-replacement? (listof (or/c inserted-string? copied-string?)))]
+  [string-replacement-preserved-locations (-> string-replacement? range-set?)]
   [string-replacement-overlaps? (-> string-replacement? string-replacement? boolean?)]
   [string-replacement-union
    (->i ([replacement1 string-replacement?]
@@ -62,6 +63,7 @@
          rebellion/base/option
          rebellion/base/range
          rebellion/collection/list
+         rebellion/collection/range-set
          rebellion/private/static-name
          rebellion/streaming/reducer
          rebellion/streaming/transducer
@@ -250,3 +252,15 @@
        #:contents (list (inserted-string "goodbye") (copied-string 5 6) (inserted-string "friend"))))
     (check-equal? union expected)
     (check-equal? (transduce (list r1 r2) #:into union-into-string-replacement) expected)))
+
+
+(define (string-replacement-preserved-locations replacement)
+  (define before-replacement
+    (less-than-range (string-replacement-start replacement) #:comparator natural<=>))
+  (define after-replacement
+    (at-least-range (string-replacement-original-end replacement) #:comparator natural<=>))
+  (for/fold ([ranges (range-set before-replacement after-replacement)])
+            ([piece (in-list (string-replacement-contents replacement))]
+             #:when (copied-string? piece))
+    (match-define (copied-string start end) piece)
+    (range-set-add ranges (closed-open-range start end #:comparator natural<=>))))

private/syntax-neighbors.rkt

@@ -0,0 +1,109 @@
+#lang racket/base
+
+
+;; This module provides a means to track which subforms of a syntax object have remained
+;; unchanged and remained neighbors after a syntax object transformation. The function
+;; syntax-mark-original-neighbors traverses all forms within a syntax object and stores
+;; their original neighboring forms within syntax properties. Storing this metadata in
+;; properties allows it to be preserved when macros, refactoring rules, and other syntax
+;; transformations shuffle subforms around. This is used by Resyntax to preserve formatting
+;; and comments when sequences of adjacent forms are left unchanged by a refactoring rule.
+
+
+(require racket/contract/base)
+
+
+(provide
+ (contract-out
+  [syntax-original-leading-neighbor (-> syntax? (or/c syntax? #false))]
+  [syntax-original-trailing-neighbor (-> syntax? (or/c syntax? #false))]
+  [syntax-originally-neighbors? (-> syntax? syntax? boolean?)]
+  [syntax-mark-original-neighbors (-> syntax? syntax?)]))
+
+
+(require guard
+         racket/syntax-srcloc
+         syntax/parse)
+
+
+(module+ test
+  (require (submod "..")
+           racket/syntax
+           rackunit))
+
+
+;@----------------------------------------------------------------------------------------------------
+
+
+(define (syntax-mark-original-neighbors stx)
+  (syntax-parse stx
+    [(~and (subform ...+) (_ trailing-neighbor ...) (leading-neighbor ... _))
+     (define leading-neighbors (cons #false (attribute leading-neighbor)))
+     (define trailing-neighbors (append (attribute trailing-neighbor) (list #false)))
+     (define results
+       (for/list ([leading (in-list leading-neighbors)]
+                  [trailing (in-list trailing-neighbors)]
+                  [subform-stx (in-list (attribute subform))])
+         (mark-neighbors (syntax-mark-original-neighbors subform-stx)
+                         #:leading-neighbor leading
+                         #:trailing-neighbor trailing)))
+     (datum->syntax stx results stx stx)]
+    [_ stx]))
+
+
+(define (mark-neighbors stx #:leading-neighbor leading-stx #:trailing-neighbor trailing-stx)
+  (define stx-with-leading
+    (if leading-stx
+        (syntax-property stx 'original-leading-neighbor leading-stx)
+        stx))
+  (if trailing-stx
+      (syntax-property stx-with-leading
+                       'original-trailing-neighbor
+                       trailing-stx)
+      stx-with-leading))
+
+
+(define (syntax-original-leading-neighbor stx)
+  (syntax-property stx 'original-leading-neighbor))
+
+
+(define (syntax-original-trailing-neighbor stx)
+  (syntax-property stx 'original-trailing-neighbor))
+
+
+(define/guard (syntax-originally-neighbors? left-stx right-stx)
+  (define left-trailer (syntax-original-trailing-neighbor left-stx))
+  (define right-leader (syntax-original-leading-neighbor right-stx))
+  (guard (and left-trailer right-leader) #:else #false)
+  (define left-srcloc (syntax-srcloc left-stx))
+  (define left-trailer-srcloc (syntax-srcloc left-trailer))
+  (define right-srcloc (syntax-srcloc right-stx))
+  (define right-leader-srcloc (syntax-srcloc right-leader))
+  (guard (and left-srcloc left-trailer-srcloc right-srcloc right-leader-srcloc) #:else #false)
+  (and (equal? left-trailer-srcloc right-srcloc)
+       (equal? right-leader-srcloc left-srcloc)))
+
+
+(module+ test
+  (test-case "syntax-mark-original-neighbors"
+    (define stx #'(foo (a b c) bar (baz)))
+    (define marked (syntax-mark-original-neighbors stx))
+    (check-equal? (syntax->datum marked) (syntax->datum stx))
+    (define/with-syntax (foo* (a* b* c*) bar* (baz*)) marked)
+    (check-false (syntax-original-leading-neighbor #'foo*))
+    (check-equal? (syntax->datum (syntax-original-trailing-neighbor #'foo*)) '(a b c))
+    (check-false (syntax-original-leading-neighbor #'a*))
+    (check-equal? (syntax->datum (syntax-original-trailing-neighbor #'a*)) 'b)
+    (check-equal? (syntax->datum (syntax-original-leading-neighbor #'b*)) 'a)
+    (check-equal? (syntax->datum (syntax-original-trailing-neighbor #'b*)) 'c)
+    (check-equal? (syntax->datum (syntax-original-leading-neighbor #'c*)) 'b)
+    (check-false (syntax-original-trailing-neighbor #'c*))
+    (check-equal? (syntax->datum (syntax-original-leading-neighbor #'bar*)) '(a b c))
+    (check-equal? (syntax->datum (syntax-original-trailing-neighbor #'bar*)) '(baz))
+    (check-false (syntax-original-leading-neighbor #'baz*))
+    (check-false (syntax-original-trailing-neighbor #'baz*))
+    (check-false (syntax-originally-neighbors? #'foo* #'b*))
+    (check-true (syntax-originally-neighbors? #'a* #'b*))
+    (check-true (syntax-originally-neighbors? #'b* #'c*))
+    (check-false (syntax-originally-neighbors? #'c* #'bar*))
+    (check-false (syntax-originally-neighbors? #'bar* #'baz*))))