Rewrite named lets into for/or and for/and (#466)

Closes #454.

Author: jackfirth

base.rkt

@@ -29,13 +29,17 @@
      (-> refactoring-rule? syntax? source? (option/c syntax-replacement?))])))
 
 
-(require (for-syntax racket/base racket/syntax resyntax/private/more-syntax-parse-classes)
+(require (for-syntax racket/base
+                     racket/list
+                     racket/syntax
+                     resyntax/private/more-syntax-parse-classes)
          racket/sequence
          rebellion/base/immutable-string
          rebellion/base/option
          rebellion/base/symbol
          rebellion/type/object
          resyntax/default-recommendations/private/definition-context
+         resyntax/private/logger
          resyntax/private/source
          resyntax/private/syntax-neighbors
          resyntax/private/syntax-replacement
@@ -128,6 +132,8 @@
     pattern-directive:syntax-parse-pattern-directive ...
     replacement)
   #:declare description (expr/c #'string?)
+  #:attr log-statement (and (not (empty? (attribute pattern-directive)))
+                            #'(log-resyntax-debug "~a: partial match" 'id))
   (define id
     (constructor:refactoring-rule
      #:name 'id
@@ -136,7 +142,9 @@
      (λ (stx)
        (syntax-parse stx
          (~@ . parse-option) ...
-         [pattern (~@ . pattern-directive) ... (present #'replacement)]
+         [pattern
+           (~? (~@ #:do [log-statement]))
+           (~@ . pattern-directive) ... (present #'replacement)]
          [_ absent])))))
 
 
@@ -154,12 +162,16 @@
   #:with body-matching-id (format-id #'macro-introduced-context "body-matching-~a" #'id)
   #:with expression-matching-id (format-id #'macro-introduced-context "expression-matching-~a" #'id)
 
+  #:attr log-statement (and (not (empty? (attribute pattern-directive)))
+                            #'(log-resyntax-debug "~a: partial match" 'id))
+
   (begin
 
     (define-splicing-syntax-class body-matching-id
       #:attributes ([refactored 1])
       (~@ . parse-option) ...
       (pattern splicing-pattern
+        (~? (~@ #:do [log-statement]))
         (~@ . pattern-directive) ...
         #:with (refactored (... ...)) #'(splicing-replacement ...)))
 

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

@@ -634,6 +634,43 @@ test: "named let loop over list can be replaced by for/list"
 ------------------------------------------------------------
 
 
+test: "named let loop can be replaced with for/and when equivalent"
+------------------------------------------------------------
+(require racket/list)
+(define (f xs big? red?)
+  (let loop ([xs xs])
+    (cond
+      [(empty? xs) #true]
+      [(and (big? (first xs)) (not (red? (car xs))))
+       (loop (rest xs))]
+      [else #false])))
+------------------------------------------------------------
+------------------------------------------------------------
+(require racket/list)
+(define (f xs big? red?)
+  (for/and ([x (in-list xs)])
+    (and (big? x) (not (red? x)))))
+------------------------------------------------------------
+
+
+test: "named let loop can be replaced with for/or when equivalent"
+------------------------------------------------------------
+(require racket/list)
+(define (f xs big? red?)
+  (let loop ([xs xs])
+    (cond
+      [(empty? xs) #false]
+      [(and (big? (first xs)) (not (red? (car xs)))) #true]
+      [else (loop (rest xs))])))
+------------------------------------------------------------
+------------------------------------------------------------
+(require racket/list)
+(define (f xs big? red?)
+  (for/or ([x (in-list xs)])
+    (and (big? x) (not (red? x)))))
+------------------------------------------------------------
+
+
 test: "append-map with for/list can be replaced by for*/list"
 ------------------------------------------------------------
 (require racket/list)

default-recommendations/for-loop-shortcuts.rkt

@@ -16,11 +16,13 @@
          resyntax/default-recommendations/private/boolean
          resyntax/default-recommendations/private/lambda-by-any-name
          resyntax/default-recommendations/private/let-binding
+         resyntax/default-recommendations/private/list-function
          resyntax/default-recommendations/private/metafunction
          resyntax/default-recommendations/private/syntax-equivalence
          resyntax/default-recommendations/private/syntax-identifier-sets
          resyntax/default-recommendations/private/syntax-lines
          resyntax/private/identifier-naming
+         resyntax/private/logger
          resyntax/private/syntax-traversal
          syntax/parse)
 
@@ -376,35 +378,89 @@ return just that result."
   #:literals (let cond else null? empty? null quote car first cdr rest cons)
   (let loop:id ([vs:id init-list])
     (cond
-      [((~or null? empty?) vs2:id) (~or null '())]
+      [(:empty-predicate-by-any-name vs2:id) :empty-list-by-any-name]
       [else
        loop-body:expr ...
-       (cons loop-element:expr
-             (loop2:id ((~or cdr rest) vs3:id)))]))
+       (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 (for*/and ([body-stx (in-list (cons #'loop-element (attribute loop-body)))]
-                    [vs-usage
-                     (syntax-search body-stx [(~var usage (expression-directly-enclosing #'vs))])]
-                    #:unless (syntax-free-identifier=? vs-usage #'(car vs)))
-           (syntax-free-identifier=? vs-usage #'(first vs)))
+  #: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 _))))))
   #: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
-      #:literals (car first)
-      [(car vs-usage:id) #:when (free-identifier=? #'vs-usage #'vs) #'element-id]
-      [(first vs-usage:id) #:when (free-identifier=? #'vs-usage #'vs) #'element-id]))
+      [(:first-by-any-name vs-usage:id) #:when (free-identifier=? #'vs-usage #'vs) #'element-id]))
 
   (for/list ([element-id (in-list init-list)])
     modified-body ...
     modified-result-element))
 
 
+(define-refactoring-rule named-let-loop-to-for/and
+  #:description "This named `let` expression is equivalent to a `for/and` loop."
+  #:literals (let cond else)
+  (let loop:id ([vs:id init-list])
+    (cond
+      [(:empty-predicate-by-any-name vs2:id) #true]
+      [element-condition:expr (loop2:id (:rest-by-any-name vs3:id))]
+      [else #false]))
+
+  #:when (free-identifier=? (attribute loop) (attribute loop2))
+  #:when (free-identifier=? (attribute vs) (attribute vs2))
+  #:when (free-identifier=? (attribute vs) (attribute vs3))
+  #:when (not (syntax-find-first (attribute element-condition)
+                (~and (~var usage (expression-directly-enclosing (attribute vs)))
+                      (~not (:first-by-any-name _)))))
+  #:cut
+
+  #:with element-id (depluralize-id (attribute vs))
+  #:with modified-element-condition
+  (syntax-traverse (attribute element-condition)
+    [(:first-by-any-name vs-usage:id)
+     #:when (free-identifier=? (attribute vs) (attribute vs-usage))
+     (attribute element-id)])
+
+  (for/and ([element-id (in-list init-list)])
+    modified-element-condition))
+
+
+(define-refactoring-rule named-let-loop-to-for/or
+  #:description "This named `let` expression is equivalent to a `for/or` loop."
+  #:literals (let cond else)
+  (let loop:id ([vs:id init-list])
+    (cond
+      [(:empty-predicate-by-any-name vs2:id) #false]
+      [element-condition:expr #true]
+      [else (loop2:id (:rest-by-any-name vs3:id))]))
+
+  #:when (free-identifier=? (attribute loop) (attribute loop2))
+  #:when (free-identifier=? (attribute vs) (attribute vs2))
+  #:when (free-identifier=? (attribute vs) (attribute vs3))
+  #:when (not (syntax-find-first (attribute element-condition)
+                (~and (~var usage (expression-directly-enclosing (attribute vs)))
+                      (~not (:first-by-any-name _)))))
+  #:cut
+
+  #:with element-id (depluralize-id (attribute vs))
+  #:with modified-element-condition
+  (syntax-traverse (attribute element-condition)
+    [(:first-by-any-name vs-usage:id)
+     #:when (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
   #:description "This loop can be replaced by a simpler, equivalent `for/first` loop."
   #:literals (let add1 + vector-length vector-ref if and <)
@@ -466,8 +522,10 @@ return just that result."
            list->set-to-for/set
            list->vector-to-for/vector
            map-to-for
-           named-let-loop-to-for/list
+           named-let-loop-to-for/and
            named-let-loop-to-for/first-in-vector
+           named-let-loop-to-for/list
+           named-let-loop-to-for/or
            nested-for-to-for*
            nested-for/and-to-for*/and
            nested-for/or-to-for*/or

default-recommendations/private/list-function.rkt

@@ -0,0 +1,34 @@
+#lang racket/base
+
+
+(provide empty-list-by-any-name
+         empty-predicate-by-any-name
+         first-by-any-name
+         rest-by-any-name)
+
+
+(require racket/list
+         syntax/parse)
+
+
+;@----------------------------------------------------------------------------------------------------
+
+
+(define-syntax-class empty-list-by-any-name
+  #:literals (quote null empty list)
+  (pattern (~or '() null empty (list))))
+
+
+(define-syntax-class empty-predicate-by-any-name
+  #:literals (null? empty?)
+  (pattern (~or null? empty?)))
+
+
+(define-syntax-class first-by-any-name
+  #:literals (car first)
+  (pattern (~or car first)))
+
+
+(define-syntax-class rest-by-any-name
+  #:literals (cdr rest)
+  (pattern (~or cdr rest)))

private/syntax-traversal.rkt

@@ -38,7 +38,7 @@
     #:when (for/or ([part-stx (in-list (attribute part))]
                     #:when (identifier? part-stx))
              (free-identifier=? id part-stx)))
-  (pattern (part ... . tail-part)
+  (pattern (part ...+ . tail-part)
     #:when (for/or ([part-stx (in-list (cons #'tail-part (attribute part)))]
                     #:when (identifier? part-stx))
              (free-identifier=? id part-stx))))
@@ -124,7 +124,7 @@
 (define-syntax-parse-rule
   (syntax-traverse (~var stx-expr (expr/c #'syntax?))
     option:syntax-parse-option ...
-    [clause-pattern directive:syntax-parse-pattern-directive ... clause-body:expr ...] ...)
+    [clause-pattern directive:syntax-parse-pattern-directive ... clause-body:expr ...+] ...)
   (let ()
     (define-syntax-class traversal-case
       #:attributes (traversed)