Add for/fold-result-keyword rule. (#266)

Closes #215. This rule specifically only targets the case where `for/fold` is used with `define-values` and exactly one of the result values is used. That seems like the most common and easily fixable case.

Additionally, this change improves the logging for suggestions that have binding problems. Some names are also changed to make it clearer what's going on.

default-recommendations/for-loop-shortcuts-test.rkt

@@ -301,6 +301,30 @@ test: "for*/fold building hash can't be refactored when referring to hash"
 ------------------------------
 
 
+test: "multi-accumulator for/fold with one used result refactorable to for/fold using #:result"
+------------------------------
+(define (foo)
+  (define-values (x y z)
+    (for/fold ([accum1 0]
+               [accum2 0]
+               [accum3 0])
+              ([n (in-naturals)])
+      (values 0 0 0)))
+  (* x 2))
+------------------------------
+------------------------------
+(define (foo)
+  (define x
+    (for/fold ([accum1 0]
+               [accum2 0]
+               [accum3 0]
+               #:result accum1)
+              ([n (in-naturals)])
+      (values 0 0 0)))
+  (* x 2))
+------------------------------
+
+
 test: "list->vector with for/list to for/vector"
 ------------------------------
 (list->vector

default-recommendations/for-loop-shortcuts.rkt

@@ -211,6 +211,36 @@
    (loop iteration-clauses body ... (values key value))])
 
 
+(define-definition-context-refactoring-rule for/fold-result-keyword
+  #:description
+  "Only one of the `for/fold` expression's result values is used. Use the `#:result` keyword to \
+return just that result."
+  #:literals (define-values for/fold for*/fold)
+  [(~seq body-before ...
+         (~and original-definition
+               (define-values (result-id:id ...)
+           ((~or for-id:for/fold for-id:for*/fold)
+            ([accumulator-id:id initializer:expr] ...)
+            loop-clauses loop-body ...)))
+         body-after ...)
+   #:do [(define used-ids
+           (for/list ([id (in-list (attribute result-id))]
+                      #:when (set-member? (syntax-free-identifiers #'(body-after ...)) id))
+             id))]
+   #:when (equal? (length used-ids) 1)
+   #:cut
+   #:do [(define used-index (index-of (attribute result-id) (first used-ids)))
+         (define used-accumulator (list-ref (attribute accumulator-id) used-index))]
+   #:with replacement-definition
+   #`(define #,(first used-ids)
+       (for-id ([accumulator-id initializer] ...
+                #:result #,used-accumulator)
+               loop-clauses loop-body ...))
+   (body-before ...
+    (~replacement replacement-definition #:original original-definition)
+    body-after ...)])
+
+
 (define-syntax-class nested-for
 
   #:attributes ([clause 1] [body 1])
@@ -309,6 +339,7 @@
          apply-append-for-loop-to-for-loop
          apply-plus-to-for/sum
          for/fold-building-hash-to-for/hash
+         for/fold-result-keyword
          for-each-to-for
          list->set-to-for/set
          list->vector-to-for/vector

main.rkt

@@ -58,10 +58,13 @@
         (guard-match (present replacement)
           (refactoring-rule-refactor rule syntax #:analysis analysis)
           #:else absent)
-        (guard (syntax-replacement-preserves-free-identifiers? replacement) #:else
+        (guard (syntax-replacement-introduces-incorrect-bindings? replacement) #:else
           (log-resyntax-error
-           "~a: suggestion discarded because it does not preserve all free identifiers"
-           (object-name rule))
+           (string-append
+            "~a: suggestion discarded because it introduces identifiers with incorrect bindings\n"
+            "  incorrect identifiers: ~a")
+           (object-name rule)
+           (syntax-replacement-introduced-incorrect-identifiers replacement))
           absent)
         (guard (syntax-replacement-preserves-comments? replacement comments) #:else
           (log-resyntax-warning

private/syntax-replacement.rkt

@@ -16,7 +16,9 @@
   [syntax-replacement-render (-> syntax-replacement? string-replacement?)]
   [syntax-replacement-original-syntax (-> syntax-replacement? (and/c syntax? syntax-original?))]
   [syntax-replacement-new-syntax (-> syntax-replacement? syntax?)]
-  [syntax-replacement-preserves-free-identifiers? (-> syntax-replacement? boolean?)]
+  [syntax-replacement-introduces-incorrect-bindings? (-> syntax-replacement? boolean?)]
+  [syntax-replacement-introduced-incorrect-identifiers
+   (-> syntax-replacement? (listof identifier?))]
   [syntax-replacement-preserves-comments? (-> syntax-replacement? range-set? boolean?)]
   [syntax-replacement-dropped-comment-locations (-> syntax-replacement? range-set? range-set?)]))
 
@@ -179,16 +181,29 @@
        (check-equal? (syntax-replacement-render replacement) expected)])))
 
 
-(define (syntax-replacement-preserves-free-identifiers? replacement)
-  (match replacement
-    [(syntax-replacement #:original-syntax orig
-                         #:new-syntax new
-                         #:introduction-scope intro)
-     (define ignore (list #'ORIGINAL-GAP))
-     (for/and ([new-id (in-syntax-identifiers new)]
-               #:unless (member new-id ignore free-identifier=?)
-               #:unless (bound-identifier=? new-id (intro new-id 'remove)))
-       (free-identifier=? new-id (datum->syntax orig (syntax->datum new-id))))]))
+(define (syntax-replacement-introduces-incorrect-bindings? replacement)
+  (match-define (syntax-replacement #:original-syntax orig
+                                    #:new-syntax new
+                                    #:introduction-scope intro)
+    replacement)
+  (define ignore (list #'ORIGINAL-GAP))
+  (for/and ([new-id (in-syntax-identifiers new)]
+            #:unless (member new-id ignore free-identifier=?)
+            #:unless (bound-identifier=? new-id (intro new-id 'remove)))
+    (free-identifier=? new-id (datum->syntax orig (syntax->datum new-id)))))
+
+
+(define (syntax-replacement-introduced-incorrect-identifiers replacement)
+  (match-define (syntax-replacement #:original-syntax orig
+                                    #:new-syntax new
+                                    #:introduction-scope intro)
+    replacement)
+  (define ignore (list #'ORIGINAL-GAP))
+  (for/list ([new-id (in-syntax-identifiers new)]
+             #:unless (member new-id ignore free-identifier=?)
+             #:unless (bound-identifier=? new-id (intro new-id 'remove))
+             #:unless (free-identifier=? new-id (datum->syntax orig (syntax->datum new-id))))
+    new-id))
 
 
 (define (syntax-replacement-dropped-comment-locations replacement all-comment-locations)