Add analysis-test: to testing language (#552)

Author: jackfirth

main.rkt

@@ -26,6 +26,8 @@
          #:max-modified-sources (or/c exact-nonnegative-integer? +inf.0)
          #:max-modified-lines (or/c exact-nonnegative-integer? +inf.0))
         resyntax-analysis?)]
+  [reysntax-analyze-for-properties-only
+   (->* (source?) (#:suite refactoring-suite?) syntax-property-bundle?)]
   [refactor! (-> (sequence/c refactoring-result?) void?)]))
 
 
@@ -59,6 +61,7 @@
          resyntax/private/source
          resyntax/private/string-indent
          resyntax/private/string-replacement
+         resyntax/private/syntax-property-bundle
          resyntax/private/syntax-range
          resyntax/private/syntax-replacement
          (except-in racket/list range)
@@ -148,8 +151,8 @@
 
 
 (define/guard (resyntax-analyze source
-                          #:suite [suite default-recommendations]
-                          #:lines [lines (range-set (unbounded-range #:comparator natural<=>))])
+                                #:suite [suite default-recommendations]
+                                #:lines [lines (range-set (unbounded-range #:comparator natural<=>))])
   (define comments (with-input-from-source source read-comment-locations))
   (define source-lang (source-read-language source))
   (guard source-lang #:else
@@ -186,6 +189,31 @@
   (refactoring-result-set #:base-source source #:results results))
 
 
+(define/guard (reysntax-analyze-for-properties-only source #:suite [suite default-recommendations])
+  (define comments (with-input-from-source source read-comment-locations))
+  (define full-source (source->string source))
+  (guard (string-prefix? full-source "#lang racket") #:else
+    (log-resyntax-warning "skipping ~a because it does not start with #lang racket"
+                          (or (source-path source) "string source"))
+    (syntax-property-bundle))
+  (log-resyntax-info "analyzing ~a" (or (source-path source) "string source"))
+  (for ([comment (in-range-set comments)])
+    (log-resyntax-debug "parsed comment: ~a: ~v" comment (substring-by-range full-source comment)))
+
+  (define (skip e)
+    (log-resyntax-error
+     "skipping ~a\n encountered an error during macro expansion\n  error:\n~a"
+     (or (source-path source) "string source")
+     (string-indent (exn-message e) #:amount 3))
+    (syntax-property-bundle))
+
+  (with-handlers ([exn:fail:syntax? skip]
+                  [exn:fail:filesystem:missing-module? skip]
+                  [exn:fail:contract:variable? skip])
+    (define analysis (source-analyze source))
+    (source-code-analysis-added-syntax-properties analysis)))
+
+
 (define (resyntax-analyze-all sources
                               #:suite [suite default-recommendations]
                               #:max-fixes [max-fixes +inf.0]

private/source.rkt

@@ -14,6 +14,7 @@
   [source-original (-> source? unmodified-source?)]
   [source-read-syntax (-> source? syntax?)]
   [source-read-language (-> source? (or/c module-path? #false))]
+  [source-text-of (-> source? syntax? immutable-string?)]
   [source-analyze (->* (source?) (#:lines range-set?) source-code-analysis?)]
   [file-source? (-> any/c boolean?)]
   [file-source (-> path-string? file-source?)]
@@ -30,6 +31,7 @@
   [source-code-analysis-visited-forms (-> source-code-analysis? (listof syntax?))]
   [source-code-analysis-expansion-time-output (-> source-code-analysis? immutable-string?)]
   [source-code-analysis-namespace (-> source-code-analysis? namespace?)]
+  [source-code-analysis-added-syntax-properties (-> source-code-analysis? syntax-property-bundle?)]
   [with-input-from-source (-> source? (-> any) any)]))
 
 
@@ -97,7 +99,8 @@
   #:guard (λ (original contents _) (values original (string->immutable-string contents))))
 
 
-(define-record-type source-code-analysis (code visited-forms expansion-time-output namespace))
+(define-record-type source-code-analysis
+  (code visited-forms expansion-time-output namespace added-syntax-properties))
 
 
 (define (with-input-from-source code proc)
@@ -169,6 +172,15 @@
       (modified-source-original code)))
 
 
+(define (source-text-of code stx)
+  (unless (and (syntax-position stx) (syntax-span stx))
+    (raise-arguments-error 'source-text-of "syntax object does not have source location information"
+                           "syntax" stx))
+  (define start (sub1 (syntax-position stx)))
+  (define end (+ start (syntax-span stx)))
+  (string->immutable-string (substring (source->string code) start end)))
+
+
 (define (source-analyze code #:lines [lines (range-set (unbounded-range #:comparator natural<=>))])
   (define ns (make-base-namespace))
   (parameterize ([current-directory (or (source-directory code) (current-directory))]
@@ -307,7 +319,8 @@
     (source-code-analysis #:code code
                           #:visited-forms visited
                           #:expansion-time-output output
-                          #:namespace ns)))
+                          #:namespace ns
+                          #:added-syntax-properties expansion-analyzer-props-adjusted-for-visits)))
 
 
 (define (syntax-original-and-from-source? stx source-name)

private/syntax-property-bundle.rkt

@@ -11,7 +11,8 @@
   [syntax-property-bundle? (-> any/c boolean?)]
   [syntax-property-bundle-as-map (-> syntax-property-bundle? immutable-sorted-map?)]
   [syntax-property-bundle-entries (-> syntax-property-bundle? (sequence/c syntax-property-entry?))]
-  [syntax-property-bundle-get-property (-> syntax-property-bundle? syntax-path? any/c any/c)]
+  [syntax-property-bundle-get-property
+   (->* (syntax-property-bundle? syntax-path? any/c) (failure-result/c) any/c)]
   [syntax-property-bundle-get-immediate-properties
    (-> syntax-property-bundle? syntax-path? immutable-hash?)]
   [syntax-property-bundle-get-all-properties
@@ -127,7 +128,7 @@
     (check-equal? actual expected)))
 
 
-(define (syntax-property-bundle-get-property prop-bundle path key)
+(define (syntax-property-bundle-get-property prop-bundle path key [failure-result #false])
   (define props-at-path (sorted-map-get (syntax-property-bundle-as-map prop-bundle) path (hash)))
 
   (define (fail)
@@ -138,7 +139,7 @@
      "property key" key
      "properties at path" props-at-path))
 
-  (hash-ref props-at-path key fail))
+  (hash-ref props-at-path key (or failure-result fail)))
 
 
 (module+ test
@@ -161,7 +162,18 @@
       (check-regexp-match #rx"syntax-property-bundle-get-property:" (exn-message thrown))
       (check-regexp-match #rx"path:" (exn-message thrown))
       (check-regexp-match #rx"property key: 'foo" (exn-message thrown))
-      (check-regexp-match #rx"properties at path: '#hash()" (exn-message thrown)))))
+      (check-regexp-match #rx"properties at path: '#hash()" (exn-message thrown)))
+
+    (test-case "empty bundle with failure value provided"
+      (define path (syntax-path (list 1 2 3)))
+      (define actual (syntax-property-bundle-get-property (syntax-property-bundle) path 'foo 42))
+      (check-equal? actual 42))
+
+    (test-case "empty bundle with failure thunk provided"
+      (define path (syntax-path (list 1 2 3)))
+      (define actual
+        (syntax-property-bundle-get-property (syntax-property-bundle) path 'foo (λ () 42)))
+      (check-equal? actual 42))))
 
 
 (define (syntax-property-bundle-get-immediate-properties prop-bundle path)

test.rkt

@@ -11,7 +11,8 @@
          range-set
          require:
          statement
-         test:)
+         test:
+         analysis-test:)
 
 
 (require (for-syntax racket/base
@@ -130,6 +131,33 @@
               args.check ...))]))))
 
 
+(begin-for-syntax
+  (define-syntax-class property-value
+    #:description "a literal syntax property value (an unquoted symbol, boolean, number, or string)"
+    (pattern (~or :id :boolean :number :str))))
+
+
+(define-syntax analysis-test:
+  (statement-transformer
+   (λ (stx)
+     (syntax-parse stx
+       #:track-literals
+       #:datum-literals (option @within @inspect @property @assert)
+       [(_ _ name:str
+           code:literal-code-block
+           (~seq (option @within context-block:literal-code-block) ...
+                 (option @inspect target-block:literal-code-block)
+                 (option @property property-key:id)
+                 (~and assert-option (option @assert expected-value:property-value))))
+        #`(test-case name
+            #,(syntax/loc this-syntax
+                (check-suite-analysis code
+                                      (list context-block ...)
+                                      target-block
+                                      'property-key
+                                      'expected-value)))]))))
+
+
 (define (line-range first-line last-line)
   (closed-range first-line last-line #:comparator natural<=>))
 
@@ -185,7 +213,10 @@
                     (syntax-e line-stx))))
          (define joined-srcloc (srcloc-spanning (first (attribute line)) (last (attribute line))))
          (define joined-lines-stx (datum->syntax #false joined-lines joined-srcloc #false))
-         (datum->syntax #false (list normalized-id joined-lines-stx) this-syntax this-syntax)]))
+         (datum->syntax #false (list normalized-id joined-lines-stx) this-syntax this-syntax)]
+        #:parent-context-modifier (λ (stx) stx)
+        #:parent-srcloc-modifier (λ (stx) stx)
+        #:parent-props-modifier (λ (stx) stx)))
     (define module-datum
       `(module refactoring-test racket/base
          (module test resyntax/test

test/private/grammar.rkt

@@ -3,12 +3,11 @@
 
 begin: statement*
 statement: COLON-IDENTIFIER (option | expression | code-block-sequence)+
-@expression: range-set | IDENTIFIER | LITERAL-STRING | LITERAL-INTEGER
+@expression: standalone-code-block | range-set | IDENTIFIER | LITERAL-STRING | LITERAL-INTEGER
 option: AT-SIGN-IDENTIFIER expression
 
 
-@code-block-sequence: standalone-code-block
-                    | starting-code-block middle-code-block* ending-code-block+
+@code-block-sequence: starting-code-block middle-code-block* ending-code-block+
 standalone-code-block: (/SINGLE-DASH CODE-LINE) | (/DASH-LINE CODE-LINE* /DASH-LINE)
 starting-code-block: /DASH-LINE CODE-LINE* /EQUALS-LINE
 middle-code-block: CODE-LINE* /EQUALS-LINE

test/private/rackunit.rkt

@@ -8,7 +8,8 @@
          set-header!
          add-suite-under-test!
          check-suite-refactors
-         check-suite-does-not-refactor)
+         check-suite-does-not-refactor
+         check-suite-analysis)
 
 
 (require racket/logging
@@ -34,6 +35,9 @@
          resyntax/private/source
          resyntax/private/string-indent
          resyntax/private/string-replacement
+         resyntax/private/syntax-path
+         resyntax/private/syntax-property-bundle
+         resyntax/private/syntax-traversal
          syntax/modread
          syntax/parse
          (except-in racket/list range))
@@ -156,10 +160,11 @@
         (with-handlers
             ([exn:fail?
               (λ (e)
-                (with-check-info (['logs (build-logs-info)]
-                                  ['original (string-block-info (code-block-raw-string original-program))]
-                                  ['expected (string-block-info expected-program)]
-                                  ['exception e])
+                (with-check-info
+                    (['logs (build-logs-info)]
+                     ['original (string-block-info (code-block-raw-string original-program))]
+                     ['expected (string-block-info expected-program)]
+                     ['exception e])
                   (fail-check "an error occurred while processing refactoring results")))])
           (call-with-logs-captured
            (λ () (modified-source-contents (refactoring-result-set-updated-source result-set))))))
@@ -212,6 +217,104 @@
           (fail-check "the program was not changed, but no-op fixes were suggested"))))))
 
 
+(define-check (check-suite-analysis program context-list target property-key expected-value)
+  (define suite (current-suite-under-test))
+  (set! program (code-block-append (current-header) program))
+  (define program-src (string-source (code-block-raw-string program)))
+  (define-values (call-with-logs-captured build-logs-info) (make-log-capture-utilities))
+
+  (define actual-props
+    (call-with-logs-captured
+     (λ () (reysntax-analyze-for-properties-only program-src))))
+
+  (define target-src (string-source (string-trim (code-block-raw-string target))))
+  (define context-src-list
+    (for/list ([ctx (in-list context-list)])
+      (string-source (string-trim (code-block-raw-string ctx)))))
+
+  (define target-path (source-find-path-of program-src target-src #:contexts context-src-list))
+
+  (unless target-path
+    (with-check-info (['logs (build-logs-info)]
+                      ['program (string-block-info (string-source-contents program-src))]
+                      ['target (string-block-info (string-source-contents target-src))])
+      (fail-check "could not locate target subform within the given program")))
+
+  (define (fail-property-lookup)
+    (define target-properties
+      (syntax-property-bundle-get-immediate-properties actual-props target-path))
+    (with-check-info (['logs (build-logs-info)]
+                      ['program (string-block-info (string-source-contents program-src))]
+                      ['target (string-block-info (string-source-contents target-src))]
+                      ['target-properties target-properties]
+                      ['property-key property-key])
+      (fail-check "analysis did not assign a value for the given syntax property key")))
+
+  (define actual-value
+    (syntax-property-bundle-get-property actual-props target-path property-key fail-property-lookup))
+
+  (unless (equal? actual-value expected-value)
+    (with-check-info (['logs (build-logs-info)]
+                      ['program (string-block-info (string-source-contents program-src))]
+                      ['target (string-block-info (string-source-contents target-src))]
+                      ['property-key property-key]
+                      ['actual actual-value]
+                      ['expected expected-value])
+      (fail-check "analysis assigned an incorrect value for the given syntax property key"))))
+
+
+(define (source-find-path-of src target-src #:contexts [context-srcs '()])
+  (define stx (syntax-label-paths (source-read-syntax src) 'source-path))
+  (define target-as-string (string-source-contents target-src))
+
+  (define target-stx
+    (let loop ([stx stx] [context-srcs context-srcs])
+      (match context-srcs
+        ['()
+         (syntax-find-first stx subform
+            #:when (equal? (source-text-of src (attribute subform)) target-as-string))]
+        [(cons next-context remaining-contexts)
+         (define next-as-string (string-source-contents next-context))
+         (define substx
+           (syntax-find-first stx subform
+             #:when (equal? (source-text-of src (attribute subform)) next-as-string)))
+         (and substx (loop substx remaining-contexts))])))
+                  
+  (and target-stx (syntax-property target-stx 'source-path)))
+
+
+(module+ test
+  (test-case "source-find-path-of"
+
+    (test-case "no #lang"
+      (define src (string-source "(+ a b c)"))
+      (define target (string-source "b"))
+      (check-equal? (source-find-path-of src target) (syntax-path (list 2))))
+
+    (test-case "simple #lang"
+      (define src (string-source "#lang racket (define a 1)"))
+      (define target (string-source "a"))
+      (check-equal? (source-find-path-of src target) (syntax-path (list 3 1 1))))
+
+    (test-case "single context"
+      (define src (string-source "(list (+ a) (* a))"))
+      (define target (string-source "a"))
+      (define contexts (list (string-source "(* a)")))
+      (check-equal? (source-find-path-of src target #:contexts contexts) (syntax-path (list 2 1))))
+
+    (test-case "multiple contexts"
+      (define src (string-source "(+ a (+ a (+ a (+ a))))"))
+      (define target (string-source "a"))
+      (define contexts
+        (list (string-source "(+ a (+ a (+ a)))")
+              (string-source "(+ a (+ a))")
+              (string-source "(+ a)")))
+
+      (define actual-path (source-find-path-of src target #:contexts contexts))
+
+      (check-equal? actual-path (syntax-path (list 2 2 2 1))))))
+
+
 (define (refactoring-result-set-matched-rules-info result-set)
   (define matches
     (transduce (refactoring-result-set-results result-set)