More analysis improvements

default-recommendations/analyzers/binding-origin-test.rkt

@@ -0,0 +1,44 @@
+#lang resyntax/test
+
+
+require: resyntax/default-recommendations default-recommendations
+header: - #lang racket/base
+
+
+analysis-test: "local variable use marked as originating from a lexical binding"
+--------------------
+(let ([x 1])
+  (void x))
+--------------------
+@within - (void x)
+@inspect - x
+@property binding-origin
+@assert lexical
+
+
+analysis-test: "#lang racket/base function use marked as originating from required module"
+- (void)
+@inspect - void
+@property binding-origin
+@assert required-module
+
+
+analysis-test: "imported function use marked as originating from required module"
+--------------------
+(require racket/list)
+(first '(a b c))
+--------------------
+@inspect - first
+@property binding-origin
+@assert required-module
+
+
+analysis-test: "module variable use marked as originating from surrounding file"
+--------------------
+(define x 1)
+(void x)
+--------------------
+@within - (void x)
+@inspect - x
+@property binding-origin
+@assert local-module

default-recommendations/analyzers/binding-origin.rkt

@@ -0,0 +1,51 @@
+#lang racket/base
+
+
+(require racket/contract/base)
+
+
+(provide
+ (contract-out
+  [binding-origin-analyzer expansion-analyzer?]))
+
+
+(require racket/match
+         racket/treelist
+         rebellion/streaming/reducer
+         resyntax/default-recommendations/analyzers/private/expansion-identifier
+         resyntax/private/analyzer
+         resyntax/private/logger
+         resyntax/private/syntax-property-bundle)
+
+
+;@----------------------------------------------------------------------------------------------------
+
+
+(define (binding-origin stx)
+  (for/reducer into-syntax-property-bundle
+               ([id (in-treelist (expanded-syntax-identifiers stx))]
+                #:when (equal? (expansion-identifier-kind id) 'usage)
+                #:do [(define origin (expansion-identifier-binding-origin id))]
+                #:when origin)
+    (syntax-property-entry (expansion-identifier-path id) 'binding-origin origin)))
+
+
+(define (expansion-identifier-binding-origin exp-id)
+  (define id-stx (expansion-identifier-syntax exp-id))
+  (define phase (expansion-identifier-phase exp-id))
+  (define mod (expansion-identifier-enclosing-module exp-id))
+  (define binding (identifier-binding id-stx phase #false #false))
+  (match binding
+    ['lexical 'lexical]
+    [(list defining-mod _ ...)
+     (define-values (path base) (module-path-index-split defining-mod))
+     (cond
+       [(and (not base) (not path)) 'local-module]
+       [else 'required-module])]
+    [_
+     (log-resyntax-debug "binding for ~a: ~a" id-stx binding)
+     #false]))
+
+
+(define binding-origin-analyzer
+  (make-expansion-analyzer binding-origin #:name 'binding-origin-analyzer))

default-recommendations/analyzers/identifier-usage-test.rkt

@@ -337,3 +337,43 @@ analysis-test: "twice-used internal function definition in function"
 @inspect - g
 @property usage-count
 @assert 2
+
+
+analysis-test: "unused local variable in macro definition"
+--------------------
+(require (for-syntax racket/base))
+(define-syntax (m stx)
+  (define a 1)
+  stx)
+--------------------
+@inspect - a
+@property usage-count
+@assert 0
+
+
+analysis-test: "once-used local variable in macro definition"
+--------------------
+(require (for-syntax racket/base))
+(define-syntax (m stx)
+  (define a 1)
+  (void a)
+  stx)
+--------------------
+@within - (define a 1)
+@inspect - a
+@property usage-count
+@assert 1
+
+
+analysis-test: "twice-used local variable in macro definition"
+--------------------
+(require (for-syntax racket/base))
+(define-syntax (m stx)
+  (define a 1)
+  (void a a)
+  stx)
+--------------------
+@within - (define a 1)
+@inspect - a
+@property usage-count
+@assert 2

default-recommendations/analyzers/private/expansion-identifier.rkt

@@ -0,0 +1,97 @@
+#lang racket/base
+
+
+(require racket/contract/base)
+
+
+(provide
+ (struct-out expansion-identifier)
+ (contract-out
+  [expanded-syntax-identifiers (-> syntax? (treelist/c expansion-identifier?))]))
+
+
+(require racket/list
+         racket/stream
+         racket/treelist
+         resyntax/private/syntax-path
+         resyntax/private/syntax-traversal
+         syntax/parse)
+
+
+;@----------------------------------------------------------------------------------------------------
+
+
+(struct expansion-identifier (syntax path phase enclosing-module kind)
+  #:transparent
+  #:guard (struct-guard/c identifier?
+                          syntax-path?
+                          exact-nonnegative-integer?
+                          module-path-index?
+                          (or/c 'binding 'usage)))
+
+
+(define (in-expanded-syntax-identifiers orig-expanded-stx)
+  (define labeled-stx (syntax-label-paths orig-expanded-stx 'expanded-path))
+  (let loop ([expanded-stx labeled-stx] [phase 0] [skip? #false] [parents '()])
+
+    (define (recur stx #:phase [phase phase] #:skip-root? [skip? #false] #:parents [parents parents])
+      (loop stx phase skip? parents))
+
+    (define (make-expanded-identifier id-stx kind)
+      (define path (syntax-property id-stx 'expanded-path))
+      (define mod (module-path-index-join #false #false (and (not (empty? parents)) parents)))
+      (expansion-identifier (syntax-ref orig-expanded-stx path) path phase mod kind))
+
+    (syntax-search expanded-stx
+      #:skip-root? skip?
+      #:literal-sets ([kernel-literals #:phase phase])
+
+      [id:id (stream (make-expanded-identifier (attribute id) 'usage))]
+
+      [(begin-for-syntax _ ...) (recur this-syntax #:phase (add1 phase) #:skip-root? #true)]
+
+      [((~or module-id:module module-id:module*) name _ body)
+       (define name-sym (syntax->datum (attribute name)))
+       (stream-append (recur (attribute module-id))
+                      (recur (attribute body) #:phase 0 #:parents (append parents (list name-sym))))]
+
+      [(quote-syntax _ ...) (stream)]
+
+      [(define-values-id:define-values (id ...) body)
+       (define exp-ids
+         (cons (make-expanded-identifier (attribute define-values-id) 'usage)
+               (for/list ([id-stx (in-list (attribute id))])
+                 (make-expanded-identifier id-stx 'binding))))
+       (stream-append exp-ids (recur (attribute body)))]
+
+      [(define-syntaxes-id:define-syntaxes (id ...) body)
+       (define exp-ids
+         (cons (make-expanded-identifier (attribute define-syntaxes-id) 'usage)
+               (for/list ([id-stx (in-list (attribute id))])
+                 (make-expanded-identifier id-stx 'binding))))
+       (stream-append exp-ids (recur (attribute body) #:phase (add1 phase)))]
+
+      [((~or let-id:let-values let-id:letrec-values) ([(id ...) rhs] ...) body ...)
+       (define exp-let-id (make-expanded-identifier (attribute let-id) 'usage))
+       (define exp-ids
+         (for*/list ([id-list (in-list (attribute id))]
+                     [id-stx (in-list id-list)])
+           (make-expanded-identifier id-stx 'binding)))
+       (define inner-exprs (append (attribute rhs) (attribute body)))
+       (apply stream-append (stream exp-let-id) exp-ids (map recur inner-exprs))]
+
+      [(#%plain-lambda formals body ...)
+       (apply stream-append
+              (syntax-search (attribute formals)
+                [id:id (stream (make-expanded-identifier (attribute id) 'binding))])
+              (map recur (attribute body)))]
+
+      [(case-lambda [formals body ...] ...)
+       (apply stream-append
+              (syntax-search #'(formals ...)
+                [id:id (stream (make-expanded-identifier (attribute id) 'binding))])
+              (map recur (append* (attribute body))))])))
+
+
+(define (expanded-syntax-identifiers orig-expanded-stx)
+  (sequence->treelist (in-expanded-syntax-identifiers orig-expanded-stx)))

default-recommendations/analyzers/private/expansion-module.rkt

@@ -0,0 +1,50 @@
+#lang racket/base
+
+
+(require racket/contract/base)
+
+
+(provide
+ (struct-out expansion-module)
+ (contract-out
+  [expanded-syntax-modules (-> syntax? (hash/c (treelist/c symbol?) expansion-module?))]))
+
+
+(require racket/stream
+         racket/treelist
+         resyntax/private/syntax-path
+         resyntax/private/syntax-traversal
+         syntax/parse)
+
+
+;@----------------------------------------------------------------------------------------------------
+
+
+(struct expansion-module (syntax path name declaration-phase parents kind prelude)
+  #:transparent
+  #:guard (struct-guard/c syntax?
+                          syntax-path?
+                          symbol?
+                          exact-nonnegative-integer?
+                          (treelist/c symbol?)
+                          (or/c 'module 'module*)
+                          (or/c module-path? #false)))
+
+
+(define (expanded-syntax-modules orig-expanded-stx)
+  (define results
+    (let loop ([stx (syntax-label-paths orig-expanded-stx 'expanded-path)]
+               [phase 0]
+               [parents (treelist)])
+      (syntax-search stx
+        #:literal-sets ([kernel-literals #:phase phase])
+        [(module name prelude body)
+         (define path (syntax-property this-syntax 'expanded-path))
+         (define name-sym (syntax->datum (attribute name)))
+         (define prelude-datum (syntax->datum (attribute prelude)))
+         (define exp-mod
+           (expansion-module this-syntax path name-sym phase parents 'module prelude-datum))
+         (stream-cons exp-mod (loop (attribute body) 0 (treelist-add parents name-sym)))])))
+  (for/hash ([expmod (in-stream results)])
+    (define ancestry (treelist-add (expansion-module-parents expmod) (expansion-module-name expmod)))
+    (values ancestry expmod)))