Test ignored-result-values with DSL (#553)

Also, improve the check failure messages a bit with more info and logs.

Author: jackfirth

default-recommendations/analyzers/ignored-result-values-test.rkt

@@ -0,0 +1,98 @@
+#lang resyntax/test
+require: resyntax/default-recommendations default-recommendations
+header: - #lang racket/base
+
+
+analysis-test: "non-terminal function bodies are ignored"
+--------------------
+(define (f)
+  (displayln "hi")
+  (void))
+--------------------
+@inspect - (displayln "hi")
+@property expression-result
+@assert ignored
+
+
+analysis-test: "terminal function bodies are used"
+--------------------
+(define (f)
+  (displayln "hi")
+  (void))
+--------------------
+@inspect - (void)
+@property expression-result
+@assert used
+
+
+analysis-test: "function arguments are used"
+- (list (void))
+@inspect - (void)
+@property expression-result
+@assert used
+
+
+analysis-test: "applied functions are used"
+- (list (void))
+@inspect - list
+@property expression-result
+@assert used
+
+
+analysis-test: "variable definitions use their right hand side"
+- (define a (void))
+@inspect - (void)
+@property expression-result
+@assert used
+
+
+analysis-test: "syntax definitions use their right hand side"
+--------------------
+(require (for-syntax racket/base))
+(define-syntax a (void))
+--------------------
+@inspect - (void)
+@property expression-result
+@assert used
+
+
+analysis-test: "begin0 forms use their initial expression"
+--------------------
+(begin0 (void)
+  (displayln "after"))
+--------------------
+@inspect - (void)
+@property expression-result
+@assert used
+
+
+analysis-test: "begin0 forms ignore their trailing body"
+--------------------
+(begin0 (void)
+  (displayln "after"))
+--------------------
+@inspect - (displayln "after")
+@property expression-result
+@assert ignored
+
+
+analysis-test: "let expressions ignore their non-terminal body forms"
+--------------------
+(let ()
+  (displayln "hi")
+  (void))
+--------------------
+@inspect - (displayln "hi")
+@property expression-result
+@assert ignored
+
+
+analysis-test: "let expressions use their terminal body form"
+--------------------
+(let ()
+  (displayln "hi")
+  (void))
+--------------------
+@inspect - (void)
+@property expression-result
+@assert used

default-recommendations/analyzers/ignored-result-values.rkt

@@ -96,34 +96,3 @@
 
 (define (stream-append-all streams)
   (apply stream-append streams))
-
-
-(module+ test
-  (test-case "ignored-result-values-analyzer"
-    (define test-stx
-      #'(define (f x)
-          (displayln "hi")
-          x))
-    (define expanded (expand test-stx))
-    (define lambda-path (syntax-path (list 2)))
-    (define displayln-path (syntax-path (list 2 2)))
-    (define displayln-id-path (syntax-path (list 2 2 (tail-syntax 1) 0)))
-    (define hi-path (syntax-path (list 2 2 (tail-syntax 1) 1)))
-    (define x-path (syntax-path (list 2 3)))
-    (check-equal? (syntax->datum (syntax-ref expanded lambda-path))
-                  '(lambda (x) (#%app displayln '"hi") x))
-    (check-equal? (syntax->datum (syntax-ref expanded displayln-path)) '(#%app displayln '"hi"))
-    (check-equal? (syntax->datum (syntax-ref expanded displayln-id-path)) 'displayln)
-    (check-equal? (syntax->datum (syntax-ref expanded hi-path)) ''"hi")
-    (check-equal? (syntax->datum (syntax-ref expanded x-path)) 'x)
-
-    (define actual (expansion-analyze ignored-result-values-analyzer expanded))
-
-    (define expected
-      (syntax-property-bundle
-       (syntax-property-entry lambda-path 'expression-result 'used)
-       (syntax-property-entry displayln-path 'expression-result 'ignored)
-       (syntax-property-entry displayln-id-path 'expression-result 'used)
-       (syntax-property-entry hi-path 'expression-result 'used)
-       (syntax-property-entry x-path 'expression-result 'used)))
-    (check-equal? actual expected)))

private/source.rkt

@@ -237,7 +237,19 @@
 
     (define property-selection-table
       (transduce movement-table
-                 (filtering-values (λ (exp-paths) (equal? (sorted-set-size exp-paths) 1)))
+                 (filtering
+                  (λ (e)
+                    (match-define (entry orig-path exp-paths) e)
+                    (match (sorted-set-size exp-paths)
+                      [1 #true]
+                      [0 #false]
+                      [_
+                       (log-resyntax-debug
+                        (string-append
+                         "ignoring expansion analyzer properties for original path ~a because"
+                         " multiple expanded forms claim to originate from that path")
+                        orig-path)
+                       #false])))
                  (mapping-values (λ (exp-paths) (present-value (sorted-set-least-element exp-paths))))
                  #:into (into-sorted-map syntax-path<=>)))
 

test/private/rackunit.rkt

@@ -246,6 +246,7 @@
     (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-path target-path]
                       ['target-properties target-properties]
                       ['property-key property-key])
       (fail-check "analysis did not assign a value for the given syntax property key")))
@@ -257,6 +258,7 @@
     (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-path target-path]
                       ['property-key property-key]
                       ['actual actual-value]
                       ['expected expected-value])