Add @lines test parameter (#367)

This allows controlling the set of lines analyzed by Resyntax in `#lang resyntax/test`. Closes #314.

default-recommendations/definition-shortcuts-test.rkt

@@ -84,6 +84,31 @@ test: "refactoring define-values to separate definitions doesn't reformat contex
 ------------------------------
 
 
+test: "refactoring define-values to separate definitions respects requested line range"
+@lines 2..3
+------------------------------
+(define (foo)
+  (define-values (a b c)
+    (values 1 2 3))
+  (+ a b c))
+(define (bar)
+  (define-values (x y z)
+    (values 4 5 6))
+  (+ x y z))
+------------------------------
+------------------------------
+(define (foo)
+  (define a 1)
+  (define b 2)
+  (define c 3)
+  (+ a b c))
+(define (bar)
+  (define-values (x y z)
+    (values 4 5 6))
+  (+ x y z))
+------------------------------
+
+
 test: "immediately returned variable definition can be inlined"
 ------------------------------
 (define (foo)
@@ -142,3 +167,28 @@ test: "inlining immediately returned variable definition in empty context does r
 (map (λ (x) (* x 2))
      (list 1 2 3))
 ------------------------------
+
+
+test: "inlining immediately returned variable definition respects requested line range"
+@lines 4..6
+------------------------------
+(define (foo)
+  (define x 1)
+  x)
+(define (bar)
+  (define x 1)
+  x)
+(define (baz)
+  (define x 1)
+  x)
+------------------------------
+------------------------------
+(define (foo)
+  (define x 1)
+  x)
+(define (bar)
+  1)
+(define (baz)
+  (define x 1)
+  x)
+------------------------------

main.rkt

@@ -7,7 +7,8 @@
 (provide
  (contract-out
   [refactor! (-> (sequence/c refactoring-result?) void?)]
-  [refactor (->* (string?) (#:suite refactoring-suite?) (listof refactoring-result?))]
+  [refactor
+   (->* (string?) (#:suite refactoring-suite? #:lines range-set?) (listof refactoring-result?))]
   [refactor-file (->* (file-portion?) (#:suite refactoring-suite?) (listof refactoring-result?))]))
 
 

test.rkt

@@ -7,6 +7,8 @@
          begin
          code-block
          header:
+         line-range
+         range-set
          require:
          statement
          test:)
@@ -15,10 +17,11 @@
 (require (for-syntax racket/base
                      racket/sequence
                      resyntax/test/private/statement)
-         racket/pretty
          racket/stxparam
          rackunit
-         resyntax/base
+         rebellion/base/comparator
+         rebellion/base/range
+         rebellion/collection/range-set
          resyntax/test/private/rackunit
          syntax/parse/define)
 
@@ -30,6 +33,7 @@
   (syntax-parse stx
     #:track-literals
     [(statement statement-id:id . tail)
+     #:do [(syntax-parse-state-cons! 'literas #'statement-id)]
      (define transformer (syntax-local-value #'statement-id (λ () #false)))
      (unless transformer
        (raise-syntax-error #false
@@ -81,60 +85,53 @@
         (syntax/loc stx (set-header! header-code))]))))
 
 
+(begin-for-syntax
+  (define-splicing-syntax-class test-parameters
+    #:attributes ([id 1] [value 1])
+    #:literals (range-set)
+    #:datum-literals (option @lines)
+
+    (pattern (~seq)
+      #:with (id ...) '()
+      #:with (value ...) '())
+
+    (pattern (~seq (option @lines (~and line-set (range-set . _))))
+      #:with (id ...) (list #'current-line-mask)
+      #:with (value ...) (list #'line-set)))
+
+  (define-splicing-syntax-class code-block-test-args
+    #:attributes ([check 1])
+
+    (pattern code:literal-code-block
+      #:with (check ...)
+      (list (syntax/loc #'code (check-suite-does-not-refactor code))))
+
+    (pattern (~seq input-code:literal-code-block expected-code:literal-code-block)
+      #:with (check ...)
+      (list (syntax/loc #'input-code (check-suite-refactors input-code expected-code))))
+
+    (pattern (~seq input-code:literal-code-block ...+
+                   expected-code:literal-code-block)
+      #:when (>= (length (attribute input-code)) 2)
+      #:with (check ...)
+      (for/list ([input-stx (in-list (attribute input-code))])
+        (quasisyntax/loc input-stx
+          (check-suite-refactors #,input-stx expected-code))))))
+
+
 (define-syntax test:
   (statement-transformer
    (λ (stx)
      (syntax-parse stx
        #:track-literals
-       [(_ _ name:str code:literal-code-block)
-        #`(test-case name
-            #,(syntax/loc stx
-                (check-suite-does-not-refactor code)))]
-       [(_ _ name:str input-code:literal-code-block expected-code:literal-code-block)
+       [(_ _ name:str params:test-parameters args:code-block-test-args)
         #`(test-case name
-            #,(syntax/loc stx
-                (check-suite-refactors input-code expected-code)))]
-       [(_ _ name:str
-           input-code:literal-code-block ...+
-           expected-code:literal-code-block)
-        #:when (>= (length (attribute input-code)) 2)
-        #`(test-case name
-            #,@(for/list ([input-stx (in-list (attribute input-code))])
-                 (quasisyntax/loc input-stx
-                   (check-suite-refactors #,input-stx expected-code))))]))))
+            (parameterize ([params.id params.value] ...)
+              args.check ...))]))))
 
 
-(define-syntax (refactoring-test-case stx)
-  (define (add-header input-stx)
-    #`(string-append implicit-program-header #,input-stx))
-  (syntax-parse stx
-    [(_ name:str input:str)
-     #:cut
-     #`(test-case name
-         #,(quasisyntax/loc this-syntax
-             (check-suite-does-not-refactor refactoring-suite-under-test #,(add-header #'input))))]
-    [(_ name:str input:str expected:str)
-     #:cut
-     #`(test-case name
-         #,(quasisyntax/loc this-syntax
-             (check-suite-refactors
-              refactoring-suite-under-test #,(add-header #'input) #,(add-header #'expected))))]
-    [(_ name:str input:str ...+ expected:str)
-     #:cut
-     #:with expected-with-header (add-header #'expected)
-     #`(test-case name
-         #,@(for/list ([input-stx (in-syntax #'(input ...))])
-              (quasisyntax/loc input-stx
-                (check-suite-refactors
-                 refactoring-suite-under-test #,(add-header input-stx) expected-with-header))))]))
-
-
-(define-syntax-parameter refactoring-suite-under-test
-  (λ (stx) (raise-syntax-error #false "can only be used within a refactoring test case" stx)))
-
-
-(define-syntax-parameter implicit-program-header
-  (syntax-parser #:literals (implicit-program-header) [implicit-program-header #'""]))
+(define (line-range first-line last-line)
+  (closed-range first-line last-line #:comparator natural<=>))
 
 
 ;@----------------------------------------------------------------------------------------------------

test/private/grammar.rkt

@@ -1,9 +1,9 @@
 #lang brag
 
 begin: statement*
-statement: COLON-IDENTIFIER (expression | option)+
-@expression: IDENTIFIER | LITERAL-STRING | LITERAL-INTEGER | closed-range | range-set | code-block
+statement: COLON-IDENTIFIER (option | code-block | expression)+
+@expression: range-set | IDENTIFIER | LITERAL-STRING | LITERAL-INTEGER
 option: AT-SIGN-IDENTIFIER expression
 code-block: CODE-BLOCK
-closed-range: LITERAL-INTEGER /DOUBLE-DOT LITERAL-INTEGER
-range-set: closed-range (/COMMA closed-range)+
+range-set: line-range (/COMMA line-range)*
+line-range: LITERAL-INTEGER /DOUBLE-DOT LITERAL-INTEGER

test/private/rackunit.rkt

@@ -4,31 +4,34 @@
 (provide (struct-out code-block)
          current-suite-under-test
          current-header
+         current-line-mask
          set-header!
          add-suite-under-test!
          check-suite-refactors
          check-suite-does-not-refactor)
 
 
-(require racket/list
+(require (except-in racket/list range)
          racket/logging
          racket/match
          racket/port
          racket/pretty
          racket/string
          rackunit
+         rebellion/base/comparator
+         rebellion/base/range
          rebellion/collection/entry
          rebellion/collection/hash
          rebellion/collection/list
          rebellion/collection/multiset
+         rebellion/collection/range-set
          rebellion/collection/vector/builder
          rebellion/streaming/transducer
          rebellion/type/tuple
          resyntax
          resyntax/base
          resyntax/private/logger
          resyntax/private/refactoring-result
-         resyntax/private/run-command
          resyntax/private/source
          resyntax/private/string-replacement
          syntax/modread
@@ -85,10 +88,27 @@
   (current-header header-code))
 
 
+(define current-line-mask (make-parameter (range-set (unbounded-range #:comparator natural<=>))))
+
+
+(define (range-bound-add bound amount)
+  (if (unbounded? bound)
+      unbounded
+      (range-bound (+ (range-bound-endpoint bound) amount) (range-bound-type bound))))
+
+
 (define-check (check-suite-refactors original-program expected-program)
   (define suite (current-suite-under-test))
   (set! original-program (code-block-append (current-header) original-program))
   (set! expected-program (code-block-append (current-header) expected-program))
+  (define header-line-count
+    (count (λ (ch) (equal? ch #\newline)) (string->list (code-block-raw-string (current-header)))))
+  (define modified-line-mask
+    (for/range-set #:comparator natural<=>
+      ([r (in-range-set (current-line-mask))])
+      (range (range-bound-add (range-lower-bound r) header-line-count)
+             (range-bound-add (range-upper-bound r) header-line-count)
+             #:comparator natural<=>)))
   (define logged-messages-builder (make-vector-builder))
 
   (define (save-log log-entry)
@@ -102,7 +122,9 @@
 
   (define results
     (call-with-logs-captured
-     (λ () (refactor (code-block-raw-string original-program) #:suite suite))))
+     (λ ()
+       (refactor (code-block-raw-string original-program)
+                 #:suite suite #:lines modified-line-mask))))
 
   (with-check-info*
       (if (empty? results)

test/private/tokenizer.rkt

@@ -49,7 +49,7 @@
 
 (define-lex-abbrev refactoring-test-identifier
   (concatenation alphabetic
-                 (repetition 0 +inf.0 (union alphabetic symbolic numeric (char-set "-/")))))
+                 (repetition 0 +inf.0 (union alphabetic numeric (char-set "-/")))))
 
 
 (define-tokens refactoring-test-tokens